BGP8DPA4 ;IHS/CMI/LAB - FORECAST;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
EYE(P,BDATE,EDATE,FORECAST) ;EP
S BGPLEYE=""
S FORECAST=$G(FORECAST)
K BGPG S %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLEYE="1^"_$P(BGPG(1),U)_"^Diab Eye Ex"
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I R="A2",'$$DNKA^BGP8D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y,$P(BGPLEYE,U,2)<D S BGPLEYE=3_"^"_D_"^Cl "_R
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I (R=17!(R=18)!(R=64)),'$$DNKA^BGP8D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y,$P(BGPLEYE,U,2)<D S BGPLEYE=$S(R="A2":3,1:3)_"^"_D_"^Cl "_R
S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I (R=24!(R=79)!(R="08")),'$$DNKA^BGP8D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y,$P(BGPLEYE,U,2)<D S BGPLEYE="3^"_D_"^Prv "_R
;
;K BGPG S %=P_"^LAST DX [BGP EYE EXAM DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
;I $D(BGPG(1)),$P(BGPLEYE,U,2)<$P(BGPG(1),U) S BGPLEYE="3^"_$P(BGPG(1),U)_"^"_$P(BGPG(1),U,2)_" POV" -LORI V13
;now check cpt taxonomies
S T=$O(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
I T D I X]"",$P(BGPLEYE,U,2)<$P(X,U,1) S BGPLEYE=1_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
S T=$O(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
I T D I X]"",$P(BGPLEYE,U,2)<$P(X,U,1) S BGPLEYE=3_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
S X=$$LASTPRC^BGP8UTL1(P,"BGP EYE EXAM PROCS",BDATE,EDATE) I X]"",$P(BGPLEYE,U,2)<$P(X,U,3) S BGPLEYE=3_U_$P(X,U,3)_U_"Proc "_$P(X,U,2)
Q BGPLEYE
EYEREF(P,BDATE,EDATE) ;EP
S G=$$REFUSAL^BGP8UTL1(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused"
Q ""
STAT ;EP - called from forecast report
NEW BGPD,BGPSTOP
S BGPSKIP=""
S BGPSTOP=""
D STRC^BGP8D212
I $G(BGPSTOP) S BGPSKIP=1 Q
I BGPN2 S BGPSKIP=1 Q ;has an exclusion
I 'BGPD7 S BGPSKIP=1 Q ;not in the denominator
S BGPD=$$HASSTAT(DFN,BGPBDATE,DT) ;does the pt have a statin pill on this date?
I BGPD="" S BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last Statin: None on file" D I020X Q
I $P(BGPD,U,2) S BGPSKIP=1 Q ;not due has a pill
S BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)
S $P(BGPISSV,U,2)="Last Statin (in past 5 years): "_$$DATE^BGP8UTL($P(BGPD,U,1))
S $P(BGPISSV,U,2)="Medication end date: "_$$DATE^BGP8UTL($P(BGPD,U,3)) D I020X Q
I020X ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
HASSTAT(P,BDATE,EDATE) ;EP
;look for last statin v med/cpt
;if none Q ""
;if found Q date^current?^med end date current=1 if has a pill left today, 0 if not
NEW %,E,BGPV,S,R,T,T1,BGPMEDS1,K,C
S BGPV=""
S %="",E=+$$CODEN^ICPTCOD("4013F"),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
I % Q $P(%,U,2)_U_1 ;HAS CPT IN REPORT PERIOD SO CURRENT
;GET LAST PRESCRIPTION ENTRY
K BGPMEDS1 S K=0,R=""
D GETMEDS^BGP8UTL2(P,$$FMADD^XLFDT(BDATE,-(5*365)),EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ""
S T=$O(^ATXAX("B","BGP PQA STATIN MEDS",0))
S T1=$O(^ATXAX("B","BGP PQA STATIN NDC",0))
S X="",R="" F S X=$O(BGPMEDS1(X),-1) Q:X'=+X!(R]"") S Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S G=0
.S D=$P(^AUPNVMED(Y,0),U)
.I T,$D(^ATXAX(T,21,"B",D)) S G=1 G STAT1
.S N=$P($G(^PSDRUG(D,2)),U,4)
.I N]"",T1,$D(^ATXAX(T1,21,"B",N)) S G=1
.Q:'G
STAT1 .;
.S S=$P(^AUPNVMED(Y,0),U,7) ;days supply
.S E=$$FMADD^XLFDT($P(BGPMEDS1(X),U,1),S)
.S C="" ;V17.1 FIX
.I E'<BDATE S C=1
.S R=$P(BGPMEDS1(X),U,1)_U_C_U_E
I C Q R
EHROUT ;
;any EHR outside meds?
K BGPMEDS1 S K=0,R=""
D GETMEDS^BGP8UTL2(P,$$DOB^AUPNPAT(P),EDATE,"BGP PQA STATIN MEDS","BGP PQA STATIN NDC",,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ""
S X=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X!(R]"") S Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.Q:$P($G(^AUPNVMED(Y,11)),U,8)="" ;NOT AN EHR OUTSIDE MED
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.Q:$P(^AUPNVMED(Y,0),U,8) ;discontinued
.S V=$P(^AUPNVMED(Y,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S R=1_U_"Statin: "_$$DATE^BGP8UTL($P($P(^AUPNVSIT(V,0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,Y,.01)_" (EHR OUTSIDE)"
Q R
FLU617 ;EP - FLU
;get last date and value for patient DFN
;date of last^value of last^next date due
S BGPSKIP=""
NEW BGPVALUE,BGPD,BGPND
S BGPAIM=$$AGE^BGP8D36(DFN,2,BGPBDATE)
I BGPAIM<6 S BGPSKIP=1 Q
I BGPAGEB>17 S BGPSKIP=1 Q ;18 and older as of crs v16
S BGPISSV="",BGPIN=""
K BGPISSV
S BGPVALUE=$$FLU^BGP8D3(DFN,BGPBD,BGPED,1)
I BGPVALUE]"",$P(BGPVALUE,U,3)'=2 S BGPSKIP=1 Q
S BGPVALUE=$$FLU^BGP8D3(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
I BGPVALUE="" S BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
S BGPD=$P(BGPVALUE,U,1)
S BGPND=$$FMADD^XLFDT(BGPD,365)
S BGPND=$$DATE^BGP8UTL(BGPND)
I BGPVALUE["Refus" S BGPIN=1 S BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP8UTL($P(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
S BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_BGPND
Q
SBIRT ;EP - Alcohol Screening
;GET LAST POSITIVE ALCOHOL SCREEN
I BGPAGEB<9 S BGPSKIP=1 Q
I BGPAGEB>75 S BGPSKIP=1 Q
S (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPV)=""
NEW BGPALL,BGPABNI,BGPBNID
K BGPALL
;get last positive
K BGPALL
D ALSCRN^BGP8D55(DFN,BGPBDATE,BGPEDATE,.BGPALL,1)
I '$D(BGPALL) S BGPSKIP=1 Q ; no screens
NEW X,Y,Z,D,G
S (D,G)=0 F S D=$O(BGPALL(D)) Q:D'=+D!(G) D
.S Y=0 F S Y=$O(BGPALL(D,Y)) Q:Y'=+Y!(G) I $P(BGPALL(D,Y),U,6)["POS" S G=BGPALL(D,Y)
I 'G S BGPSKIP=1 Q ;no positive
;did patient have bni after this screen?
K BGPABNI
S BGPBNID=""
D BNI^BGP8D24(DFN,$P(G,U,4),$$FMADD^XLFDT($P(G,U,4),7),.BGPABNI)
I $D(BGPABNI) S BGPSKIP=1 Q ;HAD A BNI
S BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_"Last Positive Alcohol Screen: "_$$DATE^BGP8UTL($P(G,U,4))_"|BNI/BI Overdue as of "_$$DATE^BGP8UTL($$FMADD^XLFDT($P(G,U,4),7))
;
SBIRTX ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
CVSSTAT ;EP - called from forecast report
NEW BGPD,BGPSTOP
S BGPSKIP=""
S BGPSTOP=""
D CVD^BGP8D213
I $G(BGPSTOP) S BGPSKIP=1 Q
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5) S BGPSKIP=1 Q
I BGPN2 S BGPSKIP=1 Q ;has an exclusion
I 'BGPD1 S BGPSKIP=1 Q ;not in the denominator
S BGPD=$$HASSTAT(DFN,BGPBDATE,DT) ;does the pt have a statin pill on this date?
I BGPD="" S BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last Statin: None on file" D CVDSTATX Q
I $P(BGPD,U,2) S BGPSKIP=1 Q ;not due has a pill
S BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)
S $P(BGPISSV,U,2)="Last Statin (in past 5 years): "_$$DATE^BGP8UTL($P(BGPD,U,1))
S $P(BGPISSV,U,2)="Medication end date: "_$$DATE^BGP8UTL($P(BGPD,U,3)) D CVDSTATX Q
CVDSTATX ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
IAA18 ;EP
;I 'BGPACTUP S BGPSKIP=1 Q
I BGPAGEB<18 S BGPSKIP=1 Q
S (BGPD,BGPN,BGPN1,BGPREF,BGPNS)=""
S BGPN1=$$DEP^BGP8D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPN1 NEW X S X=$P(BGPN1,U,4) S BGPD=X,BGPV="2 Mood Disorder DXs "
S BGPN1=$$DEPSCR^BGP8D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPN1,BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPN1=$$DEPEDU^BGP8D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPN1,BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
I BGPD="" S BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last Depression Screen: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) D IAAX Q
S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
I BGPNS>BGPED S BGPSKIP=1 D IAAX Q
S BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last Depression Screen: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPNS)
;
IAAX ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
EAPT(P,BDATE,EDATE) ;EP
;get all ANTIDEPRESSANTS
K ^TMP($J,"MEDS")
NEW BGPZ,M,K,Y,T,T2,X,V,G,D,C
S K=0
S Y="^TMP($J,""MEDS"",",X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S T=$O(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT MEDS",0))
S T2=$O(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT VA CLASS",0))
S X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X S Y=+$P(^TMP($J,"MEDS",X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.S V=$P(^AUPNVMED(Y,0),U,3)
.Q:'$D(^AUPNVSIT(V,0))
.S G=0
.S D=$P(^AUPNVMED(Y,0),U)
.I T,$D(^ATXAX(T,21,"B",D)) S G=1 D EAPT1 Q
.S C=$P($G(^PSDRUG(D,0)),U,2)
.I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1 D EAPT1 Q
.Q:'G
K ^TMP($J,"MEDS")
Q $O(BGPZ(0))
EAPT1 ;
S BGPZ($$VD^APCLV(V))=""
Q
ICRSAMM2 ;EP
D ICRSAMM^BGP8D51
I 'BGPD2 S BGPSKIP=1 Q ;not in up denominator
I BGPN3 S BGPSKIP=1 Q ;met numerator
S L=$$EAPT(DFN,$$FMADD^XLFDT(BGPBDATE,-366),BGPEDATE)
I L="" S BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last RX: Never" D ICRSAM2X Q
S BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last RX: "_$$DATE^BGP8UTL(L)
;
ICRSAM2X ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
ADULTIZ ;EP - ADULT IZ 19+ AGE APPROPRIATE
F X=1:1:99 S Y="BGPN"_X K @Y
F X=1:1:99 S Y="BGPD"_X K @Y
I BGPAGEB<19 S BGPSKIP=1 D ADULTIZQ Q
NEW BGPVALUE,BGPD,BGPND
S BGPISSO=1,BGPIN="",BGPIN1=""
K BGPISSV
D I13^BGP8D3B
I $G(BGPSTOP)=1 S BGPSKIP=1 D ADULTIZQ Q
I BGPD11,BGPN45 S BGPSKIP=1 D ADULTIZQ Q ;19-59 and up to date
I BGPD11,'BGPN45 D
.S BGPVALUE="Immunizations Overdue for: "_$S('BGPN9:" 1 Tdap ever",1:"")
.I 'BGPN10 S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; 1 Tdap/Td past 10 years"
I BGPD13,BGPN45 S BGPSKIP=1 D ADULTIZQ Q ; 60-64 UP TO DATE
I BGPD13,'BGPN45 D
.S BGPVALUE="Immunizations Overdue for: "_$S('BGPN9:" 1 Tdap ever",1:"")
.I 'BGPN10 S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; 1 Tdap/Td past 10 years"
.I 'BGPN17 S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; 1 Zoster"
I BGPD3,BGPN45 S BGPSKIP=1 D ADULTIZQ Q ; 60-64 UP TO DATE
I BGPD3,'BGPN45 D
.S BGPVALUE="Immunizations Overdue for: "_$S('BGPN9:" 1 Tdap ever",1:"")
.I 'BGPN10 S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; 1 Tdap/Td past 10 years"
.I 'BGPN17 S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; 1 Zoster"
.I 'BGPN38 S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; 1 up-to-date PPSV23/PCV3"
I 'BGPN45 S BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_BGPVALUE
ADULTIZQ ;
F X=1:1:99 S Y="BGPN"_X K @Y
F X=1:1:99 S Y="BGPD"_X K @Y
K BGPVALUE
K BGPDTAP,BGPOPV,BGPMMR,BGPD,BGPT,BGPPER,BGPTET,BGPM,BGPMU,BGPME,BGPHIB,BGPHEP,BGPVAR
Q
BGP8DPA4 ;IHS/CMI/LAB - FORECAST;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
EYE(P,BDATE,EDATE,FORECAST) ;EP
+1 SET BGPLEYE=""
+2 SET FORECAST=$GET(FORECAST)
+3 KILL BGPG
SET %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET BGPLEYE="1^"_$PIECE(BGPG(1),U)_"^Diab Eye Ex"
+5 KILL ^TMP($JOB,"A")
+6 SET A="^TMP($J,""A"","
+7 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+8 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
IF R="A2"
IF '$$DNKA^BGP8D21($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+9 IF Y
IF $PIECE(BGPLEYE,U,2)<D
SET BGPLEYE=3_"^"_D_"^Cl "_R
+10 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
IF (R=17!(R=18)!(R=64))
IF '$$DNKA^BGP8D21($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+11 IF Y
IF $PIECE(BGPLEYE,U,2)<D
SET BGPLEYE=$SELECT(R="A2":3,1:3)_"^"_D_"^Cl "_R
+12 SET (X,Y)=0
SET D=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$PRIMPROV^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"D")
IF (R=24!(R=79)!(R="08"))
IF '$$DNKA^BGP8D21($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+13 IF Y
IF $PIECE(BGPLEYE,U,2)<D
SET BGPLEYE="3^"_D_"^Prv "_R
+14 ;
+15 ;K BGPG S %=P_"^LAST DX [BGP EYE EXAM DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
+16 ;I $D(BGPG(1)),$P(BGPLEYE,U,2)<$P(BGPG(1),U) S BGPLEYE="3^"_$P(BGPG(1),U)_"^"_$P(BGPG(1),U,2)_" POV" -LORI V13
+17 ;now check cpt taxonomies
+18 SET T=$ORDER(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
+19 IF T
Begin DoDot:1
+20 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+21 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLEYE,U,2)<$PIECE(X,U,1)
SET BGPLEYE=1_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+22 SET T=$ORDER(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
+23 IF T
Begin DoDot:1
+24 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+25 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLEYE,U,2)<$PIECE(X,U,1)
SET BGPLEYE=3_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+26 SET X=$$LASTPRC^BGP8UTL1(P,"BGP EYE EXAM PROCS",BDATE,EDATE)
IF X]""
IF $PIECE(BGPLEYE,U,2)<$PIECE(X,U,3)
SET BGPLEYE=3_U_$PIECE(X,U,3)_U_"Proc "_$PIECE(X,U,2)
+27 QUIT BGPLEYE
EYEREF(P,BDATE,EDATE) ;EP
+1 SET G=$$REFUSAL^BGP8UTL1(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
+2 IF $PIECE(G,U)=1
QUIT "2^"_$PIECE(G,U,2)_"^Refused"
+3 QUIT ""
STAT ;EP - called from forecast report
+1 NEW BGPD,BGPSTOP
+2 SET BGPSKIP=""
+3 SET BGPSTOP=""
+4 DO STRC^BGP8D212
+5 IF $GET(BGPSTOP)
SET BGPSKIP=1
QUIT
+6 ;has an exclusion
IF BGPN2
SET BGPSKIP=1
QUIT
+7 ;not in the denominator
IF 'BGPD7
SET BGPSKIP=1
QUIT
+8 ;does the pt have a statin pill on this date?
SET BGPD=$$HASSTAT(DFN,BGPBDATE,DT)
+9 IF BGPD=""
SET BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last Statin: None on file"
DO I020X
QUIT
+10 ;not due has a pill
IF $PIECE(BGPD,U,2)
SET BGPSKIP=1
QUIT
+11 SET BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)
+12 SET $PIECE(BGPISSV,U,2)="Last Statin (in past 5 years): "_$$DATE^BGP8UTL($PIECE(BGPD,U,1))
+13 SET $PIECE(BGPISSV,U,2)="Medication end date: "_$$DATE^BGP8UTL($PIECE(BGPD,U,3))
DO I020X
QUIT
I020X ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
HASSTAT(P,BDATE,EDATE) ;EP
+1 ;look for last statin v med/cpt
+2 ;if none Q ""
+3 ;if found Q date^current?^med end date current=1 if has a pill left today, 0 if not
+4 NEW %,E,BGPV,S,R,T,T1,BGPMEDS1,K,C
+5 SET BGPV=""
+6 SET %=""
SET E=+$$CODEN^ICPTCOD("4013F")
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+7 ;HAS CPT IN REPORT PERIOD SO CURRENT
IF %
QUIT $PIECE(%,U,2)_U_1
+8 ;GET LAST PRESCRIPTION ENTRY
+9 KILL BGPMEDS1
SET K=0
SET R=""
+10 DO GETMEDS^BGP8UTL2(P,$$FMADD^XLFDT(BDATE,-(5*365)),EDATE,,,,,.BGPMEDS1)
+11 IF '$DATA(BGPMEDS1)
QUIT ""
+12 SET T=$ORDER(^ATXAX("B","BGP PQA STATIN MEDS",0))
+13 SET T1=$ORDER(^ATXAX("B","BGP PQA STATIN NDC",0))
+14 SET X=""
SET R=""
FOR
SET X=$ORDER(BGPMEDS1(X),-1)
IF X'=+X!(R]"")
QUIT
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+15 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+16 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+17 SET G=0
+18 SET D=$PIECE(^AUPNVMED(Y,0),U)
+19 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
GOTO STAT1
+20 SET N=$PIECE($GET(^PSDRUG(D,2)),U,4)
+21 IF N]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",N))
SET G=1
+22 IF 'G
QUIT
STAT1 ;
+1 ;days supply
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+2 SET E=$$FMADD^XLFDT($PIECE(BGPMEDS1(X),U,1),S)
+3 ;V17.1 FIX
SET C=""
+4 IF E'<BDATE
SET C=1
+5 SET R=$PIECE(BGPMEDS1(X),U,1)_U_C_U_E
End DoDot:1
+6 IF C
QUIT R
EHROUT ;
+1 ;any EHR outside meds?
+2 KILL BGPMEDS1
SET K=0
SET R=""
+3 DO GETMEDS^BGP8UTL2(P,$$DOB^AUPNPAT(P),EDATE,"BGP PQA STATIN MEDS","BGP PQA STATIN NDC",,,.BGPMEDS1)
+4 IF '$DATA(BGPMEDS1)
QUIT ""
+5 SET X=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(R]"")
QUIT
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+6 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+7 ;NOT AN EHR OUTSIDE MED
IF $PIECE($GET(^AUPNVMED(Y,11)),U,8)=""
QUIT
+8 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+9 ;discontinued
IF $PIECE(^AUPNVMED(Y,0),U,8)
QUIT
+10 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+11 IF 'V
QUIT
+12 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+13 SET R=1_U_"Statin: "_$$DATE^BGP8UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,Y,.01)_" (EHR OUTSIDE)"
End DoDot:1
+14 QUIT R
FLU617 ;EP - FLU
+1 ;get last date and value for patient DFN
+2 ;date of last^value of last^next date due
+3 SET BGPSKIP=""
+4 NEW BGPVALUE,BGPD,BGPND
+5 SET BGPAIM=$$AGE^BGP8D36(DFN,2,BGPBDATE)
+6 IF BGPAIM<6
SET BGPSKIP=1
QUIT
+7 ;18 and older as of crs v16
IF BGPAGEB>17
SET BGPSKIP=1
QUIT
+8 SET BGPISSV=""
SET BGPIN=""
+9 KILL BGPISSV
+10 SET BGPVALUE=$$FLU^BGP8D3(DFN,BGPBD,BGPED,1)
+11 IF BGPVALUE]""
IF $PIECE(BGPVALUE,U,3)'=2
SET BGPSKIP=1
QUIT
+12 SET BGPVALUE=$$FLU^BGP8D3(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
+13 IF BGPVALUE=""
SET BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
QUIT
+14 SET BGPD=$PIECE(BGPVALUE,U,1)
+15 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+16 SET BGPND=$$DATE^BGP8UTL(BGPND)
+17 IF BGPVALUE["Refus"
SET BGPIN=1
SET BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP8UTL($PIECE(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
QUIT
+18 SET BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_BGPND
+19 QUIT
SBIRT ;EP - Alcohol Screening
+1 ;GET LAST POSITIVE ALCOHOL SCREEN
+2 IF BGPAGEB<9
SET BGPSKIP=1
QUIT
+3 IF BGPAGEB>75
SET BGPSKIP=1
QUIT
+4 SET (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPV)=""
+5 NEW BGPALL,BGPABNI,BGPBNID
+6 KILL BGPALL
+7 ;get last positive
+8 KILL BGPALL
+9 DO ALSCRN^BGP8D55(DFN,BGPBDATE,BGPEDATE,.BGPALL,1)
+10 ; no screens
IF '$DATA(BGPALL)
SET BGPSKIP=1
QUIT
+11 NEW X,Y,Z,D,G
+12 SET (D,G)=0
FOR
SET D=$ORDER(BGPALL(D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+13 SET Y=0
FOR
SET Y=$ORDER(BGPALL(D,Y))
IF Y'=+Y!(G)
QUIT
IF $PIECE(BGPALL(D,Y),U,6)["POS"
SET G=BGPALL(D,Y)
End DoDot:1
+14 ;no positive
IF 'G
SET BGPSKIP=1
QUIT
+15 ;did patient have bni after this screen?
+16 KILL BGPABNI
+17 SET BGPBNID=""
+18 DO BNI^BGP8D24(DFN,$PIECE(G,U,4),$$FMADD^XLFDT($PIECE(G,U,4),7),.BGPABNI)
+19 ;HAD A BNI
IF $DATA(BGPABNI)
SET BGPSKIP=1
QUIT
+20 SET BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_"Last Positive Alcohol Screen: "_$$DATE^BGP8UTL($PIECE(G,U,4))_"|BNI/BI Overdue as of "_$$DATE^BGP8UTL($$FMADD^XLFDT($PIECE(G,U,4),7))
+21 ;
SBIRTX ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
CVSSTAT ;EP - called from forecast report
+1 NEW BGPD,BGPSTOP
+2 SET BGPSKIP=""
+3 SET BGPSTOP=""
+4 DO CVD^BGP8D213
+5 IF $GET(BGPSTOP)
SET BGPSKIP=1
QUIT
+6 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5)
SET BGPSKIP=1
QUIT
+7 ;has an exclusion
IF BGPN2
SET BGPSKIP=1
QUIT
+8 ;not in the denominator
IF 'BGPD1
SET BGPSKIP=1
QUIT
+9 ;does the pt have a statin pill on this date?
SET BGPD=$$HASSTAT(DFN,BGPBDATE,DT)
+10 IF BGPD=""
SET BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last Statin: None on file"
DO CVDSTATX
QUIT
+11 ;not due has a pill
IF $PIECE(BGPD,U,2)
SET BGPSKIP=1
QUIT
+12 SET BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)
+13 SET $PIECE(BGPISSV,U,2)="Last Statin (in past 5 years): "_$$DATE^BGP8UTL($PIECE(BGPD,U,1))
+14 SET $PIECE(BGPISSV,U,2)="Medication end date: "_$$DATE^BGP8UTL($PIECE(BGPD,U,3))
DO CVDSTATX
QUIT
CVDSTATX ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
IAA18 ;EP
+1 ;I 'BGPACTUP S BGPSKIP=1 Q
+2 IF BGPAGEB<18
SET BGPSKIP=1
QUIT
+3 SET (BGPD,BGPN,BGPN1,BGPREF,BGPNS)=""
+4 SET BGPN1=$$DEP^BGP8D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+5 IF BGPN1
NEW X
SET X=$PIECE(BGPN1,U,4)
SET BGPD=X
SET BGPV="2 Mood Disorder DXs "
+6 SET BGPN1=$$DEPSCR^BGP8D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 IF BGPN1
IF BGPD<$PIECE(BGPN1,U,4)
SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+8 SET BGPN1=$$DEPEDU^BGP8D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+9 IF BGPN1
IF BGPD<$PIECE(BGPN1,U,4)
SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+10 IF BGPD=""
SET BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last Depression Screen: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
DO IAAX
QUIT
+11 SET BGPNS=$SELECT(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
+12 IF BGPNS>BGPED
SET BGPSKIP=1
DO IAAX
QUIT
+13 SET BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last Depression Screen: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPNS)
+14 ;
IAAX ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
EAPT(P,BDATE,EDATE) ;EP
+1 ;get all ANTIDEPRESSANTS
+2 KILL ^TMP($JOB,"MEDS")
+3 NEW BGPZ,M,K,Y,T,T2,X,V,G,D,C
+4 SET K=0
+5 SET Y="^TMP($J,""MEDS"","
SET X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 SET T=$ORDER(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT MEDS",0))
+7 SET T2=$ORDER(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT VA CLASS",0))
+8 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"MEDS",X))
IF X'=+X
QUIT
SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
Begin DoDot:1
+9 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+10 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 SET G=0
+13 SET D=$PIECE(^AUPNVMED(Y,0),U)
+14 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
DO EAPT1
QUIT
+15 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+16 IF C]""
IF T2
IF $DATA(^ATXAX(T2,21,"B",C))
SET G=1
DO EAPT1
QUIT
+17 IF 'G
QUIT
End DoDot:1
+18 KILL ^TMP($JOB,"MEDS")
+19 QUIT $ORDER(BGPZ(0))
EAPT1 ;
+1 SET BGPZ($$VD^APCLV(V))=""
+2 QUIT
ICRSAMM2 ;EP
+1 DO ICRSAMM^BGP8D51
+2 ;not in up denominator
IF 'BGPD2
SET BGPSKIP=1
QUIT
+3 ;met numerator
IF BGPN3
SET BGPSKIP=1
QUIT
+4 SET L=$$EAPT(DFN,$$FMADD^XLFDT(BGPBDATE,-366),BGPEDATE)
+5 IF L=""
SET BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last RX: Never"
DO ICRSAM2X
QUIT
+6 SET BGPISSV=$$TITLE^BGP8DPA2(BGPGPRAI)_U_"Last RX: "_$$DATE^BGP8UTL(L)
+7 ;
ICRSAM2X ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
ADULTIZ ;EP - ADULT IZ 19+ AGE APPROPRIATE
+1 FOR X=1:1:99
SET Y="BGPN"_X
KILL @Y
+2 FOR X=1:1:99
SET Y="BGPD"_X
KILL @Y
+3 IF BGPAGEB<19
SET BGPSKIP=1
DO ADULTIZQ
QUIT
+4 NEW BGPVALUE,BGPD,BGPND
+5 SET BGPISSO=1
SET BGPIN=""
SET BGPIN1=""
+6 KILL BGPISSV
+7 DO I13^BGP8D3B
+8 IF $GET(BGPSTOP)=1
SET BGPSKIP=1
DO ADULTIZQ
QUIT
+9 ;19-59 and up to date
IF BGPD11
IF BGPN45
SET BGPSKIP=1
DO ADULTIZQ
QUIT
+10 IF BGPD11
IF 'BGPN45
Begin DoDot:1
+11 SET BGPVALUE="Immunizations Overdue for: "_$SELECT('BGPN9:" 1 Tdap ever",1:"")
+12 IF 'BGPN10
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_"; 1 Tdap/Td past 10 years"
End DoDot:1
+13 ; 60-64 UP TO DATE
IF BGPD13
IF BGPN45
SET BGPSKIP=1
DO ADULTIZQ
QUIT
+14 IF BGPD13
IF 'BGPN45
Begin DoDot:1
+15 SET BGPVALUE="Immunizations Overdue for: "_$SELECT('BGPN9:" 1 Tdap ever",1:"")
+16 IF 'BGPN10
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_"; 1 Tdap/Td past 10 years"
+17 IF 'BGPN17
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_"; 1 Zoster"
End DoDot:1
+18 ; 60-64 UP TO DATE
IF BGPD3
IF BGPN45
SET BGPSKIP=1
DO ADULTIZQ
QUIT
+19 IF BGPD3
IF 'BGPN45
Begin DoDot:1
+20 SET BGPVALUE="Immunizations Overdue for: "_$SELECT('BGPN9:" 1 Tdap ever",1:"")
+21 IF 'BGPN10
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_"; 1 Tdap/Td past 10 years"
+22 IF 'BGPN17
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_"; 1 Zoster"
+23 IF 'BGPN38
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_"; 1 up-to-date PPSV23/PCV3"
End DoDot:1
+24 IF 'BGPN45
SET BGPISSV=$$TITLE^BGP8DPA1(BGPGPRAI)_U_BGPVALUE
ADULTIZQ ;
+1 FOR X=1:1:99
SET Y="BGPN"_X
KILL @Y
+2 FOR X=1:1:99
SET Y="BGPD"_X
KILL @Y
+3 KILL BGPVALUE
+4 KILL BGPDTAP,BGPOPV,BGPMMR,BGPD,BGPT,BGPPER,BGPTET,BGPM,BGPMU,BGPME,BGPHIB,BGPHEP,BGPVAR
+5 QUIT
