BUDERP6M ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
;
NDC(A,B) ;
NEW BUDNDC
S BUDNDC=$P($G(^PSDRUG(A,2)),U,4)
I BUDNDC]"",B,$D(^ATXAX(B,21,"B",BUDNDC)) Q 1
Q 0
WARF(P,BD,ED) ;
NEW BUDMEDS1,G,A,C,M,V,V1D,BUDHSABA
S G="",BUDHSABA=""
D GETMEDS^BUDEUTL2(P,BD,ED,"BGP PQA WARFARIN MEDS","BGP PQA WARFARIN NDC",,,.BUDMEDS1)
I '$D(BUDMEDS1) G G
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4)
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.S C=1
I C Q 1
G K BUDMEDS1
D GETMEDS^BUDEUTL2(P,BD,ED,"BGP PQA NON-WARF ANTICOAG MEDS","BGP PQA NON-WARF ANTICOAG NDC",,,.BUDMEDS1)
I '$D(BUDMEDS1) Q 0 ; NO MEDS
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4)
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.S C=1
Q C
J ;EP ;IVD
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD18RB=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUD18RB
Q:BUDMEDV<1
S BUD18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD^BUDERP6V(DFN,BUD18TH,BUDED) Q
I $$WARF(DFN,BUDBD,BUDED) Q
K ^TMP($J,"A")
S BUDIVD=$$IVD(DFN,BUDBD,$E(BUDBD,1,3)-1_$E(BUDBD,4,7),BUDED)
K ^TMP($J,"A")
Q:BUDIVD="" ;no IVD diagnosis
S BUDIVDT=$$ASPTHER(DFN,BUDBD,BUDED)
I BUDIVDT]"" S BUDSECTJ("IVD")=$G(BUDSECTJ("IVD"))+1
;put the rest in demoninator
S BUDSECTJ("PTS")=$G(BUDSECTJ("PTS"))+1 D
.I $G(BUDIVD2L) D
..I BUDIVDT="" S ^XTMP("BUDERP6B",BUDJ,BUDH,"IVD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDIVD,U)_U_$P(BUDIVDT,U,2)
.I $G(BUDIVD1L) D
..I BUDIVDT]"" S ^XTMP("BUDERP6B",BUDJ,BUDH,"IVD1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDIVD,U)_U_$P(BUDIVDT,U,2)
Q
ASPDALG(P,ED) ;
;allergy tracking
NEW BUDD,X,N,G,Y,T,T1,S,A,B,C
S T=$O(^ATXAX("B","BUD ASPD LOWERING MEDS",0))
S T1=$O(^ATXAX("B","BGPMU ASPD LOWERING NDCS",0))
S BUDD=0
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(BUDD) D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>ED
.S N=$P($G(^GMR(120.8,X,0)),U,3)
.;
.I N["PSDRUG"!(N["PSNDF") D
..S Y=+N
..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDD=1
..S D=$P($G(^PSDRUG(Y,2)),U,4)
..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDD=1
Q BUDD
IVD(P,BDATE,PYBD,EDATE) ;EP
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDETSSC("B","T6B IVD DEFINITION CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDETSSC("AD",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01) Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" DX: "_Y Q
I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X
S Y=$$PLCL^BUDEDU(P,"T6B IVD DEFINITION CODES",EDATE,1)
I Y Q $$DATE^BUDEUTL1($P(Y,U,3))_" PL "_$P(Y,U,2)
;NOW CHECK SURGERY IN PYBD
K BUDVS
D ALLV^APCLAPIU(P,PYBD,$$FMADD^XLFDT(BDATE,-1),"BUDVS")
S TIEN=$O(^BUDETSSC("B","T6B IVD CARDIAC SURGERY CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" CPT: "_Y Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" CPT: "_Y Q
.;
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDETSSC("AP",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" PROC: "_$$VAL^XBDIQ1(9000010.08,X,.01) Q
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDETSSC("AD",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01) Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" DX/SNOMED: "_Y Q
I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X
Q ""
ASPTHER(P,BD,ED) ;
NEW BUDMEDS1,G,A,C,M,V,V1D
S G=""
D GETMEDS^BUDEUTL2(P,BD,ED,"BUD ANTIPLATELET MEDS","BGPMU IVD ANTIPLATELET NDCS",,,.BUDMEDS1)
I '$D(BUDMEDS1) G ASP
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4)
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C Q C
ASP ;
S G=""
D GETMEDS^BUDEUTL2(P,BD,ED,"DM AUDIT ASPIRIN DRUGS","",,,.BUDMEDS1)
I '$D(BUDMEDS1) G EHRO ;no aspirin
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C Q C
EHRO ;EPRES
;EHR OUTSIDE
S C=$$PRES^BUDERP6W(P,$O(^ATXAX("B","BUD ANTIPLATELET MEDS",0)),BD,ED,$O(^ATXAX("B","BGPMU IVD ANTIPLATELET NDCS",0)))
I C]"" Q 1_U_$P(C,U,1)_" on "_$$FMTE^XLFDT($P(C,U,3))
S C=$$PRES^BUDERP6W(P,$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0)),BD,ED)
Q ""
;
STATDC(V) ;EP - is the prescription discontinued?
I '$G(V) Q ""
I '$D(^AUPNVMED(V,0)) Q 0
NEW P,S,X
S P=$S($D(^PSRX("APCC",V)):$O(^(V,0)),1:0)
I 'P Q 0
S X=$P($G(^PSRX(P,0)),U,15)
I X=12 Q 1
I X=13 Q 1
I X=14 Q 1
I X=15 Q 1
S X=$P($G(^PSRX(P,"STA")),U,1)
I X=12 Q 1
I X=13 Q 1
I X=14 Q 1
I X=15 Q 1
Q 0
GETV(P,BD,ED,SITE) ;EP - get all visits for this patient and COUNT MEDICAL VISITS
NEW TV,T35V,T6V,MEDV,MEDVI,LASTV,A,X,VLOC,CLINC,TIEN,VSIT,VDATE,PP,S,LINE,D
S TV=0,T35V=0,T6V=0,MEDV=0,MEDVI="",LASTV=""
S A="A(""VISITS"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED),E=$$START1^APCLDF(B,A)
S X=0 F S X=$O(A("VISITS",X)) Q:X'=+X!(MEDV>1) S VSIT=$P(A("VISITS",X),U,5) D
.Q:'$D(^AUPNVSIT(VSIT,0))
.Q:'$P(^AUPNVSIT(VSIT,0),U,9)
.Q:$P(^AUPNVSIT(VSIT,0),U,11)
.S VLOC=$P(^AUPNVSIT(VSIT,0),U,6)
.Q:VLOC=""
.Q:'$D(^BUDESITE(SITE,11,VLOC))
.Q:"AHSORMEI"'[$P(^AUPNVSIT(VSIT,0),U,7)
.S CLINC=$$CLINIC^APCLV(VSIT,"C")
.S TIEN=$O(^BUDECNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
.I CLINC]"",$D(^BUDECNTL(TIEN,11,"B",CLINC)) Q
.;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
.S VDATE=$$VD^APCLV(VSIT)
.S PP=$$PRIMPROV^APCLV(VSIT,"I")
.I $P(^AUPNVSIT(VSIT,0),U,7)="I" Q ;don't count I visits
.I '$D(^AUPNVPOV("AD",VSIT)) Q
.S S=0
.I PP]"" D
..S D=$P($G(A("SAMEPROV",P,VDATE,PP)),U,1)
..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q
..S A("SAMEPROV",P,VDATE,PP)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
.Q:S ;quit if already had a visit to this provider
.S PP=$$PRIMPROV^APCLV(VSIT,"D")
.I PP="" Q
MEDC .;NOW CHECK FOR MEDICAL CARE,
.S S=0
.S TIEN=$O(^BUDECNTL("B","MEDICAL CARE LINE NUMBERS",0))
.;S PP=$$PRIMPROV^APCLV(VSIT,"D")
.I $E($$VAL^XBDIQ1(9000010,VSIT,.06),1,3)="CHS",PP=15 S LINE=2 G MEDC1
.S Y=$O(^BUDETFIV("C",PP,0)) I Y="" S LINE=35 G MEDC1
.S LINE=$O(^BUDETFIV("AA",PP,""))
MEDC1 .S S=0
.I $D(^BUDECNTL(TIEN,11,"B",LINE)) D
..S D=$P($G(A("MEDCARE",P,VDATE,VLOC,TIEN)),U,1)
..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q ;already have a medical care visit on this date
..S A("MEDCARE",P,VDATE,VLOC,TIEN)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
..S MEDV=MEDV+1,MEDVI=VSIT
..Q
Q MEDV
FDEPSCR(P,BD,ED) ;EP RETURN DATE OF FIRST DEPRESSION SCREEN
NEW %,E,D,V,X,G,BUDC,BUDDEPS
NEW BUDG,BUDR,BUDALL
S BUDDEPS=""
S BUDC=0
K BUDG S %=P_"^FIRST EXAM 36;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")
S BUDDEPS=$P($G(BUDG(1)),U,1)
;phq2
K BUDG S %=P_"^FIRST MEAS PHQ2;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(") ;ZW BUDG Q ""
I $D(BUDG(1)),$P(BUDG(1),U,1)<BUDDEPS S BUDDEPS=$P(BUDG(1),U,1)
K BUDG S %=P_"^FIRST MEAS PHQ9;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(") ;ZW BUDG Q ""
I $D(BUDG(1)),$P(BUDG(1),U,1)<BUDDEPS S BUDDEPS=$P(BUDG(1),U,1)
K BUDG S %=P_"^FIRST MEAS PHQT;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(") ;ZW BUDG Q ""
I $D(BUDG(1)),$P(BUDG(1),U,1)<BUDDEPS S BUDDEPS=$P(BUDG(1),U,1)
;SNOMED
;ALL POVS
K BUDG S %=P_"^ALL DX;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")
S E=0 F S E=$O(BUDG(E)) Q:E'=+E D
.S BUDR=+$P(BUDG(E),U,4)
.I $P($G(^AUPNVPOV(BUDR,11)),U,1)'=428181000124104 Q
.I $P(BUDG(E),U,1)<BUDDEPS S BUDDEPS=$P(BUDG(E),U,1)
BHSCR ;
S D=0,E=9999999-BD,D=9999999-ED-1_".9999"
F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V D
.I $P($G(^AMHREC(V,14)),U,5)]"" S I=9999999-$P(D,".") I I<BUDDEPS S BUDDEPS=I Q
.S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X S BUDP=$P($G(^AMHRMSR(X,0)),U) D
..Q:'BUDP
..S BUDP=$P($G(^AUTTMSR(BUDP,0)),U)
..I '(BUDP="PHQ2"!(BUDP="PHQ9")!(BUDP="PHQT")) Q
..S I=9999999-$P(D,".") I I<BUDDEPS S BUDDEPS=I Q
Q BUDDEPS
PAPHPVWH(P,BDATE,EDATE,T,F) ;EP
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through procedures
NEW D,X,Y,G,V,O
S (G,V)=0,I="" F S V=$O(^BWPCD("C",P,V)) Q:V="" D
.Q:'$D(^BWPCD(V,0))
.I $P(^BWPCD(V,0),U,4)'=T Q
.Q:$$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
.S D=$P(^BWPCD(V,0),U,12)
.Q:D<BDATE
.Q:D>EDATE
.I '$P(^BWPCD(V,0),U,8) Q ;has to have HPV yes
.S I=$O(G(0)) I I>D Q
.S G=V,G(D)=""
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S D=$P(^BWPCD(G,0),U,12) Q D
I F=4 S D=$P(^BWPCD(G,0),U,12) Q $$FMTE^XLFDT(D)
Q ""
PAPHPV(P,EDATE,YEARS) ;EP - PAP AND HPV ON THE SAME DAY
NEW BUDC,BUDLPAP,T,BUDLT,B,D,E,L,X,J,BUD,BUDAPAP,BUDG,BUDAHPV
;CHECK WH FOR PAP SMEAR WITH HPV SET TO YES
S BUDLPAP=""
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I T D I X]"",$P(BUDLPAP,U,2)<X S BUDLPAP="1^"_X_"^WH"
.S X=$$PAPHPVWH(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
;GATHER UP ALL PAP SMEARS BY DATE
;BUDAPAP(INVERSE DATE)=1^INTERNAL DATE^VALUE
S BUDC=""
S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
S T=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
S BUDLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...S Z=$P(^AUPNVLAB(X,0),U),Z=$P($G(^LAB(60,Z,0)),U) I Z="PAP SMEAR" S BUDAPAP(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$P(^AUPNVLAB(X,0),U,3) Q
...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDAPAP(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$P(^AUPNVLAB(X,0),U,3) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BUDERP6D(J,T)
...S BUDAPAP(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$P(^AUPNVLAB(X,0),U,3) Q
...Q
K BUDG
S X=P_"^ALL DX [BUD PAP SMEAR DXS 17;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BUDG(")
S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDAPAP(9999999-$P(BUDG(X),U,1))="1^"_$P(BUDG(X),U,1)_"^POV "_$P(BUDG(X),U,2)_U_$P(BUDG(X),U,5)
;S T=$O(^ATXAX("B","BGP CPT PAP",0))
K BUDG
S X=P_"^ALL PROC 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BUDG(")
S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDAPAP(9999999-$P(BUDG(X),U,1))="1^"_$P(BUDG(X),U,1)_"^PROC "_$P(BUDG(X),U,2)_U_$P(BUDG(X),U,5)
;ADD IN ALL CPT CODES
K BUDG
D ALLCPT^BUDEUTL2(P,BDATE,EDATE,$O(^ATXAX("B","BUD CPT PAP UDS 17",0)),"BUDG")
;reorder by date
S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDAPAP(9999999-$P(BUDG(X),U,1))="1^"_$P(BUDG(X),U,1)_U_"CPT "_$P(BUDG(X),U,2)_U_$P(BUDG(X),U,4)
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
;ADD IN ALL WH PAP SMEAR
;
S (G,V)=0,I="" F S V=$O(^BWPCD("C",P,V)) Q:V="" D
.Q:'$D(^BWPCD(V,0))
.I $P(^BWPCD(V,0),U,4)'=T Q
.Q:$$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
.S D=$P(^BWPCD(V,0),U,12)
.Q:D<BDATE
.Q:D>EDATE
.S BUDAPAP(9999999-D)="1^"_D_"^"_"WH PAP SMEAR"
;GATHER UP ALL HPV TESTS
HPV ;
S BUDC=""
K BUDAHPV
S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
S T=$O(^ATXAX("B","BUD HPV LOINC CODES",0))
S BUDLT=$O(^ATXLAB("B","BGP HPV TESTS TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDAHPV(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$P(^AUPNVLAB(X,0),U,3) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BUDERP6D(J,T)
...S BUDAHPV(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$P(^AUPNVLAB(X,0),U,3) Q
...Q
K BUDG
S X=P_"^ALL DX [BGP HPV DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BUDG(")
S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDAHPV(9999999-$P(BUDG(X),U,1))="1^"_$P(BUDG(X),U,1)_"^POV "_$P(BUDG(X),U,2)_U_$P(BUDG(X),U,5)
S T=$O(^ATXAX("B","BUD HPV CPTS",0))
;ADD IN ALL CPT CODES
K BUDG
D ALLCPT^BUDEUTL2(P,BDATE,EDATE,T,"BUDG")
;reorder by date
S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDAHPV(9999999-$P(BUDG(X),U,1))="1^"_$P(BUDG(X),U,1)_"CPT "_$P(BUDG(X),U,2)_U_$P(BUDG(X),U,4)
S T="HPV SCREEN",T=$O(^BWPN("B",T,0))
;ADD IN ALL WH HV SCREENS
;
S (G,V)=0,I="" F S V=$O(^BWPCD("C",P,V)) Q:V="" D
.Q:'$D(^BWPCD(V,0))
.I $P(^BWPCD(V,0),U,4)'=T Q
.Q:$$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
.S D=$P(^BWPCD(V,0),U,12)
.Q:D<BDATE
.Q:D>EDATE
.S BUDAHPV(9999999-D)="1^"_D_"^"_"WH HPV SCREEN"
;LOOP ALL PAPS AND SEE IF HPV ON SAME DAY
S D=0 F S D=$O(BUDAPAP(D)) Q:D'=+D D
.I $D(BUDAHPV(D)),$P(BUDAPAP(D),U,2)>$P(BUDLPAP,U,2) S BUDLPAP="1^"_$P(BUDAPAP(D),U,2)_U_$P(BUDAPAP(D),U,3)_" & "_$P(BUDAHPV(D),U,3)_U_$P(BUDAPAP(D),U,4)
Q BUDLPAP
BUDERP6M ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
+3 ;
NDC(A,B) ;
+1 NEW BUDNDC
+2 SET BUDNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+3 IF BUDNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BUDNDC))
QUIT 1
+4 QUIT 0
WARF(P,BD,ED) ;
+1 NEW BUDMEDS1,G,A,C,M,V,V1D,BUDHSABA
+2 SET G=""
SET BUDHSABA=""
+3 DO GETMEDS^BUDEUTL2(P,BD,ED,"BGP PQA WARFARIN MEDS","BGP PQA WARFARIN NDC",,,.BUDMEDS1)
+4 IF '$DATA(BUDMEDS1)
GOTO G
+5 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+6 SET M=$PIECE(BUDMEDS1(A),U,4)
+7 IF '$DATA(^AUPNVMED(M,0))
QUIT
+8 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+9 SET C=1
End DoDot:1
+10 IF C
QUIT 1
G KILL BUDMEDS1
+1 DO GETMEDS^BUDEUTL2(P,BD,ED,"BGP PQA NON-WARF ANTICOAG MEDS","BGP PQA NON-WARF ANTICOAG NDC",,,.BUDMEDS1)
+2 ; NO MEDS
IF '$DATA(BUDMEDS1)
QUIT 0
+3 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+4 SET M=$PIECE(BUDMEDS1(A),U,4)
+5 IF '$DATA(^AUPNVMED(M,0))
QUIT
+6 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+7 SET C=1
End DoDot:1
+8 QUIT C
J ;EP ;IVD
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUD18RB=($EXTRACT(BUDBD,1,3)-18)_"1231"
+3 IF BUDDOB>BUD18RB
QUIT
+4 IF BUDMEDV<1
QUIT
+5 SET BUD18TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+6 IF '$$VBBD^BUDERP6V(DFN,BUD18TH,BUDED)
QUIT
+7 IF $$WARF(DFN,BUDBD,BUDED)
QUIT
+8 KILL ^TMP($JOB,"A")
+9 SET BUDIVD=$$IVD(DFN,BUDBD,$EXTRACT(BUDBD,1,3)-1_$EXTRACT(BUDBD,4,7),BUDED)
+10 KILL ^TMP($JOB,"A")
+11 ;no IVD diagnosis
IF BUDIVD=""
QUIT
+12 SET BUDIVDT=$$ASPTHER(DFN,BUDBD,BUDED)
+13 IF BUDIVDT]""
SET BUDSECTJ("IVD")=$GET(BUDSECTJ("IVD"))+1
+14 ;put the rest in demoninator
+15 SET BUDSECTJ("PTS")=$GET(BUDSECTJ("PTS"))+1
Begin DoDot:1
+16 IF $GET(BUDIVD2L)
Begin DoDot:2
+17 IF BUDIVDT=""
SET ^XTMP("BUDERP6B",BUDJ,BUDH,"IVD2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$PIECE(BUDIVD,U)_U_$PIECE(BUDIVDT,U,2)
End DoDot:2
+18 IF $GET(BUDIVD1L)
Begin DoDot:2
+19 IF BUDIVDT]""
SET ^XTMP("BUDERP6B",BUDJ,BUDH,"IVD1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$PIECE(BUDIVD,U)_U_$PIECE(BUDIVDT,U,2)
End DoDot:2
End DoDot:1
+20 QUIT
ASPDALG(P,ED) ;
+1 ;allergy tracking
+2 NEW BUDD,X,N,G,Y,T,T1,S,A,B,C
+3 SET T=$ORDER(^ATXAX("B","BUD ASPD LOWERING MEDS",0))
+4 SET T1=$ORDER(^ATXAX("B","BGPMU ASPD LOWERING NDCS",0))
+5 SET BUDD=0
+6 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(BUDD)
QUIT
Begin DoDot:1
+7 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>ED
QUIT
+8 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,3)
+9 ;
+10 IF N["PSDRUG"!(N["PSNDF")
Begin DoDot:2
+11 SET Y=+N
+12 IF T
IF $DATA(^ATXAX(T,21,"AA",Y))
SET BUDD=1
+13 SET D=$PIECE($GET(^PSDRUG(Y,2)),U,4)
+14 IF D
IF $DATA(^ATXAX(T1,21,"AA",D))
SET BUDD=1
End DoDot:2
End DoDot:1
+15 QUIT BUDD
IVD(P,BDATE,PYBD,EDATE) ;EP
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB
+2 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+3 SET TIEN=$ORDER(^BUDETSSC("B","T6B IVD DEFINITION CODES",0))
+4 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+5 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+6 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+7 ;POV/SNOMED
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+9 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+10 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDETSSC("AD",Y,TIEN))
SET BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01)
QUIT
+11 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+12 IF Y=""
QUIT
+13 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" DX: "_Y
QUIT
End DoDot:2
End DoDot:1
+14 IF $ORDER(BUDTOB(0))
SET X=$ORDER(BUDTOB(0))
SET X=BUDTOB(X)
QUIT X
+15 SET Y=$$PLCL^BUDEDU(P,"T6B IVD DEFINITION CODES",EDATE,1)
+16 IF Y
QUIT $$DATE^BUDEUTL1($PIECE(Y,U,3))_" PL "_$PIECE(Y,U,2)
+17 ;NOW CHECK SURGERY IN PYBD
+18 KILL BUDVS
+19 DO ALLV^APCLAPIU(P,PYBD,$$FMADD^XLFDT(BDATE,-1),"BUDVS")
+20 SET TIEN=$ORDER(^BUDETSSC("B","T6B IVD CARDIAC SURGERY CODES",0))
+21 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+22 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+23 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+24 ;CPT
+25 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+26 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+27 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+28 IF Y=""
QUIT
+29 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" CPT: "_Y
QUIT
End DoDot:2
+30 ;V TRANS
+31 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+32 IF '$DATA(^AUPNVTC(X,0))
QUIT
+33 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+34 IF Y=""
QUIT
+35 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" CPT: "_Y
QUIT
End DoDot:2
+36 ;
+37 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+38 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+39 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+40 IF $DATA(^BUDETSSC("AP",Y,TIEN))
SET BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" PROC: "_$$VAL^XBDIQ1(9000010.08,X,.01)
QUIT
End DoDot:2
+41 ;POV/SNOMED
+42 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+43 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+44 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDETSSC("AD",Y,TIEN))
SET BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01)
QUIT
+45 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+46 IF Y=""
QUIT
+47 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDTOB(9999999-VDATE)=$$DATE^BUDEUTL1(VDATE)_" DX/SNOMED: "_Y
QUIT
End DoDot:2
End DoDot:1
+48 IF $ORDER(BUDTOB(0))
SET X=$ORDER(BUDTOB(0))
SET X=BUDTOB(X)
QUIT X
+49 QUIT ""
ASPTHER(P,BD,ED) ;
+1 NEW BUDMEDS1,G,A,C,M,V,V1D
+2 SET G=""
+3 DO GETMEDS^BUDEUTL2(P,BD,ED,"BUD ANTIPLATELET MEDS","BGPMU IVD ANTIPLATELET NDCS",,,.BUDMEDS1)
+4 IF '$DATA(BUDMEDS1)
GOTO ASP
+5 SET BUDISD=""
+6 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+7 SET M=$PIECE(BUDMEDS1(A),U,4)
+8 IF '$DATA(^AUPNVMED(M,0))
QUIT
+9 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+10 IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+11 SET V=$PIECE(BUDMEDS1(A),U,5)
+12 SET V1D=$$VD^APCLV(V)
+13 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+14 IF C
QUIT C
ASP ;
+1 SET G=""
+2 DO GETMEDS^BUDEUTL2(P,BD,ED,"DM AUDIT ASPIRIN DRUGS","",,,.BUDMEDS1)
+3 ;no aspirin
IF '$DATA(BUDMEDS1)
GOTO EHRO
+4 SET BUDISD=""
+5 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+6 ;IEN OF V MED
SET M=$PIECE(BUDMEDS1(A),U,4)
+7 IF '$DATA(^AUPNVMED(M,0))
QUIT
+8 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+9 IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+10 SET V=$PIECE(BUDMEDS1(A),U,5)
+11 SET V1D=$$VD^APCLV(V)
+12 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+13 IF C
QUIT C
EHRO ;EPRES
+1 ;EHR OUTSIDE
+2 SET C=$$PRES^BUDERP6W(P,$ORDER(^ATXAX("B","BUD ANTIPLATELET MEDS",0)),BD,ED,$ORDER(^ATXAX("B","BGPMU IVD ANTIPLATELET NDCS",0)))
+3 IF C]""
QUIT 1_U_$PIECE(C,U,1)_" on "_$$FMTE^XLFDT($PIECE(C,U,3))
+4 SET C=$$PRES^BUDERP6W(P,$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0)),BD,ED)
+5 QUIT ""
+6 ;
STATDC(V) ;EP - is the prescription discontinued?
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVMED(V,0))
QUIT 0
+3 NEW P,S,X
+4 SET P=$SELECT($DATA(^PSRX("APCC",V)):$ORDER(^(V,0)),1:0)
+5 IF 'P
QUIT 0
+6 SET X=$PIECE($GET(^PSRX(P,0)),U,15)
+7 IF X=12
QUIT 1
+8 IF X=13
QUIT 1
+9 IF X=14
QUIT 1
+10 IF X=15
QUIT 1
+11 SET X=$PIECE($GET(^PSRX(P,"STA")),U,1)
+12 IF X=12
QUIT 1
+13 IF X=13
QUIT 1
+14 IF X=14
QUIT 1
+15 IF X=15
QUIT 1
+16 QUIT 0
GETV(P,BD,ED,SITE) ;EP - get all visits for this patient and COUNT MEDICAL VISITS
+1 NEW TV,T35V,T6V,MEDV,MEDVI,LASTV,A,X,VLOC,CLINC,TIEN,VSIT,VDATE,PP,S,LINE,D
+2 SET TV=0
SET T35V=0
SET T6V=0
SET MEDV=0
SET MEDVI=""
SET LASTV=""
+3 SET A="A(""VISITS"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(B,A)
+4 SET X=0
FOR
SET X=$ORDER(A("VISITS",X))
IF X'=+X!(MEDV>1)
QUIT
SET VSIT=$PIECE(A("VISITS",X),U,5)
Begin DoDot:1
+5 IF '$DATA(^AUPNVSIT(VSIT,0))
QUIT
+6 IF '$PIECE(^AUPNVSIT(VSIT,0),U,9)
QUIT
+7 IF $PIECE(^AUPNVSIT(VSIT,0),U,11)
QUIT
+8 SET VLOC=$PIECE(^AUPNVSIT(VSIT,0),U,6)
+9 IF VLOC=""
QUIT
+10 IF '$DATA(^BUDESITE(SITE,11,VLOC))
QUIT
+11 IF "AHSORMEI"'[$PIECE(^AUPNVSIT(VSIT,0),U,7)
QUIT
+12 SET CLINC=$$CLINIC^APCLV(VSIT,"C")
+13 SET TIEN=$ORDER(^BUDECNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
+14 IF CLINC]""
IF $DATA(^BUDECNTL(TIEN,11,"B",CLINC))
QUIT
+15 ;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
+16 SET VDATE=$$VD^APCLV(VSIT)
+17 SET PP=$$PRIMPROV^APCLV(VSIT,"I")
+18 ;don't count I visits
IF $PIECE(^AUPNVSIT(VSIT,0),U,7)="I"
QUIT
+19 IF '$DATA(^AUPNVPOV("AD",VSIT))
QUIT
+20 SET S=0
+21 IF PP]""
Begin DoDot:2
+22 SET D=$PIECE($GET(A("SAMEPROV",P,VDATE,PP)),U,1)
+23 IF D]""
IF D'>$PIECE(^AUPNVSIT(VSIT,0),U)
SET S=1
QUIT
+24 SET A("SAMEPROV",P,VDATE,PP)=$PIECE(^AUPNVSIT(VSIT,0),U)_U_VSIT
End DoDot:2
+25 ;quit if already had a visit to this provider
IF S
QUIT
+26 SET PP=$$PRIMPROV^APCLV(VSIT,"D")
+27 IF PP=""
QUIT
MEDC ;NOW CHECK FOR MEDICAL CARE,
+1 SET S=0
+2 SET TIEN=$ORDER(^BUDECNTL("B","MEDICAL CARE LINE NUMBERS",0))
+3 ;S PP=$$PRIMPROV^APCLV(VSIT,"D")
+4 IF $EXTRACT($$VAL^XBDIQ1(9000010,VSIT,.06),1,3)="CHS"
IF PP=15
SET LINE=2
GOTO MEDC1
+5 SET Y=$ORDER(^BUDETFIV("C",PP,0))
IF Y=""
SET LINE=35
GOTO MEDC1
+6 SET LINE=$ORDER(^BUDETFIV("AA",PP,""))
MEDC1 SET S=0
+1 IF $DATA(^BUDECNTL(TIEN,11,"B",LINE))
Begin DoDot:2
+2 SET D=$PIECE($GET(A("MEDCARE",P,VDATE,VLOC,TIEN)),U,1)
+3 ;already have a medical care visit on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(VSIT,0),U)
SET S=1
QUIT
+4 SET A("MEDCARE",P,VDATE,VLOC,TIEN)=$PIECE(^AUPNVSIT(VSIT,0),U)_U_VSIT
+5 SET MEDV=MEDV+1
SET MEDVI=VSIT
+6 QUIT
End DoDot:2
End DoDot:1
+7 QUIT MEDV
FDEPSCR(P,BD,ED) ;EP RETURN DATE OF FIRST DEPRESSION SCREEN
+1 NEW %,E,D,V,X,G,BUDC,BUDDEPS
+2 NEW BUDG,BUDR,BUDALL
+3 SET BUDDEPS=""
+4 SET BUDC=0
+5 KILL BUDG
SET %=P_"^FIRST EXAM 36;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+6 SET BUDDEPS=$PIECE($GET(BUDG(1)),U,1)
+7 ;phq2
+8 ;ZW BUDG Q ""
KILL BUDG
SET %=P_"^FIRST MEAS PHQ2;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+9 IF $DATA(BUDG(1))
IF $PIECE(BUDG(1),U,1)<BUDDEPS
SET BUDDEPS=$PIECE(BUDG(1),U,1)
+10 ;ZW BUDG Q ""
KILL BUDG
SET %=P_"^FIRST MEAS PHQ9;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+11 IF $DATA(BUDG(1))
IF $PIECE(BUDG(1),U,1)<BUDDEPS
SET BUDDEPS=$PIECE(BUDG(1),U,1)
+12 ;ZW BUDG Q ""
KILL BUDG
SET %=P_"^FIRST MEAS PHQT;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+13 IF $DATA(BUDG(1))
IF $PIECE(BUDG(1),U,1)<BUDDEPS
SET BUDDEPS=$PIECE(BUDG(1),U,1)
+14 ;SNOMED
+15 ;ALL POVS
+16 KILL BUDG
SET %=P_"^ALL DX;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+17 SET E=0
FOR
SET E=$ORDER(BUDG(E))
IF E'=+E
QUIT
Begin DoDot:1
+18 SET BUDR=+$PIECE(BUDG(E),U,4)
+19 IF $PIECE($GET(^AUPNVPOV(BUDR,11)),U,1)'=428181000124104
QUIT
+20 IF $PIECE(BUDG(E),U,1)<BUDDEPS
SET BUDDEPS=$PIECE(BUDG(E),U,1)
End DoDot:1
BHSCR ;
+1 SET D=0
SET E=9999999-BD
SET D=9999999-ED-1_".9999"
+2 FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AMHREC(V,14)),U,5)]""
SET I=9999999-$PIECE(D,".")
IF I<BUDDEPS
SET BUDDEPS=I
QUIT
+4 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X
QUIT
SET BUDP=$PIECE($GET(^AMHRMSR(X,0)),U)
Begin DoDot:2
+5 IF 'BUDP
QUIT
+6 SET BUDP=$PIECE($GET(^AUTTMSR(BUDP,0)),U)
+7 IF '(BUDP="PHQ2"!(BUDP="PHQ9")!(BUDP="PHQT"))
QUIT
+8 SET I=9999999-$PIECE(D,".")
IF I<BUDDEPS
SET BUDDEPS=I
QUIT
End DoDot:2
End DoDot:1
+9 QUIT BUDDEPS
PAPHPVWH(P,BDATE,EDATE,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through procedures
+7 NEW D,X,Y,G,V,O
+8 SET (G,V)=0
SET I=""
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""
QUIT
Begin DoDot:1
+9 IF '$DATA(^BWPCD(V,0))
QUIT
+10 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+11 IF $$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
QUIT
+12 SET D=$PIECE(^BWPCD(V,0),U,12)
+13 IF D<BDATE
QUIT
+14 IF D>EDATE
QUIT
+15 ;has to have HPV yes
IF '$PIECE(^BWPCD(V,0),U,8)
QUIT
+16 SET I=$ORDER(G(0))
IF I>D
QUIT
+17 SET G=V
SET G(D)=""
+18 QUIT
End DoDot:1
+19 IF 'G
QUIT ""
+20 IF F=1
QUIT $SELECT(G:1,1:"")
+21 IF F=2
QUIT G
+22 IF F=3
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT D
+23 IF F=4
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT $$FMTE^XLFDT(D)
+24 QUIT ""
PAPHPV(P,EDATE,YEARS) ;EP - PAP AND HPV ON THE SAME DAY
+1 NEW BUDC,BUDLPAP,T,BUDLT,B,D,E,L,X,J,BUD,BUDAPAP,BUDG,BUDAHPV
+2 ;CHECK WH FOR PAP SMEAR WITH HPV SET TO YES
+3 SET BUDLPAP=""
+4 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+5 IF T
Begin DoDot:1
+6 SET X=$$PAPHPVWH(P,$$FMADD^XLFDT(EDATE,-(YEARS*365)),EDATE,T,3)
End DoDot:1
IF X]""
IF $PIECE(BUDLPAP,U,2)<X
SET BUDLPAP="1^"_X_"^WH"
+7 ;GATHER UP ALL PAP SMEARS BY DATE
+8 ;BUDAPAP(INVERSE DATE)=1^INTERNAL DATE^VALUE
+9 SET BUDC=""
+10 SET BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
+11 SET T=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+12 SET BUDLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+13 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+14 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+16 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+17 SET Z=$PIECE(^AUPNVLAB(X,0),U)
SET Z=$PIECE($GET(^LAB(60,Z,0)),U)
IF Z="PAP SMEAR"
SET BUDAPAP(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+18 IF BUDLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BUDLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BUDAPAP(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+19 IF 'T
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC^BUDERP6D(J,T)
QUIT
+22 SET BUDAPAP(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+23 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+24 KILL BUDG
+25 SET X=P_"^ALL DX [BUD PAP SMEAR DXS 17;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BUDG(")
+26 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDAPAP(9999999-$PIECE(BUDG(X),U,1))="1^"_$PIECE(BUDG(X),U,1)_"^POV "_$PIECE(BUDG(X),U,2)_U_$PIECE(BUDG(X),U,5)
+27 ;S T=$O(^ATXAX("B","BGP CPT PAP",0))
+28 KILL BUDG
+29 SET X=P_"^ALL PROC 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BUDG(")
+30 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDAPAP(9999999-$PIECE(BUDG(X),U,1))="1^"_$PIECE(BUDG(X),U,1)_"^PROC "_$PIECE(BUDG(X),U,2)_U_$PIECE(BUDG(X),U,5)
+31 ;ADD IN ALL CPT CODES
+32 KILL BUDG
+33 DO ALLCPT^BUDEUTL2(P,BDATE,EDATE,$ORDER(^ATXAX("B","BUD CPT PAP UDS 17",0)),"BUDG")
+34 ;reorder by date
+35 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDAPAP(9999999-$PIECE(BUDG(X),U,1))="1^"_$PIECE(BUDG(X),U,1)_U_"CPT "_$PIECE(BUDG(X),U,2)_U_$PIECE(BUDG(X),U,4)
+36 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+37 ;ADD IN ALL WH PAP SMEAR
+38 ;
+39 SET (G,V)=0
SET I=""
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""
QUIT
Begin DoDot:1
+40 IF '$DATA(^BWPCD(V,0))
QUIT
+41 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+42 IF $$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
QUIT
+43 SET D=$PIECE(^BWPCD(V,0),U,12)
+44 IF D<BDATE
QUIT
+45 IF D>EDATE
QUIT
+46 SET BUDAPAP(9999999-D)="1^"_D_"^"_"WH PAP SMEAR"
End DoDot:1
+47 ;GATHER UP ALL HPV TESTS
HPV ;
+1 SET BUDC=""
+2 KILL BUDAHPV
+3 SET BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
+4 SET T=$ORDER(^ATXAX("B","BUD HPV LOINC CODES",0))
+5 SET BUDLT=$ORDER(^ATXLAB("B","BGP HPV TESTS TAX",0))
+6 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 IF BUDLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BUDLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BUDAHPV(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC^BUDERP6D(J,T)
QUIT
+14 SET BUDAHPV(D)="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 KILL BUDG
+17 SET X=P_"^ALL DX [BGP HPV DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BUDG(")
+18 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDAHPV(9999999-$PIECE(BUDG(X),U,1))="1^"_$PIECE(BUDG(X),U,1)_"^POV "_$PIECE(BUDG(X),U,2)_U_$PIECE(BUDG(X),U,5)
+19 SET T=$ORDER(^ATXAX("B","BUD HPV CPTS",0))
+20 ;ADD IN ALL CPT CODES
+21 KILL BUDG
+22 DO ALLCPT^BUDEUTL2(P,BDATE,EDATE,T,"BUDG")
+23 ;reorder by date
+24 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDAHPV(9999999-$PIECE(BUDG(X),U,1))="1^"_$PIECE(BUDG(X),U,1)_"CPT "_$PIECE(BUDG(X),U,2)_U_$PIECE(BUDG(X),U,4)
+25 SET T="HPV SCREEN"
SET T=$ORDER(^BWPN("B",T,0))
+26 ;ADD IN ALL WH HV SCREENS
+27 ;
+28 SET (G,V)=0
SET I=""
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""
QUIT
Begin DoDot:1
+29 IF '$DATA(^BWPCD(V,0))
QUIT
+30 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+31 IF $$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
QUIT
+32 SET D=$PIECE(^BWPCD(V,0),U,12)
+33 IF D<BDATE
QUIT
+34 IF D>EDATE
QUIT
+35 SET BUDAHPV(9999999-D)="1^"_D_"^"_"WH HPV SCREEN"
End DoDot:1
+36 ;LOOP ALL PAPS AND SEE IF HPV ON SAME DAY
+37 SET D=0
FOR
SET D=$ORDER(BUDAPAP(D))
IF D'=+D
QUIT
Begin DoDot:1
+38 IF $DATA(BUDAHPV(D))
IF $PIECE(BUDAPAP(D),U,2)>$PIECE(BUDLPAP,U,2)
SET BUDLPAP="1^"_$PIECE(BUDAPAP(D),U,2)_U_$PIECE(BUDAPAP(D),U,3)_" & "_$PIECE(BUDAHPV(D),U,3)_U_$PIECE(BUDAPAP(D),U,4)
End DoDot:1
+39 QUIT BUDLPAP
