BGP3D21 ; IHS/CMI/LAB - measure 6 ;
;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7
;
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^BGP3D211(DFN,BGPBD1,BGPEDATE)
S BGPESRD=$$ESRD^BGP3D211(DFN,$P(^DPT(DFN,0),U,3),BGPEDATE)
S BGPQUP=$$QUANTUP^BGP3D211(DFN,BGPBD2,BGPEDATE)
S BGPHOLD=BGPGFR_"|"_BGPESRD_"|"_BGPQUP
I $P(BGPESRD,U) S BGPN1=1
I BGPGFR&(BGPQUP) S BGPN1=1
S BGPVALUE=$S(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"
I BGPN1 D
.I BGPESRD S BGPVALUE=BGPVALUE_$S(BGPESRD]"":"ESRD: "_$$DATE^BGP3UTL($P(BGPESRD,U,3))_" "_$P(BGPESRD,U,2),1:"") Q
.S BGPVALUE=BGPVALUE_$S(BGPESRD:"; ",1:""),BGPVALUE=BGPVALUE_"GFR: "_$$DATE^BGP3UTL($P(BGPGFR,U,2))
.S BGPVALUE=BGPVALUE_" & QUANT UP: "_$$DATE^BGP3UTL($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^BGP3UTL1(DFN,"BGP BILATERAL BLINDNESS DXS",$$DOB^AUPNPAT(DFN),BGPEDATE)
I 'X S X=$$BLINDPL^BGP3D21A(DFN,BGPEDATE)
I X S BGPSTOP=1 Q ;V13.0 EXCLUDE ALL THOSE WHO ARE BLIND S BGPBLIND=1
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(BGPDMD1:"UP",1:"")_$S(BGPDMD2:",AD",1:"")_$S(BGPDMD3:",AAD",1:"")_"|||"
S X=$S(BGPEYE:"Eval: "_$$DATE^BGP3UTL($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
;S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
;S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
I BGPRTYPE=1 S BGPVALUE="AD|||" I BGPN1 S BGPVALUE=BGPVALUE_$$DATE^BGP3UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
I BGPRTYPE'=1 S BGPVALUE="AD|||"_$$DATE^BGP3UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
Q
I9 ;EP
K BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6
NEW BGPTC,BGPPN,BGPV1
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
I '$G(BGPACTUP) S BGPSTOP=1 Q
S BGPD1=1
S A=$$AGE^AUPNPAT(DFN,BGPBDATE)
I A<6 S BGPD2=1
I A>5,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>54,A<75 S BGPD8=1
I A>74 S BGPD8=1
S BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
S BGPN1=0 I $P(BGPVALUE,U)=1 S BGPN1=1
;S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
S BGPV1=$$DENTDEV(DFN,BGPBDATE,BGPEDATE)
S BGPN3=0 I $P(BGPV1,U)=1 S BGPN3=1
S BGPTC=$$TC(DFN,BGPBDATE,BGPEDATE)
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 BGPVALUD="" I BGPN3 S BGPVALUD="UP w/exam "_$$DATE^BGP3UTL($P(BGPV1,U,2))_" "_$P(BGPV1,U,3)
S BGPVALUD=BGPVALUD_$S(BGPD10:",PREG",1:"")
S BGPVALUD=BGPVALUD_"|||"
I BGPTC S BGPVALUD=BGPVALUD_"TC: "_$$DATE^BGP3UTL($P(BGPTC,U,2))_" "_$P(BGPTC,U,3)
I BGPN6 S BGPVALUD=BGPVALUD_$S(BGPTC:"; ",1:""),BGPVALUD=BGPVALUD_"PN: "_$$DATE^BGP3UTL($P(BGPPN,U,2))_" "_$P(BGPPN,U,3)
;S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
I BGPRTYPE'=1 S BGPVALUE="UP|||"_$$DATE^BGP3UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
I BGPRTYPE=1 S X=BGPVALUE S BGPVALUE="UP|||" I BGPN1 S BGPVALUE=BGPVALUE_$$DATE^BGP3UTL($P(X,U,2))_" "_$P(X,U,3)
Q
PREG(P,BDATE,EDATE) ;
NEW X,Y,Z
S (X,Y)=0
I $P(^DPT(P,0),U,2)'="F" Q 0
S X=$$PREG^BGP3D7(P,$$FMADD^XLFDT(EDATE,-608),EDATE,1,1)
I BGPAGEB>9 S Y=$$BF(P,BDATE,EDATE)
Q (X+Y)
BF(P,BDATE,EDATE) ;
NEW BGPG,Y,X,E,D,T,%
;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^BGP3UTL1(P,"BGP BREASTFEEDING DXS",BDATE,EDATE)
I X Q 1
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 (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 %]"" Q 1
Q 0
;
DENTDEV(P,BDATE,EDATE) ;
;ADA 0120, 1050, 1045, 9990
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)_"^"_"ADA "_$P(BGPG(1),U,2)
S BGPC=$$CPT^BGP3DU(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,%
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)_"^"_"ADA "_$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)_"^"_"ADA "_$P(BGPG(1),U,2)
Q ""
DENTSRV(P,BDATE,EDATE,FORECAST) ;EP
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)_"^"_"ADA "_$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)_"^"_"ADA "_$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^BGP3UTL1(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 ADA "_$P(BGPG(X),U,2) Q
...I $G(FORECAST),$P(BGPG(X),U)>$P(BGPC,U) S BGPC=$P(BGPG(X),U)_"^CHS ADA VISIT"
I BGPC]"" S BGPC=1_"^"_BGPC Q BGPC
Q BGPC
;
EYE(P,BDATE,EDATE) ;EP
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]"",$P(BGPLEYE,U,2)<$P(X,U,1) Q 1_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)
.S X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,5)
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($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) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I (R=17!(R=18)),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q $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($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q "3^"_D_"^Prv "_R
;
;REMOVE V72.0 FOR 12.1
;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)) Q "3^"_$P(BGPG(1),U)_"^"_$P(BGPG(1),U,2)_" POV"
;
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^BGP3DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,5)
;S X=$$LASTPRC^BGP3UTL1(P,"BGP EYE EXAM PROCS",BDATE,EDATE) I X]"" Q 3_U_$P(X,U,3)_U_"Proc "_$P(X,U,2)
;I $G(REFUSAL) Q BGPLEYE
;S G=$$REFUSAL^BGP3UTL1(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 BGPLEYE
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^BGP3UTL((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^BGP3UTL1(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^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP3DU(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 2013
I 'BGPDMD2 S BGPSTOP=1 Q ;don't process this measure, pt not diabetic per active diabetic definition
;
;does patient have HTN?
I '$$V1HTN^BGP3D9(DFN,BGP365,BGPEDATE) S BGPSTOP=1 Q ;no 1 visit of htn during report period
I '$$FIRSTHTN^BGP3D9(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^BGP3D723(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPBDATE,BGPEDATE,BGPBDATE)
I BGPACEC S BGPN2=1,BGPVALUE="AD|||"_$P(BGPACEC,U,2) G DMACEX
S BGPACEA=$$ACEALG^BGP3D723(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^BGP3UTL2(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^BGP3D82(Y,V,EDATE)
.S K=S+K
.I R]"" S R=R_";"
.S R=R_$$DATE^BGP3UTL($P($P(^AUPNVSIT(V,0),U),"."))
I K>BGPNDAYS Q 1_U_R
Q 0
JVN(P,BDATE,EDATE) ;EP
NEW BGPVAL,A,E,%,Y,X,R,D
S BGPVAL=""
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($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y S $P(BGPVAL,U,1)="JVN: "_$$DATE^BGP3UTL(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,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y S $P(BGPVAL,U,2)="Ophth: "_$$DATE^BGP3UTL(D)_" Cl "_R
I 'Y D
.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=79,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
.I Y S $P(BGPVAL,U,2)="Ophth: "_$$DATE^BGP3UTL(D)_" Prv "_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=18,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y S $P(BGPVAL,U,3)="Optom: "_$$DATE^BGP3UTL(D)_" Cl "_R
I 'Y D
.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="08"!(R=24),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
.I Y S $P(BGPVAL,U,3)="Optom: "_$$DATE^BGP3UTL(D)_" Prv "_R
Q BGPVAL
BGP3D21 ; IHS/CMI/LAB - measure 6 ;
+1 ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7
+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^BGP3D211(DFN,BGPBD1,BGPEDATE)
+2 SET BGPESRD=$$ESRD^BGP3D211(DFN,$PIECE(^DPT(DFN,0),U,3),BGPEDATE)
+3 SET BGPQUP=$$QUANTUP^BGP3D211(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(BGPDMD1:"UP",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^BGP3UTL($PIECE(BGPESRD,U,3))_" "_$PIECE(BGPESRD,U,2),1:"")
QUIT
+10 SET BGPVALUE=BGPVALUE_$SELECT(BGPESRD:"; ",1:"")
SET BGPVALUE=BGPVALUE_"GFR: "_$$DATE^BGP3UTL($PIECE(BGPGFR,U,2))
+11 SET BGPVALUE=BGPVALUE_" & QUANT UP: "_$$DATE^BGP3UTL($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^BGP3UTL1(DFN,"BGP BILATERAL BLINDNESS DXS",$$DOB^AUPNPAT(DFN),BGPEDATE)
+5 IF 'X
SET X=$$BLINDPL^BGP3D21A(DFN,BGPEDATE)
+6 ;V13.0 EXCLUDE ALL THOSE WHO ARE BLIND S BGPBLIND=1
IF X
SET BGPSTOP=1
QUIT
+7 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(BGPDMD1:"UP",1:"")_$SELECT(BGPDMD2:",AD",1:"")_$SELECT(BGPDMD3:",AAD",1:"")_"|||"
+10 SET X=$SELECT(BGPEYE:"Eval: "_$$DATE^BGP3UTL($PIECE(BGPEYE,U,2))_" "_$PIECE(BGPEYE,U,3),1:"")
+11 IF $PIECE(BGPJVN,U,1)]""
SET X=X_$SELECT(X]"":"; ",1:"")
SET X=X_$PIECE(BGPJVN,U,1)
+12 IF $PIECE(BGPJVN,U,2)]""
SET X=X_$SELECT(X]"":"; ",1:"")
SET X=X_$PIECE(BGPJVN,U,2)
+13 IF $PIECE(BGPJVN,U,3)]""
SET X=X_$SELECT(X]"":"; ",1:"")
SET X=X_$PIECE(BGPJVN,U,3)
+14 SET BGPVALUE=BGPVALUE_X
+15 KILL BGPG,BGPEYE,BGPJVN
+16 KILL ^TMP($JOB,"A")
+17 QUIT
+18 ;
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 ;S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
+7 ;S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
+8 IF BGPRTYPE=1
SET BGPVALUE="AD|||"
IF BGPN1
SET BGPVALUE=BGPVALUE_$$DATE^BGP3UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+9 IF BGPRTYPE'=1
SET BGPVALUE="AD|||"_$$DATE^BGP3UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+10 QUIT
I9 ;EP
+1 KILL BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6
+2 NEW BGPTC,BGPPN,BGPV1
+3 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
+4 IF '$GET(BGPACTUP)
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 SET A=$$AGE^AUPNPAT(DFN,BGPBDATE)
+7 IF A<6
SET BGPD2=1
+8 IF A>5
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 ;I A>54,A<75 S BGPD8=1
+14 IF A>74
SET BGPD8=1
+15 SET BGPVALUE=$$DENTSRV(DFN,BGPBDATE,BGPEDATE)
+16 SET BGPN1=0
IF $PIECE(BGPVALUE,U)=1
SET BGPN1=1
+17 ;S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
+18 SET BGPV1=$$DENTDEV(DFN,BGPBDATE,BGPEDATE)
+19 SET BGPN3=0
IF $PIECE(BGPV1,U)=1
SET BGPN3=1
+20 SET BGPTC=$$TC(DFN,BGPBDATE,BGPEDATE)
+21 SET BGPN4=0
IF $PIECE(BGPTC,U,1)
SET BGPN4=1
+22 SET BGPD10=$$PREG(DFN,BGPBDATE,BGPEDATE)
+23 SET BGPPN=""
IF BGPD10
SET BGPPN=$$PN(DFN,BGPBDATE,BGPEDATE)
+24 SET BGPN6=0
IF $PIECE(BGPPN,U,1)
SET BGPN6=1
+25 SET BGPVALUD=""
IF BGPN3
SET BGPVALUD="UP w/exam "_$$DATE^BGP3UTL($PIECE(BGPV1,U,2))_" "_$PIECE(BGPV1,U,3)
+26 SET BGPVALUD=BGPVALUD_$SELECT(BGPD10:",PREG",1:"")
+27 SET BGPVALUD=BGPVALUD_"|||"
+28 IF BGPTC
SET BGPVALUD=BGPVALUD_"TC: "_$$DATE^BGP3UTL($PIECE(BGPTC,U,2))_" "_$PIECE(BGPTC,U,3)
+29 IF BGPN6
SET BGPVALUD=BGPVALUD_$SELECT(BGPTC:"; ",1:"")
SET BGPVALUD=BGPVALUD_"PN: "_$$DATE^BGP3UTL($PIECE(BGPPN,U,2))_" "_$PIECE(BGPPN,U,3)
+30 ;S BGPN3=0 I BGPN1,'BGPN2 S BGPN3=1
+31 IF BGPRTYPE'=1
SET BGPVALUE="UP|||"_$$DATE^BGP3UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+32 IF BGPRTYPE=1
SET X=BGPVALUE
SET BGPVALUE="UP|||"
IF BGPN1
SET BGPVALUE=BGPVALUE_$$DATE^BGP3UTL($PIECE(X,U,2))_" "_$PIECE(X,U,3)
+33 QUIT
PREG(P,BDATE,EDATE) ;
+1 NEW X,Y,Z
+2 SET (X,Y)=0
+3 IF $PIECE(^DPT(P,0),U,2)'="F"
QUIT 0
+4 SET X=$$PREG^BGP3D7(P,$$FMADD^XLFDT(EDATE,-608),EDATE,1,1)
+5 IF BGPAGEB>9
SET Y=$$BF(P,BDATE,EDATE)
+6 QUIT (X+Y)
BF(P,BDATE,EDATE) ;
+1 NEW BGPG,Y,X,E,D,T,%
+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^BGP3UTL1(P,"BGP BREASTFEEDING DXS",BDATE,EDATE)
+4 IF X
QUIT 1
+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 (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF T="BF-BC"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+15 IF T="BF-BP"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+16 IF T="BF-CS"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+17 IF T="BF-EQ"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+18 IF T="BF-FU"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+19 IF T="BF-HC"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+20 IF T="BF-ON"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+21 IF T="BF-M"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+22 IF T="BF-MK"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
+23 IF T="BF-N"
SET %=T_U_$PIECE(BGPG(X),U)
QUIT
End DoDot:1
+24 IF %]""
QUIT 1
+25 QUIT 0
+26 ;
DENTDEV(P,BDATE,EDATE) ;
+1 ;ADA 0120, 1050, 1045, 9990
+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)_"^"_"ADA "_$PIECE(BGPG(1),U,2)
+5 SET BGPC=$$CPT^BGP3DU(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,%
+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)_"^"_"ADA "_$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)_"^"_"ADA "_$PIECE(BGPG(1),U,2)
+4 QUIT ""
DENTSRV(P,BDATE,EDATE,FORECAST) ;EP
+1 KILL BGPG
+2 SET FORECAST=$GET(FORECAST)
+3 SET BGPC=""
SET %=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET BGPC=$PIECE(BGPG(1),U)_"^"_"ADA "_$PIECE(BGPG(1),U,2)
+5 KILL BGPG
+6 SET %=P_"^LAST ADA 0190;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+7 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_"ADA "_$PIECE(BGPG(1),U,2)
+8 KILL BGPG
SET %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+9 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_$PIECE(BGPG(1),U,3)
+10 IF BGPC]""
IF 'FORECAST
QUIT "1^"_BGPC
+11 SET BGPG=$$LASTDX^BGP3UTL1(P,"BGP DENTAL EXAM DXS",BDATE,EDATE)
+12 IF BGPG
IF '$GET(FORECAST)
QUIT "1^"_$PIECE(BGPG,U,3)_"^"_$PIECE(BGPG,U,2)
+13 IF BGPG
IF $GET(FORECAST)
IF $PIECE(BGPG,U,3)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG,U,3)_"^POV "_$PIECE(BGPG,U,2)
+14 KILL BGPG
SET G=""
SET %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+15 IF $DATA(BGPG)
Begin DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:2
+17 IF $PIECE($GET(^AUPNVSIT(V,0)),U,3)="C"
Begin DoDot:3
+18 IF '$GET(FORECAST)
SET G=1_"^"_$PIECE(BGPG(X),U)_"^CHS VISIT ADA "_$PIECE(BGPG(X),U,2)
QUIT
+19 IF $GET(FORECAST)
IF $PIECE(BGPG(X),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(X),U)_"^CHS ADA VISIT"
End DoDot:3
End DoDot:2
End DoDot:1
IF G]""
IF '$GET(FORECAST)
QUIT G
+20 IF BGPC]""
SET BGPC=1_"^"_BGPC
QUIT BGPC
+21 QUIT BGPC
+22 ;
EYE(P,BDATE,EDATE) ;EP
+1 SET BGPLEYE=""
+2 KILL BGPG
SET %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT "1^"_$PIECE(BGPG(1),U)_"^Diab Eye Ex"
+4 ;now check cpt taxonomies
+5 SET T=$ORDER(^ATXAX("B","BGP DM RETINAL EXAM CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLEYE,U,2)<$PIECE(X,U,1)
QUIT 1_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+9 KILL ^TMP($JOB,"A")
+10 SET A="^TMP($J,""A"","
+11 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+12 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)
+13 IF Y
QUIT 3_"^"_D_"^Cl "_R
+14 ;REMOVED CLINIC 64 12.1
+15 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))
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+16 IF Y
QUIT $SELECT(R="A2":3,1:3)_"^"_D_"^Cl "_R
+17 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($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+18 IF Y
QUIT "3^"_D_"^Prv "_R
+19 ;
+20 ;REMOVE V72.0 FOR 12.1
+21 ;K BGPG S %=P_"^LAST DX [BGP EYE EXAM DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
+22 ;I $D(BGPG(1)) Q "3^"_$P(BGPG(1),U)_"^"_$P(BGPG(1),U,2)_" POV"
+23 ;
+24 SET T=$ORDER(^ATXAX("B","BGP DM EYE EXAM CPTS",0))
+25 IF T
Begin DoDot:1
+26 SET X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+27 SET X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
QUIT 3_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+28 ;S X=$$LASTPRC^BGP3UTL1(P,"BGP EYE EXAM PROCS",BDATE,EDATE) I X]"" Q 3_U_$P(X,U,3)_U_"Proc "_$P(X,U,2)
+29 ;I $G(REFUSAL) Q BGPLEYE
+30 ;S G=$$REFUSAL^BGP3UTL1(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
+31 ;I $P(G,U)=1 Q "2^"_$P(G,U,2)_"^Refused"
+32 QUIT BGPLEYE
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^BGP3UTL((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^BGP3UTL1(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^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BGP3DU(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 2013
+4 ;don't process this measure, pt not diabetic per active diabetic definition
IF 'BGPDMD2
SET BGPSTOP=1
QUIT
+5 ;
+6 ;does patient have HTN?
+7 ;no 1 visit of htn during report period
IF '$$V1HTN^BGP3D9(DFN,BGP365,BGPEDATE)
SET BGPSTOP=1
QUIT
+8 ;no htn prior to report period
IF '$$FIRSTHTN^BGP3D9(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+9 SET BGPD1=1
SET BGPN1=0
+10 ;did PT HAVE ACE/ARB IN REPORT PERIOD?
SET BGPACERX=$$ACERX(DFN,BGPBDATE,BGPEDATE,0)
+11 IF BGPACERX
SET BGPN1=1
SET BGPVALUE="AD|||"_$PIECE(BGPACERX,U,2)
GOTO DMACEX
+12 SET BGPACEC=$$ACECONT^BGP3D723(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPBDATE,BGPEDATE,BGPBDATE)
+13 IF BGPACEC
SET BGPN2=1
SET BGPVALUE="AD|||"_$PIECE(BGPACEC,U,2)
GOTO DMACEX
+14 SET BGPACEA=$$ACEALG^BGP3D723(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+15 IF BGPACEA
SET BGPN2=1
SET BGPVALUE="AD|||"_$PIECE(BGPACEA,U,2)
GOTO DMACEX
+16 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^BGP3UTL2(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^BGP3D82(Y,V,EDATE)
+6 SET K=S+K
+7 IF R]""
SET R=R_";"
+8 SET R=R_$$DATE^BGP3UTL($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 NEW BGPVAL,A,E,%,Y,X,R,D
+2 SET BGPVAL=""
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
+5 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+6 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)
+7 IF Y
SET $PIECE(BGPVAL,U,1)="JVN: "_$$DATE^BGP3UTL(D)_" Cl "_R
+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=17
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+9 IF Y
SET $PIECE(BGPVAL,U,2)="Ophth: "_$$DATE^BGP3UTL(D)_" Cl "_R
+10 IF 'Y
Begin DoDot:1
+11 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=79
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+12 IF Y
SET $PIECE(BGPVAL,U,2)="Ophth: "_$$DATE^BGP3UTL(D)_" Prv "_R
End DoDot:1
+13 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=18
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+14 IF Y
SET $PIECE(BGPVAL,U,3)="Optom: "_$$DATE^BGP3UTL(D)_" Cl "_R
+15 IF 'Y
Begin DoDot:1
+16 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="08"!(R=24)
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+17 IF Y
SET $PIECE(BGPVAL,U,3)="Optom: "_$$DATE^BGP3UTL(D)_" Prv "_R
End DoDot:1
+18 QUIT BGPVAL
