Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP6DPA4

BGP6DPA4.m

Go to the documentation of this file.
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