Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP7DHE2

BGP7DHE2.m

Go to the documentation of this file.
  1. BGP7DHE2 ; IHS/CMI/LAB - measure HEDIS ;
  1. ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
  1. ;
  1. POSUR(P,BDATE,EDATE) ;EP
  1. K BGPC,BGPX,BGP1
  1. S BGPC=""
  1. S %="",E=+$$CODEN^ICPTCOD(82043),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(82044),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(83518),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(84166),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGP1(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(81050),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"",$G(BGP1) S BGPX(9999999-$P(%,U,2))="1^MICROALB-CPT^^"_$P(%,U,2)_" and 84166"
  1. ;TRAN
  1. S %="",E=+$$CODEN^ICPTCOD(82043),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(82044),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(83518),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPX(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(84166),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGP1(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$P(%,U,2)
  1. S %="",E=+$$CODEN^ICPTCOD(81050),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"",$G(BGP1) S BGPX(9999999-$P(%,U,2))="1^MICROALB-TRAN^^"_$P(%,U,2)_" and 84166"
  1. ;now get all loinc/taxonomy tests
  1. S T=$O(^ATXAX("B","BGP MICROALBUM LOINC CODES",0))
  1. S BGPLT=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
  1. 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
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC(J,T)
  1. ...S (BGPC,BGPX(D))="1^MICROALB^^"_(9999999-D) Q
  1. ...Q
  1. I $D(BGPX) S X=$O(BGPX(0)) Q BGPX(X) ;quit on the latest one found, if one found
  1. ;
  1. S T=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
  1. S BGPLT=$O(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
  1. 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
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC(J,T)
  1. ...S (BGPC,BGPX(D))="1^A/C RATIO^^"_(9999999-D) Q
  1. ...Q
  1. I $D(BGPX) S X=$O(BGPX(0)) Q BGPX(X) ;quit on the latest one found, if one found
  1. ;
  1. K BGPG S %=P_"^LAST LAB [DM AUDIT URINE PROTEIN TAX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. S (%,R)="" I $D(BGPG(1)) D Q R_"^"_"U"_"^"_%_"^"_$P(BGPG(1),U)
  1. .S %=$P(^AUPNVLAB(+$P(BGPG(1),U,4),0),U,4)
  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:"")
  1. S T=$O(^ATXAX("B","BGP URINE PROTEIN LOINC CODES",0))
  1. 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
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC(J,T)
  1. ...S %=$P(^AUPNVLAB(X,0),U,4)
  1. ...;S R=$S(%="":"",%["+":1,%[">":1,$E(%)="P":1,$E(%)="p":1,$E(%)="c":"",$E(%)="C":"",+%>29:1,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:"")
  1. ...S BGPC=R_"^U^"_%_"^"_(9999999-D)
  1. Q BGPC
  1. ;;;
  1. LOINC(A,B) ;
  1. NEW %
  1. S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1. I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1. S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1. I $D(^ATXAX(B,21,"B",%)) Q 1
  1. Q ""