BGP1DHE1 ; IHS/CMI/LAB - measure HEDIS ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
I2 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
S (BGPFOB,BGPSIG,BGPCOLO,BGPBE)=""
I BGPAGEB<50 S BGPSTOP=1 Q
I BGPAGEB>75 S BGPSTOP=1 Q
I BGPACTCL S BGPD1=1
I 'BGPD1 S BGPSTOP=1 Q
I $$CRC^BGP1D61(DFN,BGPEDATE) S BGPSTOP=1 Q ;has colorectal cancer
S BGPFOB=$$FOB^BGP1D62(DFN,BGPBDATE,BGPEDATE)
S BGPSIG=$$SIG^BGP1D62(DFN,BGPEDATE)
S BGPCOLO=$$COLO^BGP1D62(DFN,BGPEDATE)
;S BGPBE=$$BE^BGP1D61(DFN,BGPEDATE)
;S BGPRECT=$$RECT^BGP1D61(DFN,BGPEDATE)
I BGPFOB]""!(BGPSIG]"")!(BGPCOLO]"") S BGPN1=1
;S BGPREF="" I 'BGPN1 S BGPREF=$$REF^BGP1D61(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE) I BGPREF S BGPN4=1
S BGPVALUE=""
I BGPFOB]"" S BGPVALUE="FOBT: "_$P(BGPFOB,U)_" "_$$DATE^BGP1UTL($P(BGPFOB,U,2))_" "
I BGPSIG]"" S BGPVALUE=BGPVALUE_"SIG: "_$P(BGPSIG,U)_":"_$P(BGPSIG,U,2)_" "
I BGPCOLO]"" S BGPVALUE=BGPVALUE_"COLO: "_$P(BGPCOLO,U)_":"_$P(BGPCOLO,U,2)_" "
;I BGPBE]"" S BGPVALUE=BGPVALUE_"BE: "_$P(BGPBE,U)_":"_$P(BGPBE,U,2)_" "
;I BGPREF]"" S BGPVALUE=BGPVALUE_$P(BGPREF,U,3)_":"_$$DATE^BGP1UTL($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^BGP1D53(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^BGP1D9(DFN,BGP365,BGPEDATE),$$FIRSTIHD^BGP1D9(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^BGP1D2(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^BGP1UTL($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,BGPN11
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(DFN,BGP365,BGPEDATE)
S BGPN1=$P(BGPLHGB,U)
S BGPN2=$P(BGPLHGB,U,2)
S BGPN11=$P(BGPLHGB,U,3)
S BGPVALUE=""
S BGPVALUE=BGPVALUE_"A1c:"_$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^BGP1UTL($P(BGPEYE,U,2))_" "_$P(BGPEYE,U,3)
K BGPG
K ^TMP($J,"A")
74 ;
S BGPLDL=$$LDL^BGP1D2(DFN,BGP365,BGPEDATE)
S BGPN4=$P(BGPLDL,U),BGPN5=0,BGPN6=0
I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)["3048F" S BGPN6=1,$P(BGPLDL,U,3)="CPT 3048F LDL<100"
I $P(BGPLDL,U,3)]"",$P(BGPLDL,U,3)["CPT" G 741
I $P(BGPLDL,U,3)]"",+$P(BGPLDL,U,3)>0,$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
741 ;
I BGPN4 S BGPVALUE=BGPVALUE_";LDL: "_$$DATE^BGP1UTL($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=$$MEDNEPH^BGP1DHE2(DFN,BGP365,BGPEDATE)
S BGPN7=0 I $P(BGPUP,U)=1 S BGPN7=1
I BGPN7 S BGPVALUE=BGPVALUE_";NEP SCR/EVID: "_$$DATE^BGP1UTL($P(BGPUP,U,4))_" "_$P(BGPUP,U,2)_" "_$P(BGPUP,U,3)
BP ;
S (BGPN8,BGPN9)=0,BGPV=""
S BGPBP=$$MEANBP^BGP1D2(DFN,BGPBDATE,BGPEDATE)
I BGPBP="" S BGPBP=$$BPCPT(DFN,BGPBDATE,BGPEDATE) I BGPBP]"" D G BPS
.I $P(BGPBP,U,1) S BGPV="BP <130/80,140/90: BP :"_$P(BGPBP,U,3),BGPN8=1,BGPN9=1 Q
.I $P(BGPBP,U,2) S BGPV="BP <140/90: BP :"_$P(BGPBP,U,3),BGPN9=1 Q
I BGPBP="" G BPS
S S=$P(BGPBP," ",1)
S DS=$P(S,"/",2),S=$P(S,"/",1)
I S<130&(DS<80) S BGPN8=1,BGPN9=1,BGPV="BP: <130/80,140/90: BP: "_S_"/"_DS G BPS
I S<140&(DS<90) S BGPN9=1,BGPV="BP: <140/90: BP: "_S_"/"_DS
BPS ;
K ^TMP($J,"A")
I BGPV]"" S BGPVALUE=BGPVALUE_";"_BGPV
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^BGP1D21(DFN,BGPBDATE,BGPEDATE,1)
S BGPN1=0 I $P(BGPVALUE,U) S BGPN1=1
S BGPVALUE=$S(BGPD1:"UP",1:"")_$S(BGPD2:";AD",1:"")_"|||"_$$DATE^BGP1UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
Q
BPCPT(P,BDATE,EDATE) ;EP
NEW S,D,C,E,BGPG,X,Y,G,T
K BGPG S Y="BGPG(",X=P_"^ALL VISIT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
;go through and get all cpt codes in the 2 taxonomies and table by date using the lowest value on that day, skip ER visits
S X=0,G="" F S X=$O(BGPG(X)) Q:X'=+X D
.S V=$P(BGPG(X),U,5) ;visit ien
.Q:'$D(^AUPNVSIT(V,0))
.Q:$$CLINIC^APCLV(V,"C")=30 ;clinic ER
.Q:'$D(^AUPNVCPT("AD",V)) ;no cpt codes
.S E=0 F S E=$O(^AUPNVCPT("AD",V,E)) Q:E'=+E D
..S C=$P($G(^AUPNVCPT(E,0)),U)
..I 'C Q
..S D=$P($P(^AUPNVSIT(V,0),U),"."),D=(9999999-D)_"."_$P(D,".",2)
..I $$ICD^ATXCHK(C,$O(^ATXAX("B","BGP SYSTOLIC BP CPTS",0)),1) D
...S Y=$P($$CPT^ICPTCOD(C),U,2)
...S:'$D(S(D)) S(D)=Y
...I +S(D)>+Y S S(D)=Y
..I $$ICD^ATXCHK(C,$O(^ATXAX("B","BGP DIASTOLIC BP CPTS",0)),1) D
...S Y=$P($$CPT^ICPTCOD(C),U,2)
...S:'$D(T(D)) T(D)=Y
...I +T(D)>+Y S T(D)=Y
I '$D(S),'$D(T) Q ""
S S=$O(S(0)) I S S S=S(S)
S D=$O(T(0)) I D S D=T(D)
I S=""!(D="") Q 0_U_0_U_S_"/"_$P(D,".")
I S="3074F",D="3078F" Q 1_U_1_U_S_"/"_$P(D,".")
I S="3074F",D="3079F" Q 0_U_1_U_S_"/"_$P(D,".")
I S="3075F",D="3078F" Q 0_U_1_U_S_"/"_$P(D,".")
I S="3075F",D="3079F" Q 0_U_1_U_S_"/"_$P(D,".")
I S="3076F",D="3078F" Q 0_U_1_U_S_"/"_$P(D,".")
I S="3076F",D="3079F" Q 0_U_1_U_S_"/"_$P(D,".")
I S="3077F",D="3080F" Q 0_U_0_U_S_"/"_$P(D,".")
Q 0_U_0_U_S_"/"_$P(D,".")
Q ""
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^BGP1DU(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=$$TRAN^BGP1DU(P,BDATE,EDATE,T,6)
I $P(BGPG,U)=1 Q "1^"_$P(BGPG,U,2)_"^Ret Scr TRAN : "_$P(BGPG,U,3)
K BGPG S BGPG=$$LASTPRC^BGP1UTL1(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":2,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
K BGPG S %=P_"^LAST DX V72.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "2^"_$P(BGPG(1),U)_"V72.0 DX"
;now check for refusal of diabetic eye exam
S G=$$REFUSAL^BGP1UTL1(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
HGBA1C(P,BDATE,EDATE) ;EP
NEW BGPG,BGPT,BGPC,E,%,L,T,BGPLT,D,X,J,C,G
S BGPC=0
S G=$$CPT^BGP1DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP HGBA1C CPTS",0)),5)
I G]"" S BGPC=BGPC+1,BGPT((9999999-$P(G,U,1)),BGPC)=U_"CPT "_$P(G,U,2)
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT HGB A1C 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) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X 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=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4)_U_"LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP1D2(J,T)
...S BGPC=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4)_U_"LAB LOINC: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$P(^AUPNVLAB(X,11),U,13)
...Q
; now got though and set return value of done 1 or 0^numerator 2-7^date^value
I '$D(BGPT) Q 0_U_1_U_0_U_"No documented HgbA1c" ;no tests so is hit in numerator
; now get rid of all on same day where 1 has a result and the other doesn't
K BGPC S D=0 F S D=$O(BGPT(D)) Q:D'=+D S C=0,G=0 F S C=$O(BGPT(D,C)) Q:C'=+C D
.I $P(BGPT(D,C),U,1)]"" S BGPC(D,C)="" ;=D_U_C
.;I BGPC>0,$P(BGPT(D,C),U,1)="" K BGPT(D,C)
I $D(BGPC) D
.;loop through and get rid of all w/o results
.S D=0 F S D=$O(BGPT(D)) Q:D="" D
..S C=0 F S C=$O(BGPT(D,C)) Q:C="" D
...I '$D(BGPC(D,C)) K BGPT(D,C)
S D=0,G=""
S D=$O(BGPT(D))
S C=0,C=$O(BGPT(D,C))
S X=$P(BGPT(D,C),U,1)
I $$UP^XLFSTR(X)="COMMENT" Q 1_U_1_U_0_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" (no result) "_X
I X="" D Q G
.S G=""
.I $P(BGPT(D,C),U,2)="CPT 3046F"!($P(BGPT(D,C),U,2)="CPT 83036")!($P(BGPT(D,C),U,2)="CPT 83037") S G=1_U_1_U_0_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D) Q
.I $P(BGPT(D,C),U,2)="CPT 3047F"!($P(BGPT(D,C),U,2)="CPT 3045F") S G=1_U_0_U_0_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D) Q
.I $P(BGPT(D,C),U,2)="CPT 3044F" S G=1_U_0_U_1_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D) Q
.S G=1_U_1_U_0_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" (no result)" Q
S X=$$STRIP^XLFSTR(X," ") ;strip spaces
I X[">9" Q 1_U_1_U_0_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" "_X
S X=$$STV^BGP1EO1(X)
I X="" Q 1_U_1_U_0_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" (no result) "_X
I +X>9 Q 1_U_1_U_0_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" "_X
I +X<7 Q 1_U_0_U_1_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" "_X
Q 1_U_0_U_0_U_$P(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" result: "_X
;
BGP1DHE1 ; IHS/CMI/LAB - measure HEDIS ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
I2 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET (BGPFOB,BGPSIG,BGPCOLO,BGPBE)=""
+3 IF BGPAGEB<50
SET BGPSTOP=1
QUIT
+4 IF BGPAGEB>75
SET BGPSTOP=1
QUIT
+5 IF BGPACTCL
SET BGPD1=1
+6 IF 'BGPD1
SET BGPSTOP=1
QUIT
+7 ;has colorectal cancer
IF $$CRC^BGP1D61(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+8 SET BGPFOB=$$FOB^BGP1D62(DFN,BGPBDATE,BGPEDATE)
+9 SET BGPSIG=$$SIG^BGP1D62(DFN,BGPEDATE)
+10 SET BGPCOLO=$$COLO^BGP1D62(DFN,BGPEDATE)
+11 ;S BGPBE=$$BE^BGP1D61(DFN,BGPEDATE)
+12 ;S BGPRECT=$$RECT^BGP1D61(DFN,BGPEDATE)
+13 IF BGPFOB]""!(BGPSIG]"")!(BGPCOLO]"")
SET BGPN1=1
+14 ;S BGPREF="" I 'BGPN1 S BGPREF=$$REF^BGP1D61(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE) I BGPREF S BGPN4=1
+15 SET BGPVALUE=""
+16 IF BGPFOB]""
SET BGPVALUE="FOBT: "_$PIECE(BGPFOB,U)_" "_$$DATE^BGP1UTL($PIECE(BGPFOB,U,2))_" "
+17 IF BGPSIG]""
SET BGPVALUE=BGPVALUE_"SIG: "_$PIECE(BGPSIG,U)_":"_$PIECE(BGPSIG,U,2)_" "
+18 IF BGPCOLO]""
SET BGPVALUE=BGPVALUE_"COLO: "_$PIECE(BGPCOLO,U)_":"_$PIECE(BGPCOLO,U,2)_" "
+19 ;I BGPBE]"" S BGPVALUE=BGPVALUE_"BE: "_$P(BGPBE,U)_":"_$P(BGPBE,U,2)_" "
+20 ;I BGPREF]"" S BGPVALUE=BGPVALUE_$P(BGPREF,U,3)_":"_$$DATE^BGP1UTL($P(BGPREF,U,2))
+21 SET BGPVALUE="AC|||"_BGPVALUE
+22 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
+23 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^BGP1D53(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^BGP1D9(DFN,BGP365,BGPEDATE)
IF $$FIRSTIHD^BGP1D9(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^BGP1D2(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^BGP1UTL($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,BGPN11
+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(DFN,BGP365,BGPEDATE)
+7 SET BGPN1=$PIECE(BGPLHGB,U)
+8 SET BGPN2=$PIECE(BGPLHGB,U,2)
+9 SET BGPN11=$PIECE(BGPLHGB,U,3)
+10 SET BGPVALUE=""
+11 SET BGPVALUE=BGPVALUE_"A1c:"_$PIECE(BGPLHGB,U,4)
+12 ;I 'BGPN1 S BGPVALUE=BGPVALUE_"No A1c done"
+13 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^BGP1UTL($PIECE(BGPEYE,U,2))_" "_$PIECE(BGPEYE,U,3)
+5 KILL BGPG
+6 KILL ^TMP($JOB,"A")
74 ;
+1 SET BGPLDL=$$LDL^BGP1D2(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)["3048F"
SET BGPN6=1
SET $PIECE(BGPLDL,U,3)="CPT 3048F LDL<100"
+4 IF $PIECE(BGPLDL,U,3)]""
IF $PIECE(BGPLDL,U,3)["CPT"
GOTO 741
+5 IF $PIECE(BGPLDL,U,3)]""
IF +$PIECE(BGPLDL,U,3)>0
IF $PIECE(BGPLDL,U,3)<100
SET BGPN6=1
+6 ;I $P(BGPLDL,U,3)]"",+$P(BGPLDL,U,3),$P(BGPLDL,U,3)<130 S BGPN5=1
741 ;
+1 IF BGPN4
SET BGPVALUE=BGPVALUE_";LDL: "_$$DATE^BGP1UTL($PIECE(BGPLDL,U,2))_" "_$PIECE(BGPLDL,U,3)
+2 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPLDL,BGPHDL,BGPTRI,BGPLP
77 ;
+1 SET BGPUP=$$MEDNEPH^BGP1DHE2(DFN,BGP365,BGPEDATE)
+2 SET BGPN7=0
IF $PIECE(BGPUP,U)=1
SET BGPN7=1
+3 IF BGPN7
SET BGPVALUE=BGPVALUE_";NEP SCR/EVID: "_$$DATE^BGP1UTL($PIECE(BGPUP,U,4))_" "_$PIECE(BGPUP,U,2)_" "_$PIECE(BGPUP,U,3)
BP ;
+1 SET (BGPN8,BGPN9)=0
SET BGPV=""
+2 SET BGPBP=$$MEANBP^BGP1D2(DFN,BGPBDATE,BGPEDATE)
+3 IF BGPBP=""
SET BGPBP=$$BPCPT(DFN,BGPBDATE,BGPEDATE)
IF BGPBP]""
Begin DoDot:1
+4 IF $PIECE(BGPBP,U,1)
SET BGPV="BP <130/80,140/90: BP :"_$PIECE(BGPBP,U,3)
SET BGPN8=1
SET BGPN9=1
QUIT
+5 IF $PIECE(BGPBP,U,2)
SET BGPV="BP <140/90: BP :"_$PIECE(BGPBP,U,3)
SET BGPN9=1
QUIT
End DoDot:1
GOTO BPS
+6 IF BGPBP=""
GOTO BPS
+7 SET S=$PIECE(BGPBP," ",1)
+8 SET DS=$PIECE(S,"/",2)
SET S=$PIECE(S,"/",1)
+9 IF S<130&(DS<80)
SET BGPN8=1
SET BGPN9=1
SET BGPV="BP: <130/80,140/90: BP: "_S_"/"_DS
GOTO BPS
+10 IF S<140&(DS<90)
SET BGPN9=1
SET BGPV="BP: <140/90: BP: "_S_"/"_DS
BPS ;
+1 KILL ^TMP($JOB,"A")
+2 IF BGPV]""
SET BGPVALUE=BGPVALUE_";"_BGPV
+3 SET BGPVALUE="AD|||"_BGPVALUE
+4 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^BGP1D21(DFN,BGPBDATE,BGPEDATE,1)
+13 SET BGPN1=0
IF $PIECE(BGPVALUE,U)
SET BGPN1=1
+14 SET BGPVALUE=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPD2:";AD",1:"")_"|||"_$$DATE^BGP1UTL($PIECE(BGPVALUE,U,2))_" "_$PIECE(BGPVALUE,U,3)
+15 QUIT
BPCPT(P,BDATE,EDATE) ;EP
+1 NEW S,D,C,E,BGPG,X,Y,G,T
+2 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL VISIT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+3 ;go through and get all cpt codes in the 2 taxonomies and table by date using the lowest value on that day, skip ER visits
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;visit ien
SET V=$PIECE(BGPG(X),U,5)
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 ;clinic ER
IF $$CLINIC^APCLV(V,"C")=30
QUIT
+8 ;no cpt codes
IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+9 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AD",V,E))
IF E'=+E
QUIT
Begin DoDot:2
+10 SET C=$PIECE($GET(^AUPNVCPT(E,0)),U)
+11 IF 'C
QUIT
+12 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET D=(9999999-D)_"."_$PIECE(D,".",2)
+13 IF $$ICD^ATXCHK(C,$ORDER(^ATXAX("B","BGP SYSTOLIC BP CPTS",0)),1)
Begin DoDot:3
+14 SET Y=$PIECE($$CPT^ICPTCOD(C),U,2)
+15 IF '$DATA(S(D))
SET S(D)=Y
+16 IF +S(D)>+Y
SET S(D)=Y
End DoDot:3
+17 IF $$ICD^ATXCHK(C,$ORDER(^ATXAX("B","BGP DIASTOLIC BP CPTS",0)),1)
Begin DoDot:3
+18 SET Y=$PIECE($$CPT^ICPTCOD(C),U,2)
+19 IF '$DATA(T(D))
SET T(D)=Y
+20 IF +T(D)>+Y
SET T(D)=Y
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF '$DATA(S)
IF '$DATA(T)
QUIT ""
+22 SET S=$ORDER(S(0))
IF S
SET S=S(S)
+23 SET D=$ORDER(T(0))
IF D
SET D=T(D)
+24 IF S=""!(D="")
QUIT 0_U_0_U_S_"/"_$PIECE(D,".")
+25 IF S="3074F"
IF D="3078F"
QUIT 1_U_1_U_S_"/"_$PIECE(D,".")
+26 IF S="3074F"
IF D="3079F"
QUIT 0_U_1_U_S_"/"_$PIECE(D,".")
+27 IF S="3075F"
IF D="3078F"
QUIT 0_U_1_U_S_"/"_$PIECE(D,".")
+28 IF S="3075F"
IF D="3079F"
QUIT 0_U_1_U_S_"/"_$PIECE(D,".")
+29 IF S="3076F"
IF D="3078F"
QUIT 0_U_1_U_S_"/"_$PIECE(D,".")
+30 IF S="3076F"
IF D="3079F"
QUIT 0_U_1_U_S_"/"_$PIECE(D,".")
+31 IF S="3077F"
IF D="3080F"
QUIT 0_U_0_U_S_"/"_$PIECE(D,".")
+32 QUIT 0_U_0_U_S_"/"_$PIECE(D,".")
+33 QUIT ""
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^BGP1DU(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=$$TRAN^BGP1DU(P,BDATE,EDATE,T,6)
+9 IF $PIECE(BGPG,U)=1
QUIT "1^"_$PIECE(BGPG,U,2)_"^Ret Scr TRAN : "_$PIECE(BGPG,U,3)
+10 KILL BGPG
SET BGPG=$$LASTPRC^BGP1UTL1(P,"BGP HEDIS RETINAL SCRN PROCS",BDATE,EDATE)
+11 IF $PIECE(BGPG,U)=1
QUIT "1^"_$PIECE(BGPG,U,3)_"^Ret scr Proc: "_$PIECE(BGPG,U,2)
+12 KILL ^TMP($JOB,"A")
+13 SET A="^TMP($J,""A"","
+14 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+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)!(R=64)!(R="A2"))
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":2,1:2)_"^"_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 "2^"_D_"^Prv: "_R
+19 KILL BGPG
SET %=P_"^LAST DX V72.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+20 IF $DATA(BGPG(1))
QUIT "2^"_$PIECE(BGPG(1),U)_"V72.0 DX"
+21 ;now check for refusal of diabetic eye exam
+22 SET G=$$REFUSAL^BGP1UTL1(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
+23 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused"
+24 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
HGBA1C(P,BDATE,EDATE) ;EP
+1 NEW BGPG,BGPT,BGPC,E,%,L,T,BGPLT,D,X,J,C,G
+2 SET BGPC=0
+3 SET G=$$CPT^BGP1DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP HGBA1C CPTS",0)),5)
+4 IF G]""
SET BGPC=BGPC+1
SET BGPT((9999999-$PIECE(G,U,1)),BGPC)=U_"CPT "_$PIECE(G,U,2)
+5 ;now get all loinc/taxonomy tests
+6 SET T=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
+7 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+8 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)
QUIT
Begin DoDot:1
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPT(D,BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)_U_"LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC^BGP1D2(J,T)
QUIT
+16 SET BGPC=BGPC+1
SET BGPT(D,BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)_U_"LAB LOINC: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$PIECE(^AUPNVLAB(X,11),U,13)
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 ; now got though and set return value of done 1 or 0^numerator 2-7^date^value
+19 ;no tests so is hit in numerator
IF '$DATA(BGPT)
QUIT 0_U_1_U_0_U_"No documented HgbA1c"
+20 ; now get rid of all on same day where 1 has a result and the other doesn't
+21 KILL BGPC
SET D=0
FOR
SET D=$ORDER(BGPT(D))
IF D'=+D
QUIT
SET C=0
SET G=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C'=+C
QUIT
Begin DoDot:1
+22 ;=D_U_C
IF $PIECE(BGPT(D,C),U,1)]""
SET BGPC(D,C)=""
+23 ;I BGPC>0,$P(BGPT(D,C),U,1)="" K BGPT(D,C)
End DoDot:1
+24 IF $DATA(BGPC)
Begin DoDot:1
+25 ;loop through and get rid of all w/o results
+26 SET D=0
FOR
SET D=$ORDER(BGPT(D))
IF D=""
QUIT
Begin DoDot:2
+27 SET C=0
FOR
SET C=$ORDER(BGPT(D,C))
IF C=""
QUIT
Begin DoDot:3
+28 IF '$DATA(BGPC(D,C))
KILL BGPT(D,C)
End DoDot:3
End DoDot:2
End DoDot:1
+29 SET D=0
SET G=""
+30 SET D=$ORDER(BGPT(D))
+31 SET C=0
SET C=$ORDER(BGPT(D,C))
+32 SET X=$PIECE(BGPT(D,C),U,1)
+33 IF $$UP^XLFSTR(X)="COMMENT"
QUIT 1_U_1_U_0_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" (no result) "_X
+34 IF X=""
Begin DoDot:1
+35 SET G=""
+36 IF $PIECE(BGPT(D,C),U,2)="CPT 3046F"!($PIECE(BGPT(D,C),U,2)="CPT 83036")!($PIECE(BGPT(D,C),U,2)="CPT 83037")
SET G=1_U_1_U_0_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)
QUIT
+37 IF $PIECE(BGPT(D,C),U,2)="CPT 3047F"!($PIECE(BGPT(D,C),U,2)="CPT 3045F")
SET G=1_U_0_U_0_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)
QUIT
+38 IF $PIECE(BGPT(D,C),U,2)="CPT 3044F"
SET G=1_U_0_U_1_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)
QUIT
+39 SET G=1_U_1_U_0_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" (no result)"
QUIT
End DoDot:1
QUIT G
+40 ;strip spaces
SET X=$$STRIP^XLFSTR(X," ")
+41 IF X[">9"
QUIT 1_U_1_U_0_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" "_X
+42 SET X=$$STV^BGP1EO1(X)
+43 IF X=""
QUIT 1_U_1_U_0_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" (no result) "_X
+44 IF +X>9
QUIT 1_U_1_U_0_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" "_X
+45 IF +X<7
QUIT 1_U_0_U_1_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" "_X
+46 QUIT 1_U_0_U_0_U_$PIECE(BGPT(D,C),U,2)_" "_$$DATE^BGP1UTL(9999999-D)_" result: "_X
+47 ;
