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

BGP7DPA4.m

Go to the documentation of this file. 
  1. BGP7DPA4 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 01 Oct 2009 2:53 PM ;
  1.  ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
  1.  ;
  1. EYE(P,BDATE,EDATE,FORECAST) ;EP
  1.  S BGPLEYE=""
  1.  S FORECAST=$G(FORECAST)
  1.  K BGPG S %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) S BGPLEYE="1^"_$P(BGPG(1),U)_"^Diab Eye Ex"
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"","
  1.  S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
  1.  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^BGP7D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
  1.  I Y,$P(BGPLEYE,U,2)<D S BGPLEYE=3_"^"_D_"^Cl "_R
  1.  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^BGP7D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
  1.  I Y,$P(BGPLEYE,U,2)<D S BGPLEYE=$S(R="A2":3,1:3)_"^"_D_"^Cl "_R
  1.  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^BGP7D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
  1.  I Y,$P(BGPLEYE,U,2)<D S BGPLEYE="3^"_D_"^Prv "_R
  1.  ;
  1.  ;K BGPG S %=P_"^LAST DX [BGP EYE EXAM DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  ;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
  1.  ;now check cpt taxonomies
  1.  S T=$O(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
  1.  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)
  1.  .S X=$$CPT^BGP7DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP7DU(P,BDATE,EDATE,T,5)
  1.  S T=$O(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
  1.  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)
  1.  .S X=$$CPT^BGP7DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP7DU(P,BDATE,EDATE,T,5)
  1.  ;;S X=$$LASTPRC^BGP7UTL1(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)
  1.  Q BGPLEYE
  1. EYEREF(P,BDATE,EDATE) ;EP
  1.  S G=$$REFUSAL^BGP7UTL1(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
  1.  I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused"
  1.  Q ""
  1. STAT ;EP - called from forecast report
  1.  NEW BGPD,BGPSTOP
  1.  S BGPSKIP=""
  1.  S BGPSTOP=""
  1.  D STRC^BGP7D212
  1.  I $G(BGPSTOP) S BGPSKIP=1 Q
  1.  I BGPN2 S BGPSKIP=1 Q  ;has an exclusion
  1.  I 'BGPD7 S BGPSKIP=1 Q  ;not in the denominator
  1.  S BGPD=$$HASSTAT(DFN,BGPBDATE,DT)  ;does the pt have a statin pill on this date?
  1.  I BGPD="" S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)_U_"Last Statin: None on file" D I020X Q
  1.  I $P(BGPD,U,2) S BGPSKIP=1 Q  ;not due has a pill
  1.  S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)
  1.  S $P(BGPISSV,U,2)="Last Statin (in past 5 years): "_$$DATE^BGP7UTL($P(BGPD,U,1))
  1.  S $P(BGPISSV,U,2)="Medication end date: "_$$DATE^BGP7UTL($P(BGPD,U,3)) D I020X Q
  1. I020X ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q
  1. HASSTAT(P,BDATE,EDATE) ;EP
  1.  ;look for last statin v med/cpt
  1.  ;if none Q ""
  1.  ;if found Q date^current?^med end date   current=1 if has a pill left today, 0 if not
  1.  NEW %,E,BGPV,S,R,T,T1,BGPMEDS1,K,C
  1.  S BGPV=""
  1.  S %="",E=+$$CODEN^ICPTCOD("4013F"),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1.  I % Q $P(%,U,2)_U_1  ;HAS CPT IN REPORT PERIOD SO CURRENT
  1.  ;GET LAST PRESCRIPTION ENTRY
  1.  K BGPMEDS1 S K=0,R=""
  1.  D GETMEDS^BGP7UTL2(P,$$FMADD^XLFDT(BDATE,-(5*365)),EDATE,,,,,.BGPMEDS1)
  1.  I '$D(BGPMEDS1) Q ""
  1.  S T=$O(^ATXAX("B","BGP PQA STATIN MEDS",0))
  1.  S T1=$O(^ATXAX("B","BGP PQA STATIN NDC",0))
  1.  S X="",R="" F  S X=$O(BGPMEDS1(X),-1) Q:X'=+X!(R]"")  S Y=+$P(BGPMEDS1(X),U,4) D
  1.  .Q:'$D(^AUPNVMED(Y,0))
  1.  .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
  1.  .S G=0
  1.  .S D=$P(^AUPNVMED(Y,0),U)
  1.  .I T,$D(^ATXAX(T,21,"B",D)) S G=1 G STAT1
  1.  .S N=$P($G(^PSDRUG(D,2)),U,4)
  1.  .I N]"",T1,$D(^ATXAX(T1,21,"B",N)) S G=1
  1.  .Q:'G
  1. STAT1 .;
  1.  .S S=$P(^AUPNVMED(Y,0),U,7)  ;days supply
  1.  .S E=$$FMADD^XLFDT($P(BGPMEDS1(X),U,1),S)
  1.  .S C=""  ;V17.1  FIX
  1.  .I E'<BDATE S C=1
  1.  .S R=$P(BGPMEDS1(X),U,1)_U_C_U_E
  1.  Q R
  1. FLU617 ;EP - FLU
  1.  ;get last date and value for patient DFN
  1.  ;date of last^value of last^next date due
  1.  S BGPSKIP=""
  1.  NEW BGPVALUE,BGPD,BGPND
  1.  S BGPAIM=$$AGE^BGP7D36(DFN,2,BGPBDATE)
  1.  I BGPAIM<6 S BGPSKIP=1 Q
  1.  I BGPAGEB>17 S BGPSKIP=1 Q  ;18 and older as of crs v16
  1.  S BGPISSV="",BGPIN=""
  1.  K BGPISSV
  1.  S BGPVALUE=$$FLU^BGP7D3(DFN,BGPBD,BGPED,1)
  1.  I BGPVALUE]"",$P(BGPVALUE,U,3)'=2 S BGPSKIP=1 Q
  1.  S BGPVALUE=$$FLU^BGP7D3(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
  1.  I BGPVALUE="" S BGPISSV=$$TITLE^BGP7DPA1(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP7UTL(BGPBD) Q
  1.  S BGPD=$P(BGPVALUE,U,1)
  1.  S BGPND=$$FMADD^XLFDT(BGPD,365)
  1.  S BGPND=$$DATE^BGP7UTL(BGPND)
  1.  I BGPVALUE["Refus" S BGPIN=1 S BGPISSV=$$TITLE^BGP7DPA1(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP7UTL($P(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP7UTL(BGPBD) Q
  1.  S BGPISSV=$$TITLE^BGP7DPA1(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP7UTL(BGPD)_"|Overdue as of: "_BGPND
  1.  Q
  1. SBIRT ;EP - Alcohol Screening
  1.  ;GET LAST POSITIVE ALCOHOL SCREEN
  1.  I BGPAGEB<9 S BGPSKIP=1 Q
  1.  I BGPAGEB>75 S BGPSKIP=1 Q
  1.  S (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPV)=""
  1.  NEW BGPALL,BGPABNI,BGPBNID
  1.  K BGPALL
  1.  ;get last positive
  1.  K BGPALL
  1.  D ALSCRN^BGP7D55(DFN,BGPBDATE,BGPEDATE,.BGPALL,1)
  1.  I '$D(BGPALL) S BGPSKIP=1 Q  ; no screens
  1.  NEW X,Y,Z,D,G
  1.  S (D,G)=0 F  S D=$O(BGPALL(D)) Q:D'=+D!(G)  D
  1.  .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)
  1.  I 'G S BGPSKIP=1 Q  ;no positive
  1.  ;did patient have bni after this screen?
  1.  K BGPABNI
  1.  S BGPBNID=""
  1.  D BNI^BGP7D24(DFN,$P(G,U,4),$$FMADD^XLFDT($P(G,U,4),7),.BGPABNI)
  1.  I $D(BGPABNI) S BGPSKIP=1 Q  ;HAD A BNI
  1.  S BGPISSV=$$TITLE^BGP7DPA1(BGPGPRAI)_U_"Last Positive Alcohol Screen: "_$$DATE^BGP7UTL($P(G,U,4))_"|BNI/BI Overdue as of "_$$DATE^BGP7UTL($$FMADD^XLFDT($P(G,U,4),7))
  1.  ;
  1. SBIRTX ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q
  1. CVSSTAT ;EP - called from forecast report
  1.  NEW BGPD,BGPSTOP
  1.  S BGPSKIP=""
  1.  S BGPSTOP=""
  1.  D CVD^BGP7D213
  1.  I $G(BGPSTOP) S BGPSKIP=1 Q
  1.  I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5) S BGPSKIP=1 Q
  1.  I BGPN2 S BGPSKIP=1 Q  ;has an exclusion
  1.  I 'BGPD1 S BGPSKIP=1 Q  ;not in the denominator
  1.  S BGPD=$$HASSTAT(DFN,BGPBDATE,DT)  ;does the pt have a statin pill on this date?
  1.  I BGPD="" S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)_U_"Last Statin: None on file" D CVDSTATX Q
  1.  I $P(BGPD,U,2) S BGPSKIP=1 Q  ;not due has a pill
  1.  S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)
  1.  S $P(BGPISSV,U,2)="Last Statin (in past 5 years): "_$$DATE^BGP7UTL($P(BGPD,U,1))
  1.  S $P(BGPISSV,U,2)="Medication end date: "_$$DATE^BGP7UTL($P(BGPD,U,3)) D CVDSTATX Q
  1. CVDSTATX ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q
  1. IAA18 ;EP
  1.  ;I 'BGPACTUP S BGPSKIP=1 Q
  1.  I BGPAGEB<18 S BGPSKIP=1 Q
  1.  S (BGPD,BGPN,BGPN1,BGPREF,BGPNS)=""
  1.  S BGPN1=$$DEP^BGP7D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPN1 NEW X S X=$P(BGPN1,U,4) S BGPD=X,BGPV="2 Mood Disorder DXs "
  1.  S BGPN1=$$DEPSCR^BGP7D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPN1,BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
  1.  S BGPN1=$$DEPEDU^BGP7D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPN1,BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
  1.  I BGPD="" S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)_U_"Last Depression Screen: Never|Overdue as of: "_$$DATE^BGP7UTL(BGPBD) D IAAX Q
  1.  S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
  1.  I BGPNS>BGPED S BGPSKIP=1 D IAAX Q
  1.  S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)_U_"Last Depression Screen: "_$$DATE^BGP7UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP7UTL(BGPNS)
  1.  ;
  1. IAAX ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q
  1. ICRSAMM1 ;EP
  1.  D ICRSAMM^BGP7D51
  1.  I 'BGPD2 S BGPSKIP=1 Q  ;not in up denominator
  1.  I BGPN2 S BGPSKIP=1 Q  ;met numerator
  1.  S L=$$EAPT(DFN,$$FMADD^XLFDT(BGPBDATE,-366),BGPEDATE)
  1.  I L="" S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)_U_"Last RX: Never" D ICRSAMMX Q
  1.  S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)_U_"Last RX: "_$$DATE^BGP7UTL(L)
  1.  ;
  1. ICRSAMMX ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q
  1. EAPT(P,BDATE,EDATE) ;EP
  1.  ;get all ANTIDEPRESSANTS
  1.  K ^TMP($J,"MEDS")
  1.  NEW BGPZ,M,K,Y,T,T2,X,V,G,D,C
  1.  S K=0
  1.  S Y="^TMP($J,""MEDS"",",X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  S T=$O(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT MEDS",0))
  1.  S T2=$O(^ATXAX("B","BGP HEDIS ANTIDEPRESSANT VA CLASS",0))
  1.  S X=0 F  S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X  S Y=+$P(^TMP($J,"MEDS",X),U,4) D
  1.  .Q:'$D(^AUPNVMED(Y,0))
  1.  .S V=$P(^AUPNVMED(Y,0),U,3)
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .S G=0
  1.  .S D=$P(^AUPNVMED(Y,0),U)
  1.  .I T,$D(^ATXAX(T,21,"B",D)) S G=1 D EAPT1 Q
  1.  .S C=$P($G(^PSDRUG(D,0)),U,2)
  1.  .I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1 D EAPT1 Q
  1.  .Q:'G
  1.  K ^TMP($J,"MEDS")
  1.  Q $O(BGPZ(0))
  1. EAPT1 ;
  1.  S BGPZ($$VD^APCLV(V))=""
  1.  Q
  1. ICRSAMM2 ;EP
  1.  D ICRSAMM^BGP7D51
  1.  I 'BGPD2 S BGPSKIP=1 Q  ;not in up denominator
  1.  I BGPN3 S BGPSKIP=1 Q  ;met numerator
  1.  S L=$$EAPT(DFN,$$FMADD^XLFDT(BGPBDATE,-366),BGPEDATE)
  1.  I L="" S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)_U_"Last RX: Never" D ICRSAM2X Q
  1.  S BGPISSV=$$TITLE^BGP7DPA2(BGPGPRAI)_U_"Last RX: "_$$DATE^BGP7UTL(L)
  1.  ;
  1. ICRSAM2X ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q