BUDDRP6M.m

BUDDRP6M ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;

 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66

 ;

 ;

NDC(A,B) ;

 ;a is drug ien

 ;b is taxonomy ien

 NEW BUDNDC

 S BUDNDC=$P($G(^PSDRUG(A,2)),U,4)

 I BUDNDC]"",B,$D(^ATXAX(B,21,"B",BUDNDC)) Q 1

 Q 0

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^BUDDRP6V(DFN,BUD18TH,BUDED) Q  ;quit if no visiT AFTER 18TH BIRTHDAY

 K ^TMP($J,"A")

 S BUDIVD=$$IVD(DFN,BUDBD,$E(BUDBD,1,3)-1_$E(BUDBD,4,7),BUDED)  ;return date of problem list or visit date during report period

 K ^TMP($J,"A")

 ;I BUDIVD="" S X="",X=$$ASPTHER(DFN,BUDBD,BUDED) I X]"" S ^XTMP("BUDDRP6B",BUDJ,BUDH,"IVD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDIVD,U)_U_$P(X,U,2) Q

 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("BUDDRP6B",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("BUDDRP6B",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  ;entered after end date

 .S N=$P($G(^GMR(120.8,X,0)),U,3)

 .;IF PSDRUG CHECK AGAINST MEDS TAXONOMY

 .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(^BUDDTSSC("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(^BUDDTSSC("AD",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01) Q

 ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(VDATE)_" DX: "_Y Q

 I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X

 S Y=$$PLCL^BUDDDU(P,"T6B IVD DEFINITION CODES",EDATE,1)

 I Y Q $$DATE^BUDDUTL1($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(^BUDDTSSC("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(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(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(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(VDATE)_" CPT: "_Y Q

 .;V PROC

 .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(^BUDDTSSC("AP",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(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(^BUDDTSSC("AD",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01) Q

 ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)

 ..Q:Y=""

 ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(VDATE)_" DX/SNOMED: "_Y Q

 I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X

 ;S Y=$$PLCL^BUDDDU(P,"T6B IVD CARDIAC SURGERY CODES",EDATE,1)

 ;I Y Q $$DATE^BUDDUTL1($P(Y,U,3))_" PL "_$P(Y,U,2)

 Q ""

ASPTHER(P,BD,ED) ;

 NEW BUDMEDS1,G,A,C,M,V,V1D

 S G=""

 D GETMEDS^BUDDUTL2(P,BD,ED,"BUD ANTIPLATELET MEDS","BGPMU IVD ANTIPLATELET NDCS",,,.BUDMEDS1)

 I '$D(BUDMEDS1) G ASP  ; no meds

 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  ;d/c'ed BY PROVIDER OR EDIT

 .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^BUDDUTL2(P,BD,ED,"DM AUDIT ASPIRIN DRUGS","",,,.BUDMEDS1)

 I '$D(BUDMEDS1) Q G  ;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  ;d/c'ed BY PROVIDER OR EDIT

 .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

 Q ""

 ;

STATDC(V) ;EP - is the prescription associated with this V MED 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(^BUDDSITE(SITE,11,VLOC))  ;not valid location

 .Q:"AHSORMEI"'[$P(^AUPNVSIT(VSIT,0),U,7)

 .S CLINC=$$CLINIC^APCLV(VSIT,"C")

 .S TIEN=$O(^BUDDCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))

 .I CLINC]"",$D(^BUDDCNTL(TIEN,11,"B",CLINC)) Q  ;not a clinic code we want in any table

 .;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  ;already had a visit to this provider on this date

 ..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, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER

 .S S=0

 .S TIEN=$O(^BUDDCNTL("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(^BUDDTFIV("C",PP,0)) I Y="" S LINE=35 G MEDC1

 .S LINE=$O(^BUDDTFIV("AA",PP,""))

MEDC1 .S S=0

 .I $D(^BUDDCNTL(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)

 ;NOW GO TO BH

 ;BH EXAM

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

BUDDRP6M  ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;

 +1       ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66

 +2       ;

 +3       ;

NDC(A,B)  ;

 +1       ;a is drug ien

 +2       ;b is taxonomy ien

 +3        NEW BUDNDC

 +4        SET BUDNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)

 +5        IF BUDNDC]""

               IF B

                   IF $DATA(^ATXAX(B,21,"B",BUDNDC))

                       QUIT 1

 +6        QUIT 0

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       ;quit if no visiT AFTER 18TH BIRTHDAY

           IF '$$VBBD^BUDDRP6V(DFN,BUD18TH,BUDED)

               QUIT 

 +7        KILL ^TMP($JOB,"A")

 +8       ;return date of problem list or visit date during report period

           SET BUDIVD=$$IVD(DFN,BUDBD,$EXTRACT(BUDBD,1,3)-1_$EXTRACT(BUDBD,4,7),BUDED)

 +9        KILL ^TMP($JOB,"A")

 +10      ;I BUDIVD="" S X="",X=$$ASPTHER(DFN,BUDBD,BUDED) I X]"" S ^XTMP("BUDDRP6B",BUDJ,BUDH,"IVD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDIVD,U)_U_$P(X,U,2) Q

 +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("BUDDRP6B",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("BUDDRP6B",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       ;entered after end date

                   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       ;IF PSDRUG CHECK AGAINST MEDS TAXONOMY

 +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(^BUDDTSSC("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(^BUDDTSSC("AD",Y,TIEN))

                               SET BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(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(^BUDDTSSC("AS",Y,TIEN))

                               SET BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(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^BUDDDU(P,"T6B IVD DEFINITION CODES",EDATE,1)

 +16       IF Y

               QUIT $$DATE^BUDDUTL1($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(^BUDDTSSC("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(^BUDDTSSC("AC",Y,TIEN))

                               SET BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(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(^BUDDTSSC("AC",Y,TIEN))

                               SET BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(VDATE)_" CPT: "_Y

                               QUIT 

                       End DoDot:2

 +36      ;V PROC

 +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(^BUDDTSSC("AP",Y,TIEN))

                               SET BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(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(^BUDDTSSC("AD",Y,TIEN))

                               SET BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(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(^BUDDTSSC("AS",Y,TIEN))

                               SET BUDTOB(9999999-VDATE)=$$DATE^BUDDUTL1(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      ;S Y=$$PLCL^BUDDDU(P,"T6B IVD CARDIAC SURGERY CODES",EDATE,1)

 +50      ;I Y Q $$DATE^BUDDUTL1($P(Y,U,3))_" PL "_$P(Y,U,2)

 +51       QUIT ""

ASPTHER(P,BD,ED) ;

 +1        NEW BUDMEDS1,G,A,C,M,V,V1D

 +2        SET G=""

 +3        DO GETMEDS^BUDDUTL2(P,BD,ED,"BUD ANTIPLATELET MEDS","BGPMU IVD ANTIPLATELET NDCS",,,.BUDMEDS1)

 +4       ; no meds

           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       ;IEN OF V MED

                   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      ;d/c'ed BY PROVIDER OR EDIT

                   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^BUDDUTL2(P,BD,ED,"DM AUDIT ASPIRIN DRUGS","",,,.BUDMEDS1)

 +3       ;no aspirin

           IF '$DATA(BUDMEDS1)

               QUIT G

 +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       ;d/c'ed BY PROVIDER OR EDIT

                   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

 +14       QUIT ""

 +15      ;

STATDC(V) ;EP - is the prescription associated with this V MED 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)