BGP6DHE1.m

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