- 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 ""