BGP8D21 ; IHS/CMI/LAB - measure 6 ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
I6 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPUP,BGPGFR
S (BGPN1,BGPN2,BGPN3,BGPN4)=0
I 'BGPDM1 S BGPSTOP=1 Q
DMNA ;EP - called from elder care
S BGPBD1=BGP365
S BGPBD2=BGPBDATE
I61 ;EP
S BGPGFR=$$GFR^BGP8D211(DFN,BGPBD1,BGPEDATE)
S BGPESRD=$$ESRD^BGP8D211(DFN,$P(^DPT(DFN,0),U,3),BGPEDATE)
S BGPQUP=$$QUANTUP^BGP8D211(DFN,BGPBD2,BGPEDATE)
S BGPHOLD=BGPGFR_"|"_BGPESRD_"|"_BGPQUP
I $P(BGPESRD,U) S BGPN1=1
I BGPGFR&(BGPQUP) S BGPN1=1
S BGPVALUE=$S(BGPDMD6:"UPDM",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"
I BGPN1 D
.I BGPESRD S BGPVALUE=BGPVALUE_$S(BGPESRD]"":"ESRD: "_$$DATE^BGP8UTL($P(BGPESRD,U,3))_" "_$P(BGPESRD,U,2),1:"") Q
.S BGPVALUE=BGPVALUE_$S(BGPESRD:"; ",1:""),BGPVALUE=BGPVALUE_"GFR: "_$$DATE^BGP8UTL($P(BGPGFR,U,2))
.S BGPVALUE=BGPVALUE_" & UACR: "_$$DATE^BGP8UTL($P(BGPQUP,U,3))_" "_$P(BGPQUP,U,2)
K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPBD1,BGPBD2,BGPQUP,BGPESRD
Q
;
I7 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPVALUE,BGPD1)=""
NEW BGPEYE,BGPJVN
I 'BGPDM1 S BGPSTOP=1 Q
S X=$$LASTDX^BGP8UTL1(DFN,"BGP BILATERAL BLINDNESS DXS",$$DOB^AUPNPAT(DFN),BGPEDATE)
I 'X S X=$$BLINDPL^BGP8D21A(DFN,BGPEDATE)
I X S BGPSTOP=1 Q
;EXCL EYE ENUCLEATION
S X=$$EYEENUC^BGP8D21A(DFN,BGPEDATE)
I X S BGPSTOP=1 Q
I BGPDMD2 S BGPD1=1
DMEYE ;EP - called from elder care
S BGPEYE=$$EYE(DFN,BGPBDATE,BGPEDATE)
S BGPN1=0 I $P(BGPEYE,U)=1!($P(BGPEYE,U)=3) S BGPN1=1
S BGPN2=0 I $P(BGPEYE,U)=1 S BGPN2=1 ;QUALIFIED
S BGPN3=0 I $P(BGPEYE,U)=3 S BGPN3=1 ;OTHER EYE EXAM
S BGPJVN=$$JVN(DFN,BGPBDATE,BGPEDATE)
I $P(BGPJVN,U,1)]"" S BGPN4=1 ;JVN
I $P(BGPJVN,U,2)]"" S BGPN5=1 ;OPTH
I $P(BGPJVN,U,3)]"" S BGPN6=1 ;OPTOMETRY
S BGPVALUE=$S(BGPDMD6:"UPDM",1:"")_$S(BGPDMD2:",AD",1:"")
I BGPDMD3,BGPVALUE]"" S BGPVALUE=BGPVALUE_",AAD"
I BGPDMD3,BGPVALUE="" S BGPVALUE="AAD"
S BGPVALUE=BGPVALUE_"|||"
S X=$S(BGPEYE:"Eval: "_$$DATE^BGP8UTL($P(BGPEYE,U,2))_" "_$P(BGPEYE,U,3),1:"")
I $P(BGPJVN,U,1)]"" S X=X_$S(X]"":"; ",1:""),X=X_$P(BGPJVN,U,1)
I $P(BGPJVN,U,2)]"" S X=X_$S(X]"":"; ",1:""),X=X_$P(BGPJVN,U,2)
I $P(BGPJVN,U,3)]"" S X=X_$S(X]"":"; ",1:""),X=X_$P(BGPJVN,U,3)
S BGPVALUE=BGPVALUE_X
K BGPG,BGPEYE,BGPJVN
K ^TMP($J,"A")
Q
;
I8 ;EP
K BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
S BGPN1=0
I '$G(BGPDMD2) S BGPSTOP=1 Q
S BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
S BGPN1=0 I $P(BGPVALUE,U)=1 S BGPN1=1
I BGPRTYPE=1 S BGPVALUE="AD|||" I BGPN1 S BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
I BGPRTYPE'=1 S BGPVALUE="AD|||"_$$DATE^BGP8UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
Q
I9 ;EP
K BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9
NEW BGPTC,BGPPN,BGPV1
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14)=0
I '$G(BGPACTUP) S BGPSTOP=1 Q
S BGPD1=1 ;USER POP
S A=$$AGE^AUPNPAT(DFN,BGPBDATE)
I A<6 S BGPD2=1
I A>15,A<22 S BGPD3=1
I A>21,A<35 S BGPD4=1
I A>34,A<45 S BGPD5=1
I A>44,A<55 S BGPD6=1
I A>54,A<75 S BGPD7=1
I A>74 S BGPD8=1
I A<3 S BGPD9=1
I A>2,A<6 S BGPD11=1
I A>5,A<10 S BGPD12=1
I A>9,A<13 S BGPD13=1
I A>12,A<16 S BGPD14=1
S BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE) ;DOCUMENTED DENTAL VISIT
S BGPN1=0 I $P(BGPVALUE,U)=1 S BGPN1=1
;S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
S BGPN9=0
S BGPDEVV=$$DENTSRVD^BGP8D211(DFN,BGPBDATE,BGPEDATE) ;ddocumented dental visit BGPN9 GPRA DEV
I BGPDEVV S BGPN9=1
S BGPV1=$$DENTDEV(DFN,BGPBDATE,BGPEDATE) ;DENTAL EXAM
S BGPN3=0 I $P(BGPV1,U)=1 S BGPN3=1
S BGPTC=$$TC(DFN,BGPBDATE,BGPEDATE) ;ALL TX COMPLETED
S BGPN4=0 I $P(BGPTC,U,1) S BGPN4=1
S BGPD10=$$PREG(DFN,BGPBDATE,BGPEDATE)
S BGPPN="" I BGPD10 S BGPPN=$$PN(DFN,BGPBDATE,BGPEDATE)
S BGPN6=0 I $P(BGPPN,U,1) S BGPN6=1
S BGPN7=0,BGPN8=0
S BGPGAX=""
I BGPD2 D
.S BGPGAX=$$GA^BGP8D3A(DFN,BGPBDATE,BGPEDATE)
.S BGPN7=$P(BGPGAX,U,1),BGPN8=$P(BGPGAX,U,2)
S BGPVALUD="UP" I BGPN9 S BGPVALUD="UP,UP w/dental visit "_$$DATE^BGP8UTL($P(BGPDEVV,U,2))
S BGPVALUD=BGPVALUD_$S(BGPD10:",PREG",1:"")
S BGPVALUD=BGPVALUD_"|||"
I BGPN9 S BGPVALUD=BGPVALUD_"Visit: "_$$DATE^BGP8UTL($P(BGPDEVV,U,2))_" "_$P(BGPDEVV,U,3)
I BGPN3 S BGPVALUD=BGPVALUD_";Exam: "_$$DATE^BGP8UTL($P(BGPV1,U,2))_" CDT "_$P(BGPV1,U,3)
I BGPTC S BGPVALUD=BGPVALUD_$S(BGPV1:"; ",1:"")_"TC: "_$$DATE^BGP8UTL($P(BGPTC,U,2))_" "_$P(BGPTC,U,3)
I BGPN6 S BGPVALUD=BGPVALUD_$S(BGPTC:"; ",1:""),BGPVALUD=BGPVALUD_"PN: "_$$DATE^BGP8UTL($P(BGPPN,U,2))_" "_$P(BGPPN,U,3)
I BGPN7 S BGPVALUD=BGPVALUD_" GEN/SSC: "_$P(BGPGAX,U,3)
;S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
I BGPRTYPE'=1 S BGPVALUE="UP|||"_$$DATE^BGP8UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
I BGPRTYPE=1 S X=BGPVALUE S BGPVALUE="UP|||" I BGPN1 S BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($P(X,U,2))_" "_$P(X,U,3)
K BGPDEVV
Q
PREG(P,BDATE,EDATE) ;EP
NEW X,Y,Z
S (X,Y)=0
I $P(^DPT(P,0),U,2)'="F" Q 0
S X=$$PREG^BGP8D7(P,$$FMADD^XLFDT(EDATE,-608),EDATE,1,1,,BDATE,EDATE) ;V17.1 CMI/LAB ADDED DATES FOR CURRENTLY PREGNANT
I BGPAGEB>9 S Y=$$BF(P,BDATE,EDATE)
Q (X+Y)
BF(P,BDATE,EDATE) ;EP
NEW BGPG,Y,X,E,D,T,%,SN
;S Y="BGPG(",X=P_"^LAST [BGP BREASTFEEDING DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=$$LASTDX^BGP8UTL1(P,"BGP BREASTFEEDING DXS",BDATE,EDATE)
I X Q 1_U_$$DATE^BGP8UTL($P(X,U,3))
K BGPG
S Y="BGPG("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG) Q ""
S SN=$O(^BGPSNOMR("B","BREASTFEEDING PATIENT ED",0))
S (X,D)=0,%="",T="" F S X=$O(BGPG(X)) Q:X'=+X!(%]"") D
.S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="BF-BC" S %=T_U_$P(BGPG(X),U) Q
.I T="BF-BP" S %=T_U_$P(BGPG(X),U) Q
.I T="BF-CS" S %=T_U_$P(BGPG(X),U) Q
.I T="BF-EQ" S %=T_U_$P(BGPG(X),U) Q
.I T="BF-FU" S %=T_U_$P(BGPG(X),U) Q
.I T="BF-HC" S %=T_U_$P(BGPG(X),U) Q
.I T="BF-ON" S %=T_U_$P(BGPG(X),U) Q
.I T="BF-M" S %=T_U_$P(BGPG(X),U) Q
.I T="BF-MK" S %=T_U_$P(BGPG(X),U) Q
.I T="BF-N" S %=T_U_$P(BGPG(X),U) Q
.I $P(T,"-")]"",$D(^BGPSNOMR(SN,11,"B",$P(T,"-"))) S %=T_U_$P(BGPG(X),U) Q
I %]"" Q 1_U_$$DATE^BGP8UTL($P(%,U,2))
Q 0
;
DENTDEV(P,BDATE,EDATE) ;
;ADA 1050, 1045
NEW BGPG,BGPC,%
S BGPC="",%=P_"^LAST ADA [BGP DENTAL EXAM ADA CODES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U)_"^"_"RPMS DENTAL "_$P(BGPG(1),U,2)
S BGPC=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP DENTAL EXAM CPTS",0)),5)
I BGPC Q 1_U_BGPC
Q ""
TC(P,BDATE,EDATE) ;
NEW BGPG,BGPC,%,V,X
S BGPC="",%=P_"^LAST ADA 9990;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U)_"^"_"RPMS DENTAL "_$P(BGPG(1),U,2)
Q ""
PN(P,BDATE,EDATE) ;
NEW BGPG,BGPC,%
S BGPC="",%=P_"^LAST ADA [BGP PRENATAL DENTAL ADA CODES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U)_"^"_"RPMS DENTAL "_$P(BGPG(1),U,2)
Q ""
DENTSRV(P,BDATE,EDATE,FORECAST) ;EP
NEW BGPG,BGPC
K BGPG
S FORECAST=$G(FORECAST)
S BGPC="",%=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPC=$P(BGPG(1),U)_"^"_"RPMS DENTAL "_$P(BGPG(1),U,2)
K BGPG
S %=P_"^LAST ADA 0190;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_"RPMS DENTAL "_$P(BGPG(1),U,2)
K BGPG
S %=P_"^LAST ADA 0191;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_"RPMS DENTAL "_$P(BGPG(1),U,2)
K BGPG
S BGPG(1)=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP DENTAL EXAM CPT 0190",0)),5)
I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_"CDT "_$P(BGPG(1),U,2)
K BGPG
S %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_$P(BGPG(1),U,3)
I BGPC]"",'FORECAST Q "1^"_BGPC
S BGPG=$$LASTDX^BGP8UTL1(P,"BGP DENTAL EXAM DXS",BDATE,EDATE)
I BGPG,'$G(FORECAST) Q "1^"_$P(BGPG,U,3)_"^"_$P(BGPG,U,2)
I BGPG,$G(FORECAST),$P(BGPG,U,3)>$P(BGPC,U) S BGPC=$P(BGPG,U,3)_"^POV "_$P(BGPG,U,2)
K BGPG S G="" S %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG) D I G]"",'$G(FORECAST) Q G
.S X=0 F S X=$O(BGPG(X)) Q:X'=+X S V=$P(BGPG(X),U,5) D
..I $P($G(^AUPNVSIT(V,0)),U,3)="C" D
...I '$G(FORECAST) S G=1_"^"_$P(BGPG(X),U)_"^CHS VISIT RPMS DENTAL "_$P(BGPG(X),U,2) Q
...I $G(FORECAST),$P(BGPG(X),U)>$P(BGPC,U) S BGPC=$P(BGPG(X),U)_"^CHS RPMS DENTAL VISIT"
I BGPC]"" S BGPC=1_"^"_BGPC Q BGPC
Q BGPC
;
EYE(P,BDATE,EDATE) ;EP - REPORT PERIOD
NEW BGPLEYE,T,E,%,X,R,Y,D,J,V
S BGPLEYE=""
K BGPG S %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "1^"_$P(BGPG(1),U)_"^Diab Eye Ex"
;now check cpt taxonomies
S T=$O(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
I T D I X]"" Q 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)
K ^TMP($J,"A")
S R=$NA(^TMP($J,"A"))
;CHANGE 16.1 TO CLINIC A2 OR CLINIC 17 OR 18 WITH PROVIDER 24, 79,08 AND NOT C OR T
S T=$O(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
I T D I X]"" Q 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^BGP2UTL1(P,"BGP EYE EXAM PROCS",BDATE,EDATE) I X]"" Q 3_U_$P(X,U,3)_U_"Proc "_$P(X,U,2)
D ALLV^APCLAPIU(P,BDATE,EDATE,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="A2",'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q 3_"^"_D_"^Cl "_R
;REMOVED CLINIC 64 12.1
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) D
.S V=$P(^TMP($J,"A",X),U,5)
.I 'V Q
.I $P($G(^AUPNVSIT(V,0)),U,7)="T" Q
.I $P($G(^AUPNVSIT(V,0)),U,7)="C" Q
.S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C")
.I R'=17,R'=18 Q ;MUST BE 17 OR 18
.Q:$$DNKA($P(^TMP($J,"A",X),U,5)) ;CAN'T BE A DNKA
.S J=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D")
.I J'=24,J'=79,J'="08" Q ;MUST BE PROVIDER 24,79,08
.S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q 3_"^"_D_"^Cl/Prv "_R_"/"_J
;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($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
;I Y Q "3^"_D_"^Prv "_R
;
;
;S T=$O(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
;I T D I X]"" Q 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)
Q ""
DNKA(V) ;EP
NEW D,N
S D=$$PRIMPOV^APCLV(V,"C")
I D=".0860" Q 1
S N=$$PRIMPOV^APCLV(V,"N")
I $E(D)="V",N["DNKA" Q 1
I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
I $E(D)="V",N["DID NOT KEEP APPT" Q 1
Q 0
GFR(P,BDATE,EDATE) ;EP
S BGPC=""
S T=$O(^LAB(60,"B","ESTIMATED GFR",0))
S T1=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)=""
...I T,$P(^AUPNVLAB(X,0),U)=T S BGPC=1_U_$$DATE^BGP8UTL((9999999-D)) Q
...I T1,$D(^ATXLAB(T1,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D) Q
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...S %=$P($G(^LAB(95.3,J,9999999)),U,2)
...I %="33914-3" S BGPC=1_U_(9999999-D) Q
...S J=$P($G(^LAB(95.3,J,0)),U)_"-"_$P($G(^LAB(95.3,J,0)),U,15)
...I J="33914-3" S BGPC=1_U_(9999999-D) Q
...Q
Q BGPC
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
ESRD(P,BDATE,EDATE) ;EP
K BGPG S %=P_"^LAST DX [BGP ESRD PMS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "1^ESRD "_$P(BGPG(1),U,2)_"^^"_$P(BGPG(1),U)
S X=$$LASTPRC^BGP8UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
I X Q 1_"^ESRD PROC "_$P(X,U,2)_"^^"_$P(X,U,3)
S T=$O(^ATXAX("B","BGP ESRD CPTS",0))
I T D I X]"" Q 1_U_"ESRD "_$P(X,U,2)_U_U_$P(X,U,1)
.S X=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
Q 0
DMACE ;EP
NEW BGPACERX,BGPACEC,BGPACEA
S (BGPD1,BGPN1,BGPN2)=0
;BGPN4 AND BGPN5, BGPN6 ARE GPRA DEV 2017
I 'BGPDMD2 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic per active diabetic definition
I $$ESRD^BGP8D211(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSTOP=1 Q ;no one with ESRD 14.1
;
;does patient have HTN?
I '$$V1HTN^BGP8D9(DFN,BGP365,BGPEDATE) S BGPSTOP=1 Q ;no 1 visit of htn during report period
I '$$FIRSTHTN^BGP8D9(DFN,BGPEDATE) S BGPSTOP=1 Q ;no htn prior to report period
S BGPD1=1,BGPN1=0
S BGPACERX=$$ACERX(DFN,BGPBDATE,BGPEDATE,0) ;did PT HAVE ACE/ARB IN REPORT PERIOD?
I BGPACERX S BGPN1=1,BGPVALUE="AD|||"_$P(BGPACERX,U,2) G DMACEX
S BGPACEC=$$ACECONT^BGP8D723(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPBDATE,BGPEDATE,BGPBDATE)
I BGPACEC S BGPN2=1,BGPVALUE="AD|||"_$P(BGPACEC,U,2) G DMACEX
S BGPACEA=$$ACEALG^BGP8D723(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPACEA S BGPN2=1,BGPVALUE="AD|||"_$P(BGPACEA,U,2) G DMACEX
S BGPVALUE="AD|||"
DMACEX ;
K BGPACERX
Q
ACERX(P,BDATE,EDATE,BGPNDAYS) ;EP
K BGPMEDS1
NEW K,R,T,T1,T2,T3,X,Y,G,D,N,J,V,S
S K=0,R="",G=""
D GETMEDS^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ""
S T=$O(^ATXAX("B","BGP HEDIS ACEI MEDS",0))
S T1=$O(^ATXAX("B","BGP HEDIS ACEI NDC",0))
S T2=$O(^ATXAX("B","BGP HEDIS ARB MEDS",0))
S T3=$O(^ATXAX("B","BGP HEDIS ARB NDC",0))
S X=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X!(G) 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 ACE1
.I T2,$D(^ATXAX(T2,21,"B",D)) S G=1 G ACE1
.S N=$P($G(^PSDRUG(D,2)),U,4)
.I N]"",T1,$D(^ATXAX(T1,21,"B",N)) S G=1
.I N]"",T3,$D(^ATXAX(T3,21,"B",N)) S G=1
.Q:'G
ACE1 .;
.S J=$P(^AUPNVMED(Y,0),U,8)
.S V=$P(^AUPNVMED(Y,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.S S=$$DAYS^BGP8D82(Y,V,EDATE)
.S K=S+K
.I R]"" S R=R_";"
.S R=R_$$DATE^BGP8UTL($P($P(^AUPNVSIT(V,0),U),"."))
I K>BGPNDAYS Q 1_U_R
Q 0
JVN(P,BDATE,EDATE) ;EP
G JVN^BGP8D211
BGP8D21 ; IHS/CMI/LAB - measure 6 ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
I6 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPUP,BGPGFR
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4)=0
+3 IF 'BGPDM1
SET BGPSTOP=1
QUIT
DMNA ;EP - called from elder care
+1 SET BGPBD1=BGP365
+2 SET BGPBD2=BGPBDATE
I61 ;EP
+1 SET BGPGFR=$$GFR^BGP8D211(DFN,BGPBD1,BGPEDATE)
+2 SET BGPESRD=$$ESRD^BGP8D211(DFN,$PIECE(^DPT(DFN,0),U,3),BGPEDATE)
+3 SET BGPQUP=$$QUANTUP^BGP8D211(DFN,BGPBD2,BGPEDATE)
+4 SET BGPHOLD=BGPGFR_"|"_BGPESRD_"|"_BGPQUP
+5 IF $PIECE(BGPESRD,U)
SET BGPN1=1
+6 IF BGPGFR&(BGPQUP)
SET BGPN1=1
+7 SET BGPVALUE=$SELECT(BGPDMD6:"UPDM",1:"")_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:"")_"|||"
+8 IF BGPN1
Begin DoDot:1
+9 IF BGPESRD
SET BGPVALUE=BGPVALUE_$SELECT(BGPESRD]"":"ESRD: "_$$DATE^BGP8UTL($PIECE(BGPESRD,U,3))_" "_$PIECE(BGPESRD,U,2),1:"")
QUIT
+10 SET BGPVALUE=BGPVALUE_$SELECT(BGPESRD:"; ",1:"")
SET BGPVALUE=BGPVALUE_"GFR: "_$$DATE^BGP8UTL($PIECE(BGPGFR,U,2))
+11 SET BGPVALUE=BGPVALUE_" & UACR: "_$$DATE^BGP8UTL($PIECE(BGPQUP,U,3))_" "_$PIECE(BGPQUP,U,2)
End DoDot:1
+12 KILL BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG,BGPBD1,BGPBD2,BGPQUP,BGPESRD
+13 QUIT
+14 ;
I7 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPVALUE,BGPD1)=""
+2 NEW BGPEYE,BGPJVN
+3 IF 'BGPDM1
SET BGPSTOP=1
QUIT
+4 SET X=$$LASTDX^BGP8UTL1(DFN,"BGP BILATERAL BLINDNESS DXS",$$DOB^AUPNPAT(DFN),BGPEDATE)
+5 IF 'X
SET X=$$BLINDPL^BGP8D21A(DFN,BGPEDATE)
+6 IF X
SET BGPSTOP=1
QUIT
+7 ;EXCL EYE ENUCLEATION
+8 SET X=$$EYEENUC^BGP8D21A(DFN,BGPEDATE)
+9 IF X
SET BGPSTOP=1
QUIT
+10 IF BGPDMD2
SET BGPD1=1
DMEYE ;EP - called from elder care
+1 SET BGPEYE=$$EYE(DFN,BGPBDATE,BGPEDATE)
+2 SET BGPN1=0
IF $PIECE(BGPEYE,U)=1!($PIECE(BGPEYE,U)=3)
SET BGPN1=1
+3 ;QUALIFIED
SET BGPN2=0
IF $PIECE(BGPEYE,U)=1
SET BGPN2=1
+4 ;OTHER EYE EXAM
SET BGPN3=0
IF $PIECE(BGPEYE,U)=3
SET BGPN3=1
+5 SET BGPJVN=$$JVN(DFN,BGPBDATE,BGPEDATE)
+6 ;JVN
IF $PIECE(BGPJVN,U,1)]""
SET BGPN4=1
+7 ;OPTH
IF $PIECE(BGPJVN,U,2)]""
SET BGPN5=1
+8 ;OPTOMETRY
IF $PIECE(BGPJVN,U,3)]""
SET BGPN6=1
+9 SET BGPVALUE=$SELECT(BGPDMD6:"UPDM",1:"")_$SELECT(BGPDMD2:",AD",1:"")
+10 IF BGPDMD3
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_",AAD"
+11 IF BGPDMD3
IF BGPVALUE=""
SET BGPVALUE="AAD"
+12 SET BGPVALUE=BGPVALUE_"|||"
+13 SET X=$SELECT(BGPEYE:"Eval: "_$$DATE^BGP8UTL($PIECE(BGPEYE,U,2))_" "_$PIECE(BGPEYE,U,3),1:"")
+14 IF $PIECE(BGPJVN,U,1)]""
SET X=X_$SELECT(X]"":"; ",1:"")
SET X=X_$PIECE(BGPJVN,U,1)
+15 IF $PIECE(BGPJVN,U,2)]""
SET X=X_$SELECT(X]"":"; ",1:"")
SET X=X_$PIECE(BGPJVN,U,2)
+16 IF $PIECE(BGPJVN,U,3)]""
SET X=X_$SELECT(X]"":"; ",1:"")
SET X=X_$PIECE(BGPJVN,U,3)
+17 SET BGPVALUE=BGPVALUE_X
+18 KILL BGPG,BGPEYE,BGPJVN
+19 KILL ^TMP($JOB,"A")
+20 QUIT
+21 ;
I8 ;EP
+1 KILL BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
+2 SET BGPN1=0
+3 IF '$GET(BGPDMD2)
SET BGPSTOP=1
QUIT
+4 SET BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
+5 SET BGPN1=0
IF $PIECE(BGPVALUE,U)=1
SET BGPN1=1
+6 IF BGPRTYPE=1
SET BGPVALUE="AD|||"
IF BGPN1
SET BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+7 IF BGPRTYPE'=1
SET BGPVALUE="AD|||"_$$DATE^BGP8UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+8 QUIT
I9 ;EP
+1 KILL BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9
+2 NEW BGPTC,BGPPN,BGPV1
+3 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14)=0
+4 IF '$GET(BGPACTUP)
SET BGPSTOP=1
QUIT
+5 ;USER POP
SET BGPD1=1
+6 SET A=$$AGE^AUPNPAT(DFN,BGPBDATE)
+7 IF A<6
SET BGPD2=1
+8 IF A>15
IF A<22
SET BGPD3=1
+9 IF A>21
IF A<35
SET BGPD4=1
+10 IF A>34
IF A<45
SET BGPD5=1
+11 IF A>44
IF A<55
SET BGPD6=1
+12 IF A>54
IF A<75
SET BGPD7=1
+13 IF A>74
SET BGPD8=1
+14 IF A<3
SET BGPD9=1
+15 IF A>2
IF A<6
SET BGPD11=1
+16 IF A>5
IF A<10
SET BGPD12=1
+17 IF A>9
IF A<13
SET BGPD13=1
+18 IF A>12
IF A<16
SET BGPD14=1
+19 ;DOCUMENTED DENTAL VISIT
SET BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
+20 SET BGPN1=0
IF $PIECE(BGPVALUE,U)=1
SET BGPN1=1
+21 ;S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
+22 SET BGPN9=0
+23 ;ddocumented dental visit BGPN9 GPRA DEV
SET BGPDEVV=$$DENTSRVD^BGP8D211(DFN,BGPBDATE,BGPEDATE)
+24 IF BGPDEVV
SET BGPN9=1
+25 ;DENTAL EXAM
SET BGPV1=$$DENTDEV(DFN,BGPBDATE,BGPEDATE)
+26 SET BGPN3=0
IF $PIECE(BGPV1,U)=1
SET BGPN3=1
+27 ;ALL TX COMPLETED
SET BGPTC=$$TC(DFN,BGPBDATE,BGPEDATE)
+28 SET BGPN4=0
IF $PIECE(BGPTC,U,1)
SET BGPN4=1
+29 SET BGPD10=$$PREG(DFN,BGPBDATE,BGPEDATE)
+30 SET BGPPN=""
IF BGPD10
SET BGPPN=$$PN(DFN,BGPBDATE,BGPEDATE)
+31 SET BGPN6=0
IF $PIECE(BGPPN,U,1)
SET BGPN6=1
+32 SET BGPN7=0
SET BGPN8=0
+33 SET BGPGAX=""
+34 IF BGPD2
Begin DoDot:1
+35 SET BGPGAX=$$GA^BGP8D3A(DFN,BGPBDATE,BGPEDATE)
+36 SET BGPN7=$PIECE(BGPGAX,U,1)
SET BGPN8=$PIECE(BGPGAX,U,2)
End DoDot:1
+37 SET BGPVALUD="UP"
IF BGPN9
SET BGPVALUD="UP,UP w/dental visit "_$$DATE^BGP8UTL($PIECE(BGPDEVV,U,2))
+38 SET BGPVALUD=BGPVALUD_$SELECT(BGPD10:",PREG",1:"")
+39 SET BGPVALUD=BGPVALUD_"|||"
+40 IF BGPN9
SET BGPVALUD=BGPVALUD_"Visit: "_$$DATE^BGP8UTL($PIECE(BGPDEVV,U,2))_" "_$PIECE(BGPDEVV,U,3)
+41 IF BGPN3
SET BGPVALUD=BGPVALUD_";Exam: "_$$DATE^BGP8UTL($PIECE(BGPV1,U,2))_" CDT "_$PIECE(BGPV1,U,3)
+42 IF BGPTC
SET BGPVALUD=BGPVALUD_$SELECT(BGPV1:"; ",1:"")_"TC: "_$$DATE^BGP8UTL($PIECE(BGPTC,U,2))_" "_$PIECE(BGPTC,U,3)
+43 IF BGPN6
SET BGPVALUD=BGPVALUD_$SELECT(BGPTC:"; ",1:"")
SET BGPVALUD=BGPVALUD_"PN: "_$$DATE^BGP8UTL($PIECE(BGPPN,U,2))_" "_$PIECE(BGPPN,U,3)
+44 IF BGPN7
SET BGPVALUD=BGPVALUD_" GEN/SSC: "_$PIECE(BGPGAX,U,3)
+45 ;S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
+46 IF BGPRTYPE'=1
SET BGPVALUE="UP|||"_$$DATE^BGP8UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+47 IF BGPRTYPE=1
SET X=BGPVALUE
SET BGPVALUE="UP|||"
IF BGPN1
SET BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
+48 KILL BGPDEVV
+49 QUIT
PREG(P,BDATE,EDATE) ;EP
+1 NEW X,Y,Z
+2 SET (X,Y)=0
+3 IF $PIECE(^DPT(P,0),U,2)'="F"
QUIT 0
+4 ;V17.1 CMI/LAB ADDED DATES FOR CURRENTLY PREGNANT
SET X=$$PREG^BGP8D7(P,$$FMADD^XLFDT(EDATE,-608),EDATE,1,1,,BDATE,EDATE)
+5 IF BGPAGEB>9
SET Y=$$BF(P,BDATE,EDATE)
+6 QUIT (X+Y)
BF(P,BDATE,EDATE) ;EP
+1 NEW BGPG,Y,X,E,D,T,%,SN
+2 ;S Y="BGPG(",X=P_"^LAST [BGP BREASTFEEDING DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
+3 SET X=$$LASTDX^BGP8UTL1(P,"BGP BREASTFEEDING DXS",BDATE,EDATE)
+4 IF X
QUIT 1_U_$$DATE^BGP8UTL($PIECE(X,U,3))
+5 KILL BGPG
+6 SET Y="BGPG("
+7 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+8 IF '$DATA(BGPG)
QUIT ""
+9 SET SN=$ORDER(^BGPSNOMR("B","BREASTFEEDING PATIENT ED",0))
+10 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+11 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+12 IF 'T
QUIT
+13 IF '$DATA(^AUTTEDT(T,0))
QUIT
+14 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+15 IF T="BF-BC"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+16 IF T="BF-BP"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+17 IF T="BF-CS"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+18 IF T="BF-EQ"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+19 IF T="BF-FU"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+20 IF T="BF-HC"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+21 IF T="BF-ON"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+22 IF T="BF-M"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+23 IF T="BF-MK"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+24 IF T="BF-N"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+25 IF $PIECE(T,"-")]""
IF $DATA(^BGPSNOMR(SN,11,"B",$PIECE(T,"-")))
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
End DoDot:1
+26 IF %]""
QUIT 1_U_$$DATE^BGP8UTL($PIECE(%,U,2))
+27 QUIT 0
+28 ;
DENTDEV(P,BDATE,EDATE) ;
+1 ;ADA 1050, 1045
+2 NEW BGPG,BGPC,%
+3 SET BGPC=""
SET %=P_"^LAST ADA [BGP DENTAL EXAM ADA CODES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U)_"^"_"RPMS DENTAL "_$PIECE(BGPG(1),U,2)
+5 SET BGPC=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP DENTAL EXAM CPTS",0)),5)
+6 IF BGPC
QUIT 1_U_BGPC
+7 QUIT ""
TC(P,BDATE,EDATE) ;
+1 NEW BGPG,BGPC,%,V,X
+2 SET BGPC=""
SET %=P_"^LAST ADA 9990;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U)_"^"_"RPMS DENTAL "_$PIECE(BGPG(1),U,2)
+4 QUIT ""
PN(P,BDATE,EDATE) ;
+1 NEW BGPG,BGPC,%
+2 SET BGPC=""
SET %=P_"^LAST ADA [BGP PRENATAL DENTAL ADA CODES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U)_"^"_"RPMS DENTAL "_$PIECE(BGPG(1),U,2)
+4 QUIT ""
DENTSRV(P,BDATE,EDATE,FORECAST) ;EP
+1 NEW BGPG,BGPC
+2 KILL BGPG
+3 SET FORECAST=$GET(FORECAST)
+4 SET BGPC=""
SET %=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+5 IF $DATA(BGPG(1))
SET BGPC=$PIECE(BGPG(1),U)_"^"_"RPMS DENTAL "_$PIECE(BGPG(1),U,2)
+6 KILL BGPG
+7 SET %=P_"^LAST ADA 0190;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+8 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_"RPMS DENTAL "_$PIECE(BGPG(1),U,2)
+9 KILL BGPG
+10 SET %=P_"^LAST ADA 0191;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+11 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_"RPMS DENTAL "_$PIECE(BGPG(1),U,2)
+12 KILL BGPG
+13 SET BGPG(1)=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP DENTAL EXAM CPT 0190",0)),5)
+14 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_"CDT "_$PIECE(BGPG(1),U,2)
+15 KILL BGPG
+16 SET %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+17 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_$PIECE(BGPG(1),U,3)
+18 IF BGPC]""
IF 'FORECAST
QUIT "1^"_BGPC
+19 SET BGPG=$$LASTDX^BGP8UTL1(P,"BGP DENTAL EXAM DXS",BDATE,EDATE)
+20 IF BGPG
IF '$GET(FORECAST)
QUIT "1^"_$PIECE(BGPG,U,3)_"^"_$PIECE(BGPG,U,2)
+21 IF BGPG
IF $GET(FORECAST)
IF $PIECE(BGPG,U,3)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG,U,3)_"^POV "_$PIECE(BGPG,U,2)
+22 KILL BGPG
SET G=""
SET %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+23 IF $DATA(BGPG)
Begin DoDot:1
+24 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:2
+25 IF $PIECE($GET(^AUPNVSIT(V,0)),U,3)="C"
Begin DoDot:3
+26 IF '$GET(FORECAST)
SET G=1_"^"_$PIECE(BGPG(X),U)_"^CHS VISIT RPMS DENTAL "_$PIECE(BGPG(X),U,2)
QUIT
+27 IF $GET(FORECAST)
IF $PIECE(BGPG(X),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(X),U)_"^CHS RPMS DENTAL VISIT"
End DoDot:3
End DoDot:2
End DoDot:1
IF G]""
IF '$GET(FORECAST)
QUIT G
+28 IF BGPC]""
SET BGPC=1_"^"_BGPC
QUIT BGPC
+29 QUIT BGPC
+30 ;
EYE(P,BDATE,EDATE) ;EP - REPORT PERIOD
+1 NEW BGPLEYE,T,E,%,X,R,Y,D,J,V
+2 SET BGPLEYE=""
+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))
QUIT "1^"_$PIECE(BGPG(1),U)_"^Diab Eye Ex"
+5 ;now check cpt taxonomies
+6 SET T=$ORDER(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
+7 IF T
Begin DoDot:1
+8 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+9 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+10 KILL ^TMP($JOB,"A")
+11 SET R=$NAME(^TMP($JOB,"A"))
+12 ;CHANGE 16.1 TO CLINIC A2 OR CLINIC 17 OR 18 WITH PROVIDER 24, 79,08 AND NOT C OR T
+13 SET T=$ORDER(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
+14 IF T
Begin DoDot:1
+15 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+16 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
QUIT 3_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+17 SET X=$$LASTPRC^BGP2UTL1(P,"BGP EYE EXAM PROCS",BDATE,EDATE)
IF X]""
QUIT 3_U_$PIECE(X,U,3)_U_"Proc "_$PIECE(X,U,2)
+18 DO ALLV^APCLAPIU(P,BDATE,EDATE,R)
+19 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($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+20 IF Y
QUIT 3_"^"_D_"^Cl "_R
+21 ;REMOVED CLINIC 64 12.1
+22 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+23 SET V=$PIECE(^TMP($JOB,"A",X),U,5)
+24 IF 'V
QUIT
+25 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="T"
QUIT
+26 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="C"
QUIT
+27 SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
+28 ;MUST BE 17 OR 18
IF R'=17
IF R'=18
QUIT
+29 ;CAN'T BE A DNKA
IF $$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
QUIT
+30 SET J=$$PRIMPROV^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"D")
+31 ;MUST BE PROVIDER 24,79,08
IF J'=24
IF J'=79
IF J'="08"
QUIT
+32 SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
End DoDot:1
+33 IF Y
QUIT 3_"^"_D_"^Cl/Prv "_R_"/"_J
+34 ;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($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
+35 ;I Y Q "3^"_D_"^Prv "_R
+36 ;
+37 ;
+38 ;S T=$O(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
+39 ;I T D I X]"" Q 3_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
+40 ;.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
+41 ;.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
+42 QUIT ""
DNKA(V) ;EP
+1 NEW D,N
+2 SET D=$$PRIMPOV^APCLV(V,"C")
+3 IF D=".0860"
QUIT 1
+4 SET N=$$PRIMPOV^APCLV(V,"N")
+5 IF $EXTRACT(D)="V"
IF N["DNKA"
QUIT 1
+6 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPOINTMENT"
QUIT 1
+7 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPT"
QUIT 1
+8 QUIT 0
GFR(P,BDATE,EDATE) ;EP
+1 SET BGPC=""
+2 SET T=$ORDER(^LAB(60,"B","ESTIMATED GFR",0))
+3 SET T1=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
+4 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPC]"")
QUIT
Begin DoDot:1
+5 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+7 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+8 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+9 IF T
IF $PIECE(^AUPNVLAB(X,0),U)=T
SET BGPC=1_U_$$DATE^BGP8UTL((9999999-D))
QUIT
+10 IF T1
IF $DATA(^ATXLAB(T1,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)
QUIT
+11 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+12 SET %=$PIECE($GET(^LAB(95.3,J,9999999)),U,2)
+13 IF %="33914-3"
SET BGPC=1_U_(9999999-D)
QUIT
+14 SET J=$PIECE($GET(^LAB(95.3,J,0)),U)_"-"_$PIECE($GET(^LAB(95.3,J,0)),U,15)
+15 IF J="33914-3"
SET BGPC=1_U_(9999999-D)
QUIT
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT BGPC
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
ESRD(P,BDATE,EDATE) ;EP
+1 KILL BGPG
SET %=P_"^LAST DX [BGP ESRD PMS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
QUIT "1^ESRD "_$PIECE(BGPG(1),U,2)_"^^"_$PIECE(BGPG(1),U)
+3 SET X=$$LASTPRC^BGP8UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
+4 IF X
QUIT 1_"^ESRD PROC "_$PIECE(X,U,2)_"^^"_$PIECE(X,U,3)
+5 SET T=$ORDER(^ATXAX("B","BGP ESRD CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1_U_"ESRD "_$PIECE(X,U,2)_U_U_$PIECE(X,U,1)
+9 QUIT 0
DMACE ;EP
+1 NEW BGPACERX,BGPACEC,BGPACEA
+2 SET (BGPD1,BGPN1,BGPN2)=0
+3 ;BGPN4 AND BGPN5, BGPN6 ARE GPRA DEV 2017
+4 ;don't process this measure, pt not diabetic per active diabetic definition
IF 'BGPDMD2
SET BGPSTOP=1
QUIT
+5 ;no one with ESRD 14.1
IF $$ESRD^BGP8D211(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
SET BGPSTOP=1
QUIT
+6 ;
+7 ;does patient have HTN?
+8 ;no 1 visit of htn during report period
IF '$$V1HTN^BGP8D9(DFN,BGP365,BGPEDATE)
SET BGPSTOP=1
QUIT
+9 ;no htn prior to report period
IF '$$FIRSTHTN^BGP8D9(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+10 SET BGPD1=1
SET BGPN1=0
+11 ;did PT HAVE ACE/ARB IN REPORT PERIOD?
SET BGPACERX=$$ACERX(DFN,BGPBDATE,BGPEDATE,0)
+12 IF BGPACERX
SET BGPN1=1
SET BGPVALUE="AD|||"_$PIECE(BGPACERX,U,2)
GOTO DMACEX
+13 SET BGPACEC=$$ACECONT^BGP8D723(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPBDATE,BGPEDATE,BGPBDATE)
+14 IF BGPACEC
SET BGPN2=1
SET BGPVALUE="AD|||"_$PIECE(BGPACEC,U,2)
GOTO DMACEX
+15 SET BGPACEA=$$ACEALG^BGP8D723(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+16 IF BGPACEA
SET BGPN2=1
SET BGPVALUE="AD|||"_$PIECE(BGPACEA,U,2)
GOTO DMACEX
+17 SET BGPVALUE="AD|||"
DMACEX ;
+1 KILL BGPACERX
+2 QUIT
ACERX(P,BDATE,EDATE,BGPNDAYS) ;EP
+1 KILL BGPMEDS1
+2 NEW K,R,T,T1,T2,T3,X,Y,G,D,N,J,V,S
+3 SET K=0
SET R=""
SET G=""
+4 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
QUIT ""
+6 SET T=$ORDER(^ATXAX("B","BGP HEDIS ACEI MEDS",0))
+7 SET T1=$ORDER(^ATXAX("B","BGP HEDIS ACEI NDC",0))
+8 SET T2=$ORDER(^ATXAX("B","BGP HEDIS ARB MEDS",0))
+9 SET T3=$ORDER(^ATXAX("B","BGP HEDIS ARB NDC",0))
+10 SET X=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(G)
QUIT
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+11 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+12 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+13 SET G=0
+14 SET D=$PIECE(^AUPNVMED(Y,0),U)
+15 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
GOTO ACE1
+16 IF T2
IF $DATA(^ATXAX(T2,21,"B",D))
SET G=1
GOTO ACE1
+17 SET N=$PIECE($GET(^PSDRUG(D,2)),U,4)
+18 IF N]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",N))
SET G=1
+19 IF N]""
IF T3
IF $DATA(^ATXAX(T3,21,"B",N))
SET G=1
+20 IF 'G
QUIT
ACE1 ;
+1 SET J=$PIECE(^AUPNVMED(Y,0),U,8)
+2 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+3 IF 'V
QUIT
+4 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+5 SET S=$$DAYS^BGP8D82(Y,V,EDATE)
+6 SET K=S+K
+7 IF R]""
SET R=R_";"
+8 SET R=R_$$DATE^BGP8UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
End DoDot:1
+9 IF K>BGPNDAYS
QUIT 1_U_R
+10 QUIT 0
JVN(P,BDATE,EDATE) ;EP
+1 GOTO JVN^BGP8D211
