BGP6DPA4 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 01 Oct 2009 2:53 PM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
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^BGP6D21($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^BGP6D21($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^BGP6D21($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^BGP6DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP6DU(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^BGP6DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP6DU(P,BDATE,EDATE,T,5)
;;S X=$$LASTPRC^BGP6UTL1(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^BGP6UTL1(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^BGP6D212
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^BGP6DPA2(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^BGP6DPA2(BGPGPRAI)
S $P(BGPISSV,U,2)="Last Statin (in past 5 years): "_$$DATE^BGP6UTL($P(BGPD,U,1))
S $P(BGPISSV,U,2)="Medication end date: "_$$DATE^BGP6UTL($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^BGP6DU(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^BGP6UTL2(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)
.I E'<BDATE S C=1
.S R=$P(BGPMEDS1(X),U,1)_U_C_U_E
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^BGP6D36(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^BGP6D3(DFN,BGPBD,BGPED,1)
I BGPVALUE]"",$P(BGPVALUE,U,3)'=2 S BGPSKIP=1 Q
S BGPVALUE=$$FLU^BGP6D3(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
I BGPVALUE="" S BGPISSV=$$TITLE^BGP6DPA1(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP6UTL(BGPBD) Q
S BGPD=$P(BGPVALUE,U,1)
S BGPND=$$FMADD^XLFDT(BGPD,365)
S BGPND=$$DATE^BGP6UTL(BGPND)
I BGPVALUE["Refus" S BGPIN=1 S BGPISSV=$$TITLE^BGP6DPA1(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP6UTL($P(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP6UTL(BGPBD) Q
S BGPISSV=$$TITLE^BGP6DPA1(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP6UTL(BGPD)_"|Overdue as of: "_BGPND
Q
BGP6DPA4 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 01 Oct 2009 2:53 PM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+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^BGP6D21($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^BGP6D21($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^BGP6D21($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^BGP6DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+21 SET X=$$TRAN^BGP6DU(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^BGP6DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+25 SET X=$$TRAN^BGP6DU(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 ;;S X=$$LASTPRC^BGP6UTL1(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)
+27 QUIT BGPLEYE
EYEREF(P,BDATE,EDATE) ;EP
+1 SET G=$$REFUSAL^BGP6UTL1(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^BGP6D212
+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^BGP6DPA2(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^BGP6DPA2(BGPGPRAI)
+12 SET $PIECE(BGPISSV,U,2)="Last Statin (in past 5 years): "_$$DATE^BGP6UTL($PIECE(BGPD,U,1))
+13 SET $PIECE(BGPISSV,U,2)="Medication end date: "_$$DATE^BGP6UTL($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^BGP6DU(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^BGP6UTL2(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 IF E'<BDATE
SET C=1
+4 SET R=$PIECE(BGPMEDS1(X),U,1)_U_C_U_E
End DoDot:1
+5 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^BGP6D36(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^BGP6D3(DFN,BGPBD,BGPED,1)
+11 IF BGPVALUE]""
IF $PIECE(BGPVALUE,U,3)'=2
SET BGPSKIP=1
QUIT
+12 SET BGPVALUE=$$FLU^BGP6D3(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
+13 IF BGPVALUE=""
SET BGPISSV=$$TITLE^BGP6DPA1(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP6UTL(BGPBD)
QUIT
+14 SET BGPD=$PIECE(BGPVALUE,U,1)
+15 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+16 SET BGPND=$$DATE^BGP6UTL(BGPND)
+17 IF BGPVALUE["Refus"
SET BGPIN=1
SET BGPISSV=$$TITLE^BGP6DPA1(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP6UTL($PIECE(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP6UTL(BGPBD)
QUIT
+18 SET BGPISSV=$$TITLE^BGP6DPA1(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP6UTL(BGPD)_"|Overdue as of: "_BGPND
+19 QUIT