BGP6DHE1 ; IHS/CMI/LAB - measure HEDIS ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
I2 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I BGPAGEB<51 S BGPSTOP=1 Q
I BGPAGEB>80 S BGPSTOP=1 Q
I BGPACTCL S BGPD1=1
I 'BGPD1 S BGPSTOP=1 Q
I $$CRC^BGP6D61(DFN,BGPEDATE) S BGPSTOP=1 Q ;has colorectal cancer
S BGPFOB=$$FOB^BGP6D61(DFN,BGPBDATE,BGPEDATE)
S BGPRECT=$$RECT^BGP6D61(DFN,BGPEDATE)
I BGPFOB]"" S BGPN1=1
S BGPOTH=""
I BGPN1=0 S BGPOTH=$$IBH^BGP6D61(DFN,BGPEDATE)
I BGPOTH]"" S BGPN1=1
S BGPREF="" I 'BGPN1 S BGPREF=$$REF^BGP6D61(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE) I BGPREF S BGPN1=1,BGPN4=1
S BGPVALUE=""
I BGPFOB]"" S BGPVALUE=$P(BGPFOB,U)_":"_$P(BGPFOB,U,2)_" "
I BGPOTH]"" S BGPVALUE=BGPVALUE_$P(BGPOTH,U)_":"_$P(BGPOTH,U,2)_" "
I BGPREF]"" S BGPVALUE=BGPVALUE_$P(BGPREF,U,3)_":"_$$DATE^BGP6UTL($P(BGPREF,U,2))
S BGPVALUE="AC|||"_BGPVALUE
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
Q
I5 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I 'BGPACTUP S BGPSTOP=1 Q
I BGPSEX'="F" S BGPSTOP=1 Q
I BGPAGEB<16 S BGPSTOP=1 Q
I BGPAGEB>25 S BGPSTOP=1 Q
I BGPACTUP S BGPD2=1
I BGPACTCL S BGPD1=1
I 'BGPD1 S BGPSTOP=1 Q
I BGPD1,BGPAGEB>15,BGPAGEB<21 S BGPD3=1
I BGPD1,BGPAGEB>20,BGPAGEB<26 S BGPD4=1
S BGPN1=$$CHL^BGP6D5(DFN,BGP365,BGPEDATE)
S BGPVALUE="AC"
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
Q
I7 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPHOSP,BGPIHD)=0
I $$V2IHD^BGP6D9(DFN,BGP365,BGPEDATE),$$FIRSTIHD^BGP6D9(DFN,BGPEDATE) S BGPIHD=1,BGPD1=1
I 'BGPD1 S BGPSTOP=1 Q ;not ihd patient
S (BGPVALUE,BGPLP,BGPLDL,BGPHDL,BGPTRI)=""
S BGPLDL=$$LDL^BGP6D2(DFN,BGP365,BGPEDATE) ;date^value
I $P(BGPLDL,U) S BGPN1=1
I $P(BGPLDL,U,3)]"" D
.S V=$P(BGPLDL,U,3)
.I V]"",+V'>100 S BGPN2=1
.I +V>100.99999,+V<131 S BGPN3=1
S BGPVALUE="IHD|||"_$S(BGPN1:"LDL; ",1:"")
S %=$S($P(BGPLDL,U,2):$$DATE^BGP6UTL($P(BGPLDL,U,2))_" "_$S($P(BGPLDL,U,3)]"":$P(BGPLDL,U,3),1:"no result"),1:"")
S BGPVALUE=BGPVALUE_%
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
Q
I11 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10
S BGPD1=0
I 'BGPDMD2 S BGPSTOP=1 Q ;not active diabetic
I BGPDMD2 S BGPD1=1
I 'BGPDM1 S BGPSTOP=1 Q
S BGPLHGB=$$HGBA1C^BGP6D2(DFN,BGP365,BGPEDATE)
S BGPN1=$P(BGPLHGB,U)
S BGPN2=0 I 'BGPN1!($P(BGPLHGB,U,2)=2)!($P(BGPLHGB,U,2)=3)!($P(BGPLHGB,U,2)=7)!(+$P(BGPLHGB,U,4)>9.0) S BGPN2=1
S BGPVALUE=""
I BGPN1 S BGPVALUE=BGPVALUE_"A1c:"_$$DATE^BGP6UTL($P(BGPLHGB,U,3))_" "_$P(BGPLHGB,U,4)
;I 'BGPN1 S BGPVALUE=BGPVALUE_"No A1c done"
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPG
73 S BGPEYE=$$EYE(DFN,BGP365,BGPEDATE)
S A=0 I $P(BGPEYE,U)=1 S A=1
S B=0 I $P(BGPEYE,U)=2 S B=1
S BGPN3=0 I A!(B) S BGPN3=1
I BGPN3 S BGPVALUE=BGPVALUE_";eye: "_$$DATE^BGP6UTL($P(BGPEYE,U,2))_" "_$P(BGPEYE,U,3)
K BGPG
K ^TMP($J,"A")
74 ;
S BGPLDL=$$LDL^BGP6D2(DFN,BGP365,BGPEDATE)
S BGPN4=$P(BGPLDL,U),BGPN5=0,BGPN6=0
I $P(BGPLDL,U,3)]"",+$P(BGPLDL,U,3),$P(BGPLDL,U,3)'>100 S BGPN6=1
I $P(BGPLDL,U,3)]"",+$P(BGPLDL,U,3),$P(BGPLDL,U,3)<130 S BGPN5=1
I BGPN4 S BGPVALUE=BGPVALUE_";LDL: "_$$DATE^BGP6UTL($P(BGPLDL,U,2))_" "_$P(BGPLDL,U,3)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPLDL,BGPHDL,BGPTRI,BGPLP
77 ;
S BGPUP=$$POSUR(DFN,BGP365,BGPEDATE)
S BGPN7=0 I $P(BGPUP,U)=1 S BGPN7=1
I BGPN7 S BGPVALUE=BGPVALUE_";NEP SCR: "_$$DATE^BGP6UTL($P(BGPUP,U,4))_" "_$P(BGPUP,U,2)_" "_$P(BGPUP,U,3)
S BGPN8=0,BGPNEPEV=$$NEPEVID(DFN,BGP365,BGPEDATE) I $P(BGPNEPEV,U) S BGPN8=1
I BGPN8 S BGPVALUE=BGPVALUE_";NEP EVID: "_$$DATE^BGP6UTL($P(BGPNEPEV,U,2))_" "_$P(BGPNEPEV,U,3)
I BGPN7,'BGPN8 S BGPVALUE=BGPVALUE_";NEP EVID: "_$$DATE^BGP6UTL($P(BGPUP,U,4))_" "_$P(BGPUP,U,2)_" "_$P(BGPUP,U,3)
S BGPN9=0 I BGPN7!(BGPN8) S BGPN9=1
S BGPN10=0 I BGPN1,BGPN3,BGPN4,BGPN9 S BGPN10=1
K ^TMP($J,"A")
I BGPN10 S BGPVALUE="all;"_BGPVALUE
S BGPVALUE="AD|||"_BGPVALUE
Q
I013 ;EP
K BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
S (BGPN1,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7)=0
;I 'BGPACTUP S BGPSTOP=1 Q ;not in denominator so don't bother
I BGPAGEB>2,BGPAGEB<22 S BGPD1=1
I BGPDMD2 S BGPD2=1
I BGPAGEB>2,BGPAGEB<7 S BGPD3=1
I BGPAGEB>6,BGPAGEB<11 S BGPD4=1
I BGPAGEB>10,BGPAGEB<15 S BGPD5=1
I BGPAGEB>14,BGPAGEB<19 S BGPD6=1
I BGPAGEB>18,BGPAGEB<22 S BGPD7=1
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7) S BGPST0P=1 Q
S BGPVALUE=$$DENTSRV^BGP6D21(DFN,BGPBDATE,BGPEDATE)
S BGPN1=0 I $P(BGPVALUE,U) S BGPN1=1
S BGPVALUE=$S(BGPD1:"UP",1:"")_$S(BGPD2:";AD",1:"")_"|||"_$$DATE^BGP6UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
Q
IH ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ
I 'BGPACTUP S BGPSTOP=1 ;must be at least user pop
S BGPTOBP=$$TOBACCO^BGP6D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
S BGPSDX=$$DX^BGP6D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
S BGP1320=$$DENT^BGP6D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&(+BGPSDX'="305.13"))!(BGP1320]"")!(BGPTOBP["CESSATION") S BGPD2=1
I 'BGPD2 S BGPSTOP=1 Q
I BGPD2,BGPACTCL S BGPD1=1
I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q ;hedis must be active clinical
S BGPTC=$$PED(DFN,BGP365,BGPEDATE)
I $P(BGPTC,U)]"" S BGPN1=1
S BGPTOM=$$TOMED(DFN,BGP365,BGPEDATE) I BGPTOM]"" S BGPN2=1
S BGPTOB=$$TOBACCO^BGP6D7(DFN,BGP365,BGPEDATE)
S BGPVALUE=$S(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$S(BGPD1:";AC",1:"")_"|||"_$S($P(BGPTC,U):"PT ED: "_$$DATE^BGP5UTL($P(BGPTC,U))_" "_$P(BGPTC,U,2),1:"")_" "_$S($P(BGPTOM,U)]"":"MED ED: "_$$DATE^BGP5UTL($P(BGPTOM,U))_" "_$P(BGPTOM,U,2),1:"")
I BGPN3,BGPRTYPE'=3 S BGPVALUE=BGPVALUE_";QUIT: "_$P(BGPTOB,U)_" "_$P(BGPTOB,U,2)_$S(+BGPSDX="305.13":" DX: 305.13"_$$DATE^BGP5UTL($P(BGPSDX,U,2)),1:"")
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPALLED,BGPTQ,BGPTC,BGPTOB,BGPSDX,BGP1320
Q
NEPEVID(P,BDATE,EDATE) ;
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP NEPHROPATHY DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U)_" "_$P(BGPG(1),U,2) ;has a dx
K BGPG
S T=$O(^ATXAX("B","BGP NEPHROPATHY PROCEDURES",0))
S (F,S)=0 F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S C=$P(^AUPNVPRC(F,0),U) D
.S G=0 S:$$ICD^ATXCHK(C,T,0) G=1
.Q:G=0
.S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")
.I D>EDATE Q
.I D<BDATE Q
.S S=1
I S=1 Q 1_U_D_" "_$P($$ICDOP^ICDCODE(C),U,2) ;has a PROCEDURE
S T=$O(^ATXAX("B","BGP NEPHROPATHY CPTS",0))
S X=$$CPT^BGP6DU(P,BDATE,EDATE,T,5)
I X]"" Q 1_U_X
;
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=49,'$$DNKA^BGP6D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q 2_"^"_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=69,'$$DNKA^BGP6D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q "2^"_D_"^Prv: "_R
Q ""
POSUR(P,BDATE,EDATE) ;EP
K BGPC,BGPX,BGP1
S BGPC=""
S %="",E=+$$CODEN^ICPTCOD(82043),%=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(82044),%=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(83518),%=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(84166),%=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
I %]"" S BGP1(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(81050),%=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
I %]"",$G(BGP1) S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)_" and 84166"
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP MICROALBUM LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA 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))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S (BGPC,BGPX(D))="1^MICROALB^^"_(9999999-D) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S (BGPC,BGPX(D))="1^MICROALB^^"_(9999999-D) Q
...Q
I $D(BGPX) S X=$O(BGPX(0)) Q BGPX(X) ;quit on the latest one found, if one found
;
S T=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT A/C RATIO 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))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S (BGPC,BGPX(D))="1^A/C RATIO^^"_(9999999-D) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S (BGPC,BGPX(D))="1^A/C RATIO^^"_(9999999-D) Q
...Q
I $D(BGPX) S X=$O(BGPX(0)) Q BGPX(X) ;quit on the latest one found, if one found
;
K BGPG S %=P_"^LAST LAB [DM AUDIT URINE PROTEIN TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
S (%,R)="" I $D(BGPG(1)) D Q R_"^"_"U"_"^"_%_"^"_$P(BGPG(1),U)
.S %=$P(^AUPNVLAB(+$P(BGPG(1),U,4),0),U,4)
.S R=$S(%="":"",%["+":1,%[">":1,$E(%)="P":1,$E(%)="p":1,$E(%)="L":1,$E(%)="l":1,$E(%)="M":1,$E(%)="m":1,$E(%)="S":1,$E(%)="s":1,$E(%)="c":"",$E(%)="C":"",+%>29:1,1:"")
S T=$O(^ATXAX("B","BGP URINE PROTEIN LOINC CODES",0))
S BGPC="",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:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S %=$P(^AUPNVLAB(X,0),U,4)
...;S R=$S(%="":"",%["+":1,%[">":1,$E(%)="P":1,$E(%)="p":1,$E(%)="c":"",$E(%)="C":"",+%>29:1,1:"")
...S R=$S(%="":"",%["+":1,%[">":1,$E(%)="P":1,$E(%)="p":1,$E(%)="L":1,$E(%)="l":1,$E(%)="M":1,$E(%)="m":1,$E(%)="S":1,$E(%)="s":1,$E(%)="c":"",$E(%)="C":"",+%>29:1,1:"")
...S BGPC=R_"^U^"_%_"^"_(9999999-D)
Q BGPC
;;;
LOINC(A,B) ;
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 ""
EYE(P,BDATE,EDATE) ;EP HEDIS ONLY
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"
S BD=BDATE
S ED=EDATE
S T=$O(^ATXAX("B","BGP HEDIS RETINAL SCREENING",0))
K BGPG S BGPG=$$CPT^BGP6DU(P,BDATE,EDATE,T,6)
I $P(BGPG,U)=1 Q "1^"_$P(BGPG,U,2)_"^Ret Scr CPT : "_$P(BGPG,U,3)
K BGPG S BGPG=$$LASTPRC^BGP6UTL1(P,"BGP HEDIS RETINAL SCRN PROCS",BDATE,EDATE)
I $P(BGPG,U)=1 Q "1^"_$P(BGPG,U,3)_"^Ret scr Proc: "_$P(BGPG,U,2)
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=17!(R=18)!(R=64)!(R="A2")),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q $S(R="A2":1,1:2)_"^"_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 "2^"_D_"^Prv: "_R
;now check for refusal of diabetic eye exam
S G=$$REFUSAL^BGP6UTL1(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused"
Q ""
DNKA(V) ;EP - is this a DNKA visit?
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
PED(P,BDATE,EDATE) ;EP
K BGPALLED
S Y="BGPALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPALLED(1)) S %="" D I %]"" Q %
.S (X,D)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X!(%]"") D
..S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-",2)="TO" S %=$P(BGPALLED(X),U)_U_T Q
..I $P(T,"-",2)="SHS" S %=$P(BGPALLED(X),U)_U_T Q
..I $P(T,"-")="TO",T'="TO-M" S %=$P(BGPALLED(1),U)_U_T Q
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S X=0,G="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G]"") S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S B=$$CLINIC^APCLV(V,"C")
.I B=94 S G=$P($P(^AUPNVSIT(V,0),U),".")_U_"CL 94" Q
.S Z=0 F S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G) S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320 S G=$P($P(^AUPNVSIT(V,0),U),".")_U_"ADA 1320" Q
.Q
I G]"" Q G
S G="",X=0 F S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X=""!(G]"") D
.S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D=""!(G]"") D
..S I=0 F S I=$O(^AUPNPREF("AA",P,9999999.09,X,D,I)) Q:I'=+I!(G]"") D
...S Z=$P($G(^AUPNPREF(I,0)),U,3)
...Q:Z=""
...I Z<BDATE Q
...I Z>EDATE Q
...S Y=$P($G(^AUTTEDT(X,0)),U,2)
...I $P(Y,"-")="TO"&(Y'="TO-M")!($P(Y,"-",2)="TO")!($P(Y,"-",2)="SHS") S G=Z_U_"ref "_Y
Q G
TOMED(P,BDATE,EDATE) ;EP
K BGPALLED
S Y="BGPALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPALLED(1)) S %="" D I %]"" Q %
.S (X,D)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X!(%]"") D
..S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I T="TO-M" S %=$P(BGPALLED(X),U)_U_T Q
S G="",X=0 F S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X=""!(G]"") D
.S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D=""!(G]"") D
..S I=0 F S I=$O(^AUPNPREF("AA",P,9999999.09,X,D,I)) Q:I'=+I!(G]"") D
...S Z=$P($G(^AUPNPREF(I,0)),U,3)
...Q:Z=""
...I Z<BDATE Q
...I Z>EDATE Q
...S Y=$P($G(^AUPNPREF(I,0)),U)
...Q:Y=""
...S Y=$P($G(^AUTTEDT(Y,0)),U,2)
...I Y="TO-M" S G=Z_U_"ref "_Y
Q G
BGP6DHE1 ; IHS/CMI/LAB - measure HEDIS ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
I2 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 IF BGPAGEB<51
SET BGPSTOP=1
QUIT
+3 IF BGPAGEB>80
SET BGPSTOP=1
QUIT
+4 IF BGPACTCL
SET BGPD1=1
+5 IF 'BGPD1
SET BGPSTOP=1
QUIT
+6 ;has colorectal cancer
IF $$CRC^BGP6D61(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+7 SET BGPFOB=$$FOB^BGP6D61(DFN,BGPBDATE,BGPEDATE)
+8 SET BGPRECT=$$RECT^BGP6D61(DFN,BGPEDATE)
+9 IF BGPFOB]""
SET BGPN1=1
+10 SET BGPOTH=""
+11 IF BGPN1=0
SET BGPOTH=$$IBH^BGP6D61(DFN,BGPEDATE)
+12 IF BGPOTH]""
SET BGPN1=1
+13 SET BGPREF=""
IF 'BGPN1
SET BGPREF=$$REF^BGP6D61(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE)
IF BGPREF
SET BGPN1=1
SET BGPN4=1
+14 SET BGPVALUE=""
+15 IF BGPFOB]""
SET BGPVALUE=$PIECE(BGPFOB,U)_":"_$PIECE(BGPFOB,U,2)_" "
+16 IF BGPOTH]""
SET BGPVALUE=BGPVALUE_$PIECE(BGPOTH,U)_":"_$PIECE(BGPOTH,U,2)_" "
+17 IF BGPREF]""
SET BGPVALUE=BGPVALUE_$PIECE(BGPREF,U,3)_":"_$$DATE^BGP6UTL($PIECE(BGPREF,U,2))
+18 SET BGPVALUE="AC|||"_BGPVALUE
+19 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
+20 QUIT
I5 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+3 IF BGPSEX'="F"
SET BGPSTOP=1
QUIT
+4 IF BGPAGEB<16
SET BGPSTOP=1
QUIT
+5 IF BGPAGEB>25
SET BGPSTOP=1
QUIT
+6 IF BGPACTUP
SET BGPD2=1
+7 IF BGPACTCL
SET BGPD1=1
+8 IF 'BGPD1
SET BGPSTOP=1
QUIT
+9 IF BGPD1
IF BGPAGEB>15
IF BGPAGEB<21
SET BGPD3=1
+10 IF BGPD1
IF BGPAGEB>20
IF BGPAGEB<26
SET BGPD4=1
+11 SET BGPN1=$$CHL^BGP6D5(DFN,BGP365,BGPEDATE)
+12 SET BGPVALUE="AC"
+13 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+14 QUIT
I7 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPHOSP,BGPIHD)=0
+2 IF $$V2IHD^BGP6D9(DFN,BGP365,BGPEDATE)
IF $$FIRSTIHD^BGP6D9(DFN,BGPEDATE)
SET BGPIHD=1
SET BGPD1=1
+3 ;not ihd patient
IF 'BGPD1
SET BGPSTOP=1
QUIT
+4 SET (BGPVALUE,BGPLP,BGPLDL,BGPHDL,BGPTRI)=""
+5 ;date^value
SET BGPLDL=$$LDL^BGP6D2(DFN,BGP365,BGPEDATE)
+6 IF $PIECE(BGPLDL,U)
SET BGPN1=1
+7 IF $PIECE(BGPLDL,U,3)]""
Begin DoDot:1
+8 SET V=$PIECE(BGPLDL,U,3)
+9 IF V]""
IF +V'>100
SET BGPN2=1
+10 IF +V>100.99999
IF +V<131
SET BGPN3=1
End DoDot:1
+11 SET BGPVALUE="IHD|||"_$SELECT(BGPN1:"LDL; ",1:"")
+12 SET %=$SELECT($PIECE(BGPLDL,U,2):$$DATE^BGP6UTL($PIECE(BGPLDL,U,2))_" "_$SELECT($PIECE(BGPLDL,U,3)]"":$PIECE(BGPLDL,U,3),1:"no result"),1:"")
+13 SET BGPVALUE=BGPVALUE_%
+14 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+15 QUIT
I11 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10
+2 SET BGPD1=0
+3 ;not active diabetic
IF 'BGPDMD2
SET BGPSTOP=1
QUIT
+4 IF BGPDMD2
SET BGPD1=1
+5 IF 'BGPDM1
SET BGPSTOP=1
QUIT
+6 SET BGPLHGB=$$HGBA1C^BGP6D2(DFN,BGP365,BGPEDATE)
+7 SET BGPN1=$PIECE(BGPLHGB,U)
+8 SET BGPN2=0
IF 'BGPN1!($PIECE(BGPLHGB,U,2)=2)!($PIECE(BGPLHGB,U,2)=3)!($PIECE(BGPLHGB,U,2)=7)!(+$PIECE(BGPLHGB,U,4)>9.0)
SET BGPN2=1
+9 SET BGPVALUE=""
+10 IF BGPN1
SET BGPVALUE=BGPVALUE_"A1c:"_$$DATE^BGP6UTL($PIECE(BGPLHGB,U,3))_" "_$PIECE(BGPLHGB,U,4)
+11 ;I 'BGPN1 S BGPVALUE=BGPVALUE_"No A1c done"
+12 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPG
73 SET BGPEYE=$$EYE(DFN,BGP365,BGPEDATE)
+1 SET A=0
IF $PIECE(BGPEYE,U)=1
SET A=1
+2 SET B=0
IF $PIECE(BGPEYE,U)=2
SET B=1
+3 SET BGPN3=0
IF A!(B)
SET BGPN3=1
+4 IF BGPN3
SET BGPVALUE=BGPVALUE_";eye: "_$$DATE^BGP6UTL($PIECE(BGPEYE,U,2))_" "_$PIECE(BGPEYE,U,3)
+5 KILL BGPG
+6 KILL ^TMP($JOB,"A")
74 ;
+1 SET BGPLDL=$$LDL^BGP6D2(DFN,BGP365,BGPEDATE)
+2 SET BGPN4=$PIECE(BGPLDL,U)
SET BGPN5=0
SET BGPN6=0
+3 IF $PIECE(BGPLDL,U,3)]""
IF +$PIECE(BGPLDL,U,3)
IF $PIECE(BGPLDL,U,3)'>100
SET BGPN6=1
+4 IF $PIECE(BGPLDL,U,3)]""
IF +$PIECE(BGPLDL,U,3)
IF $PIECE(BGPLDL,U,3)<130
SET BGPN5=1
+5 IF BGPN4
SET BGPVALUE=BGPVALUE_";LDL: "_$$DATE^BGP6UTL($PIECE(BGPLDL,U,2))_" "_$PIECE(BGPLDL,U,3)
+6 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPLDL,BGPHDL,BGPTRI,BGPLP
77 ;
+1 SET BGPUP=$$POSUR(DFN,BGP365,BGPEDATE)
+2 SET BGPN7=0
IF $PIECE(BGPUP,U)=1
SET BGPN7=1
+3 IF BGPN7
SET BGPVALUE=BGPVALUE_";NEP SCR: "_$$DATE^BGP6UTL($PIECE(BGPUP,U,4))_" "_$PIECE(BGPUP,U,2)_" "_$PIECE(BGPUP,U,3)
+4 SET BGPN8=0
SET BGPNEPEV=$$NEPEVID(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPNEPEV,U)
SET BGPN8=1
+5 IF BGPN8
SET BGPVALUE=BGPVALUE_";NEP EVID: "_$$DATE^BGP6UTL($PIECE(BGPNEPEV,U,2))_" "_$PIECE(BGPNEPEV,U,3)
+6 IF BGPN7
IF 'BGPN8
SET BGPVALUE=BGPVALUE_";NEP EVID: "_$$DATE^BGP6UTL($PIECE(BGPUP,U,4))_" "_$PIECE(BGPUP,U,2)_" "_$PIECE(BGPUP,U,3)
+7 SET BGPN9=0
IF BGPN7!(BGPN8)
SET BGPN9=1
+8 SET BGPN10=0
IF BGPN1
IF BGPN3
IF BGPN4
IF BGPN9
SET BGPN10=1
+9 KILL ^TMP($JOB,"A")
+10 IF BGPN10
SET BGPVALUE="all;"_BGPVALUE
+11 SET BGPVALUE="AD|||"_BGPVALUE
+12 QUIT
I013 ;EP
+1 KILL BGPN1,BGPVALUE,BGPN2,BGPN3,BGPN4,BGPN5
+2 SET (BGPN1,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7)=0
+3 ;I 'BGPACTUP S BGPSTOP=1 Q ;not in denominator so don't bother
+4 IF BGPAGEB>2
IF BGPAGEB<22
SET BGPD1=1
+5 IF BGPDMD2
SET BGPD2=1
+6 IF BGPAGEB>2
IF BGPAGEB<7
SET BGPD3=1
+7 IF BGPAGEB>6
IF BGPAGEB<11
SET BGPD4=1
+8 IF BGPAGEB>10
IF BGPAGEB<15
SET BGPD5=1
+9 IF BGPAGEB>14
IF BGPAGEB<19
SET BGPD6=1
+10 IF BGPAGEB>18
IF BGPAGEB<22
SET BGPD7=1
+11 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7)
SET BGPST0P=1
QUIT
+12 SET BGPVALUE=$$DENTSRV^BGP6D21(DFN,BGPBDATE,BGPEDATE)
+13 SET BGPN1=0
IF $PIECE(BGPVALUE,U)
SET BGPN1=1
+14 SET BGPVALUE=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPD2:";AD",1:"")_"|||"_$$DATE^BGP6UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+15 QUIT
IH ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 KILL BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ
+3 ;must be at least user pop
IF 'BGPACTUP
SET BGPSTOP=1
+4 SET BGPTOBP=$$TOBACCO^BGP6D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+5 SET BGPSDX=$$DX^BGP6D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+6 SET BGP1320=$$DENT^BGP6D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+7 IF $PIECE(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&(+BGPSDX'="305.13"))!(BGP1320]"")!(BGPTOBP["CESSATION")
SET BGPD2=1
+8 IF 'BGPD2
SET BGPSTOP=1
QUIT
+9 IF BGPD2
IF BGPACTCL
SET BGPD1=1
+10 ;hedis must be active clinical
IF BGPRTYPE=3
IF 'BGPD1
SET BGPSTOP=1
QUIT
+11 SET BGPTC=$$PED(DFN,BGP365,BGPEDATE)
+12 IF $PIECE(BGPTC,U)]""
SET BGPN1=1
+13 SET BGPTOM=$$TOMED(DFN,BGP365,BGPEDATE)
IF BGPTOM]""
SET BGPN2=1
+14 SET BGPTOB=$$TOBACCO^BGP6D7(DFN,BGP365,BGPEDATE)
+15 SET BGPVALUE=$SELECT(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$SELECT(BGPD1:";AC",1:"")_"|||"_$SELECT(...
... $PIECE(BGPTC,U):"PT ED: "_$$DATE^BGP5UTL($PIECE(BGPTC,U))_" "_$PIECE(BGPTC,U,2),1:"")_" "_$SELECT($PIECE(BGPTOM,U)]"":"MED ED: "_$$DATE^BGP5UTL($PIECE(BGPTOM,U))_" "_$PIECE(BGPTOM,U,2),1:"")
+16 IF BGPN3
IF BGPRTYPE'=3
SET BGPVALUE=BGPVALUE_";QUIT: "_$PIECE(BGPTOB,U)_" "_$PIECE(BGPTOB,U,2)_$SELECT(+BGPSDX="305.13":" DX: 305.13"_$$DATE^BGP5UTL($PIECE(BGPSDX,U,2)),1:"")
+17 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPALLED,BGPTQ,BGPTC,BGPTOB,BGPSDX,BGP1320
+18 QUIT
NEPEVID(P,BDATE,EDATE) ;
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^LAST DX [BGP NEPHROPATHY DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 ;has a dx
IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U)_" "_$PIECE(BGPG(1),U,2)
+5 KILL BGPG
+6 SET T=$ORDER(^ATXAX("B","BGP NEPHROPATHY PROCEDURES",0))
+7 SET (F,S)=0
FOR
SET F=$ORDER(^AUPNVPRC("AC",P,F))
IF F'=+F!(S)
QUIT
SET C=$PIECE(^AUPNVPRC(F,0),U)
Begin DoDot:1
+8 SET G=0
IF $$ICD^ATXCHK(C,T,0)
SET G=1
+9 IF G=0
QUIT
+10 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+11 IF D>EDATE
QUIT
+12 IF D<BDATE
QUIT
+13 SET S=1
End DoDot:1
+14 ;has a PROCEDURE
IF S=1
QUIT 1_U_D_" "_$PIECE($$ICDOP^ICDCODE(C),U,2)
+15 SET T=$ORDER(^ATXAX("B","BGP NEPHROPATHY CPTS",0))
+16 SET X=$$CPT^BGP6DU(P,BDATE,EDATE,T,5)
+17 IF X]""
QUIT 1_U_X
+18 ;
+19 KILL ^TMP($JOB,"A")
+20 SET A="^TMP($J,""A"","
+21 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+22 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=49
IF '$$DNKA^BGP6D21($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+23 IF Y
QUIT 2_"^"_D_"^Cl: "_R
+24 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=69
IF '$$DNKA^BGP6D21($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+25 IF Y
QUIT "2^"_D_"^Prv: "_R
+26 QUIT ""
POSUR(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPX,BGP1
+2 SET BGPC=""
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(82043)
SET %=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
+4 IF %]""
SET BGPX(9999999-$PIECE(%,U,2))="1^MICROALB-CPT^^"_$PIECE(%,U,2)
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(82044)
SET %=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
+6 IF %]""
SET BGPX(9999999-$PIECE(%,U,2))="1^MICROALB-CPT^^"_$PIECE(%,U,2)
+7 SET %=""
SET E=+$$CODEN^ICPTCOD(83518)
SET %=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
+8 IF %]""
SET BGPX(9999999-$PIECE(%,U,2))="1^MICROALB-CPT^^"_$PIECE(%,U,2)
+9 SET %=""
SET E=+$$CODEN^ICPTCOD(84166)
SET %=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
+10 IF %]""
SET BGP1(9999999-$PIECE(%,U,2))="1^MICROALB-CPT^^"_$PIECE(%,U,2)
+11 SET %=""
SET E=+$$CODEN^ICPTCOD(81050)
SET %=$$CPTI^BGP6DU(P,BDATE,EDATE,E)
+12 IF %]""
IF $GET(BGP1)
SET BGPX(9999999-$PIECE(%,U,2))="1^MICROALB-CPT^^"_$PIECE(%,U,2)_" and 84166"
+13 ;now get all loinc/taxonomy tests
+14 SET T=$ORDER(^ATXAX("B","BGP MICROALBUM LOINC CODES",0))
+15 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
+16 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
+17 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+18 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+19 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+20 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET (BGPC,BGPX(D))="1^MICROALB^^"_(9999999-D)
QUIT
+21 IF 'T
QUIT
+22 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+23 IF '$$LOINC(J,T)
QUIT
+24 SET (BGPC,BGPX(D))="1^MICROALB^^"_(9999999-D)
QUIT
+25 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;quit on the latest one found, if one found
IF $DATA(BGPX)
SET X=$ORDER(BGPX(0))
QUIT BGPX(X)
+27 ;
+28 SET T=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+29 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
+30 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
+31 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+32 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+33 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+34 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET (BGPC,BGPX(D))="1^A/C RATIO^^"_(9999999-D)
QUIT
+35 IF 'T
QUIT
+36 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+37 IF '$$LOINC(J,T)
QUIT
+38 SET (BGPC,BGPX(D))="1^A/C RATIO^^"_(9999999-D)
QUIT
+39 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+40 ;quit on the latest one found, if one found
IF $DATA(BGPX)
SET X=$ORDER(BGPX(0))
QUIT BGPX(X)
+41 ;
+42 KILL BGPG
SET %=P_"^LAST LAB [DM AUDIT URINE PROTEIN TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+43 SET (%,R)=""
IF $DATA(BGPG(1))
Begin DoDot:1
+44 SET %=$PIECE(^AUPNVLAB(+$PIECE(BGPG(1),U,4),0),U,4)
+45 SET R=$SELECT(%="":"",%["+":1,%[">":1,$EXTRACT(%)="P":1,$EXTRACT(%)="p":1,$EXTRACT(%)="L":1,$EXTRACT(%)="l":1,$EXTRACT(%)="M":1,$EXTRACT(%)="m":1,$EXTRACT(%)="S":1,$EXTRACT(%)="s":1,$EXTRACT(%)="c":"",$EXTRACT(%)="C":"",+%>29:1,1:"")
End DoDot:1
QUIT R_"^"_"U"_"^"_%_"^"_$PIECE(BGPG(1),U)
+46 SET T=$ORDER(^ATXAX("B","BGP URINE PROTEIN LOINC CODES",0))
+47 SET BGPC=""
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
+48 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+49 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+50 IF 'T
QUIT
+51 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+52 IF '$$LOINC(J,T)
QUIT
+53 SET %=$PIECE(^AUPNVLAB(X,0),U,4)
+54 ;S R=$S(%="":"",%["+":1,%[">":1,$E(%)="P":1,$E(%)="p":1,$E(%)="c":"",$E(%)="C":"",+%>29:1,1:"")
+55 SET R=$SELECT(%="":"",%["+":1,%[">":1,$EXTRACT(%)="P":1,$EXTRACT(%)="p":1,$EXTRACT(%)="L":1,$EXTRACT(%)="l":1,$EXTRACT(%)="M":1,$EXTRACT(%)="m":1,$EXTRACT(%)="S":1,$EXTRACT(%)="s":1,$EXTRACT(%)="c":"",$EXTRACT(%)="C":"",
+%>29:1,1:"")
+56 SET BGPC=R_"^U^"_%_"^"_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+57 QUIT BGPC
+58 ;;;
LOINC(A,B) ;
+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 ""
EYE(P,BDATE,EDATE) ;EP HEDIS ONLY
+1 KILL BGPG
SET %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+2 IF $DATA(BGPG(1))
QUIT "1^"_$PIECE(BGPG(1),U)_"^Diab Eye Ex"
+3 SET BD=BDATE
+4 SET ED=EDATE
+5 SET T=$ORDER(^ATXAX("B","BGP HEDIS RETINAL SCREENING",0))
+6 KILL BGPG
SET BGPG=$$CPT^BGP6DU(P,BDATE,EDATE,T,6)
+7 IF $PIECE(BGPG,U)=1
QUIT "1^"_$PIECE(BGPG,U,2)_"^Ret Scr CPT : "_$PIECE(BGPG,U,3)
+8 KILL BGPG
SET BGPG=$$LASTPRC^BGP6UTL1(P,"BGP HEDIS RETINAL SCRN PROCS",BDATE,EDATE)
+9 IF $PIECE(BGPG,U)=1
QUIT "1^"_$PIECE(BGPG,U,3)_"^Ret scr Proc: "_$PIECE(BGPG,U,2)
+10 KILL ^TMP($JOB,"A")
+11 SET A="^TMP($J,""A"","
+12 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+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=17!(R=18)!(R=64)!(R="A2"))
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+14 IF Y
QUIT $SELECT(R="A2":1,1:2)_"^"_D_"^Cl: "_R
+15 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)
+16 IF Y
QUIT "2^"_D_"^Prv: "_R
+17 ;now check for refusal of diabetic eye exam
+18 SET G=$$REFUSAL^BGP6UTL1(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
+19 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused"
+20 QUIT ""
DNKA(V) ;EP - is this a DNKA visit?
+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
PED(P,BDATE,EDATE) ;EP
+1 KILL BGPALLED
+2 SET Y="BGPALLED("
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPALLED(1))
SET %=""
Begin DoDot:1
+5 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:2
+6 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+7 IF 'T
QUIT
+8 IF '$DATA(^AUTTEDT(T,0))
QUIT
+9 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+10 IF $PIECE(T,"-",2)="TO"
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+11 IF $PIECE(T,"-",2)="SHS"
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+12 IF $PIECE(T,"-")="TO"
IF T'="TO-M"
SET %=$PIECE(BGPALLED(1),U)_U_T
QUIT
End DoDot:2
End DoDot:1
IF %]""
QUIT %
+13 KILL ^TMP($JOB,"A")
+14 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+15 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+16 SET X=0
SET G=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G]"")
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+17 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+18 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+19 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+20 SET B=$$CLINIC^APCLV(V,"C")
+21 IF B=94
SET G=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CL 94"
QUIT
+22 SET Z=0
FOR
SET Z=$ORDER(^AUPNVDEN("AD",V,Z))
IF Z'=+Z!(G)
QUIT
SET B=$PIECE($GET(^AUPNVDEN(Z,0)),U)
IF B
SET B=$PIECE($GET(^AUTTADA(B,0)),U)
IF B=1320
SET G=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"ADA 1320"
QUIT
+23 QUIT
End DoDot:1
+24 IF G]""
QUIT G
+25 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.09,X))
IF X=""!(G]"")
QUIT
Begin DoDot:1
+26 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D))
IF D=""!(G]"")
QUIT
Begin DoDot:2
+27 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D,I))
IF I'=+I!(G]"")
QUIT
Begin DoDot:3
+28 SET Z=$PIECE($GET(^AUPNPREF(I,0)),U,3)
+29 IF Z=""
QUIT
+30 IF Z<BDATE
QUIT
+31 IF Z>EDATE
QUIT
+32 SET Y=$PIECE($GET(^AUTTEDT(X,0)),U,2)
+33 IF $PIECE(Y,"-")="TO"&(Y'="TO-M")!($PIECE(Y,"-",2)="TO")!($PIECE(Y,"-",2)="SHS")
SET G=Z_U_"ref "_Y
End DoDot:3
End DoDot:2
End DoDot:1
+34 QUIT G
TOMED(P,BDATE,EDATE) ;EP
+1 KILL BGPALLED
+2 SET Y="BGPALLED("
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPALLED(1))
SET %=""
Begin DoDot:1
+5 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:2
+6 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+7 IF 'T
QUIT
+8 IF '$DATA(^AUTTEDT(T,0))
QUIT
+9 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+10 IF T="TO-M"
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
End DoDot:2
End DoDot:1
IF %]""
QUIT %
+11 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.09,X))
IF X=""!(G]"")
QUIT
Begin DoDot:1
+12 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D))
IF D=""!(G]"")
QUIT
Begin DoDot:2
+13 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D,I))
IF I'=+I!(G]"")
QUIT
Begin DoDot:3
+14 SET Z=$PIECE($GET(^AUPNPREF(I,0)),U,3)
+15 IF Z=""
QUIT
+16 IF Z<BDATE
QUIT
+17 IF Z>EDATE
QUIT
+18 SET Y=$PIECE($GET(^AUPNPREF(I,0)),U)
+19 IF Y=""
QUIT
+20 SET Y=$PIECE($GET(^AUTTEDT(Y,0)),U,2)
+21 IF Y="TO-M"
SET G=Z_U_"ref "_Y
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT G
