BGP7DHE2 ; IHS/CMI/LAB - measure HEDIS ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
POSUR(P,BDATE,EDATE) ;EP
K BGPC,BGPX,BGP1
S BGPC=""
S %="",E=+$$CODEN^ICPTCOD(82043),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(82044),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(83518),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(84166),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGP1(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(81050),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
I %]"",$G(BGP1) S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)_" and 84166"
;TRAN
S %="",E=+$$CODEN^ICPTCOD(82043),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(82044),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(83518),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(84166),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"" S BGP1(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(81050),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
I %]"",$G(BGP1) S BGPX(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$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 ""
BGP7DHE2 ; IHS/CMI/LAB - measure HEDIS ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
POSUR(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPX,BGP1
+2 SET BGPC=""
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(82043)
SET %=$$CPTI^BGP7DU(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^BGP7DU(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^BGP7DU(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^BGP7DU(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^BGP7DU(P,BDATE,EDATE,E)
+12 IF %]""
IF $GET(BGP1)
SET BGPX(9999999-$PIECE(%,U,2))="1^MICROALB-CPT^^"_$PIECE(%,U,2)_" and 84166"
+13 ;TRAN
+14 SET %=""
SET E=+$$CODEN^ICPTCOD(82043)
SET %=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
+15 IF %]""
SET BGPX(9999999-$PIECE(%,U,2))="1^MICROALB-TRAN^^"_$PIECE(%,U,2)
+16 SET %=""
SET E=+$$CODEN^ICPTCOD(82044)
SET %=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
+17 IF %]""
SET BGPX(9999999-$PIECE(%,U,2))="1^MICROALB-TRAN^^"_$PIECE(%,U,2)
+18 SET %=""
SET E=+$$CODEN^ICPTCOD(83518)
SET %=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
+19 IF %]""
SET BGPX(9999999-$PIECE(%,U,2))="1^MICROALB-TRAN^^"_$PIECE(%,U,2)
+20 SET %=""
SET E=+$$CODEN^ICPTCOD(84166)
SET %=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
+21 IF %]""
SET BGP1(9999999-$PIECE(%,U,2))="1^MICROALB-TRAN^^"_$PIECE(%,U,2)
+22 SET %=""
SET E=+$$CODEN^ICPTCOD(81050)
SET %=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
+23 IF %]""
IF $GET(BGP1)
SET BGPX(9999999-$PIECE(%,U,2))="1^MICROALB-TRAN^^"_$PIECE(%,U,2)_" and 84166"
+24 ;now get all loinc/taxonomy tests
+25 SET T=$ORDER(^ATXAX("B","BGP MICROALBUM LOINC CODES",0))
+26 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
+27 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
+28 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+30 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+31 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
+32 IF 'T
QUIT
+33 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+34 IF '$$LOINC(J,T)
QUIT
+35 SET (BGPC,BGPX(D))="1^MICROALB^^"_(9999999-D)
QUIT
+36 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;quit on the latest one found, if one found
IF $DATA(BGPX)
SET X=$ORDER(BGPX(0))
QUIT BGPX(X)
+38 ;
+39 SET T=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+40 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
+41 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
+42 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+43 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+44 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+45 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
+46 IF 'T
QUIT
+47 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+48 IF '$$LOINC(J,T)
QUIT
+49 SET (BGPC,BGPX(D))="1^A/C RATIO^^"_(9999999-D)
QUIT
+50 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+51 ;quit on the latest one found, if one found
IF $DATA(BGPX)
SET X=$ORDER(BGPX(0))
QUIT BGPX(X)
+52 ;
+53 KILL BGPG
SET %=P_"^LAST LAB [DM AUDIT URINE PROTEIN TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+54 SET (%,R)=""
IF $DATA(BGPG(1))
Begin DoDot:1
+55 SET %=$PIECE(^AUPNVLAB(+$PIECE(BGPG(1),U,4),0),U,4)
+56 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)
+57 SET T=$ORDER(^ATXAX("B","BGP URINE PROTEIN LOINC CODES",0))
+58 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
+59 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+60 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+61 IF 'T
QUIT
+62 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+63 IF '$$LOINC(J,T)
QUIT
+64 SET %=$PIECE(^AUPNVLAB(X,0),U,4)
+65 ;S R=$S(%="":"",%["+":1,%[">":1,$E(%)="P":1,$E(%)="p":1,$E(%)="c":"",$E(%)="C":"",+%>29:1,1:"")
+66 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:"")
+67 SET BGPC=R_"^U^"_%_"^"_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+68 QUIT BGPC
+69 ;;;
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 ""
