BUDERP6M.m

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