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

BDMDG1H.m

Go to the documentation of this file. 
  1. BDMDG1H ; IHS/CMI/LAB - 2019 DIABETES AUDIT 15 Dec 2016 3:06 PM ; 
  1.  ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
  1.  ;
  1. GATHER ;
  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)!($D(BDM))  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...;Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
  1.  ...I '$G(BDMACRA) Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["COMMENT"
  1.  ...Q:$P(^AUPNVLAB(X,0),U,4)=""
  1.  ...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETO Q
  1.  ...Q:'BDMOT
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,BDMOT)
  1.  ...D SETO
  1.  ...Q
  1.  Q
  1. LOINC(A,B) ;EP - is loinc code A in taxonomy B
  1.  NEW %
  1.  I '$G(B) Q ""
  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 ""
  1. SETO ;
  1.  S BDMC=BDMC+1
  1.  S V=$P(^AUPNVLAB(X,0),U,3),BDMV=$P($P($G(^AUPNVSIT(V,0)),U),".") Q:'BDMV
  1.  S BDM(9999999-BDMV,BDMC)=BDMV_"^"_$S($P(^AUPNVLAB(X,0),U,4)]"":$P(^AUPNVLAB(X,0),U,4),1:"")_"^"_$$VAL^XBDIQ1(9000010.09,X,.01)_"^"_X_";AUPNVLAB^"_V
  1.  Q
  1. SETV ;
  1.  S BDMC=BDMC+1
  1.  S V=$P(^AUPNVLAB(X,0),U,3),BDMV=$P($P($G(^AUPNVSIT(V,0)),U),".") Q:'BDMV
  1.  S BDM(BDMC)=BDMV_"^"_$S($P(^AUPNVLAB(X,0),U,4)]"":$P(^AUPNVLAB(X,0),U,4),1:"")_"^"_$$VAL^XBDIQ1(9000010.09,X,.01)_"^"_X_";AUPNVLAB^"_V
  1.  Q
  1. SETN ;
  1.  S N="" NEW A,G,BDMR,D
  1.  S A=0 F  S A=$O(BDM(A)) Q:A'=+A  S BDMR(9999999-$P(BDM(A),U,1),A)=BDM(A)
  1.  S (A,D,G)=0 F  S D=$O(BDMR(D)) Q:D'=+D!(G)  D
  1.  .S A=0 F  S A=$O(BDMR(D,A)) Q:A'=+A!(G)  D
  1.  ..S R=$P(^AUPNVLAB(+$P(BDM(A),U,4),0),U,4) I R]"",$$UP^XLFSTR(R)'="COMMENT" S G=A
  1.  S N=$S(G:G,1:1)
  1.  Q
  1. SET3 ;
  1.  NEW X,N1,N2,N3,A,T
  1.  K A
  1.  S X=0 F  S X=$O(BDM(X)) Q:X'=+X  S A($P(BDM(X),U),X)=""
  1.  NEW D S D=0 F  S D=$O(A(D)) Q:D'=+D  D
  1.  .S G=0,N=0 F  S N=$O(A(D,N)) Q:N'=+N  D
  1.  ..I $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"",$$UP^XLFSTR($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4))'="COMMENT" S G=1 Q
  1.  .I G S N=0 F  S N=$O(A(D,N)) Q:N'=+N  I $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)="" K BDM(N)
  1.  .Q
  1.  Q
  1.  ;
  1. URIN ;EP
  1.  NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,G,C,BDMNROK,T,N,BDMACRA
  1. 1 ;
  1.  K BDM S BDMC=0,BDMACRA=1
  1.  S BDMOT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT QUANT UACR",0))
  1.  D GATHER
  1.  S D=0,C=0,G="" F  S D=$O(BDM(D)) Q:D'=+D!(G]"")  S C=0 F  S C=$O(BDM(D,C)) Q:C'=+C!(G]"")  D
  1.  .;EVALUATE RESULT, if contains < or > strip that off and use the number
  1.  .S R=$P(BDM(D,C),U,2)
  1.  .I $E(R)=">" S R=999
  1.  .S R=$$STV^BDMDG18(R,8) I R]"" S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_1_U_R,$P(G,U,12)=$$VAL^XBDIQ1(9000010.09,+$P(BDM(D,C),U,4),1101)
  1.  .;S R=$$STV^BDMDG18(R,8)
  1.  .I R="" D  Q
  1.  ..S (E,X,J,L)=""
  1.  ..S BDMOT=$O(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
  1.  ..S BDMLT=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
  1.  ..S V=$P(BDM(D,C),U,5) S X=0 F  S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X!(G)  D
  1.  ...S L=$P($G(^AUPNVLAB(X,0)),U,1)
  1.  ...Q:L=""
  1.  ...S E=""
  1.  ...I BDMLT,$D(^ATXLAB(BDMLT,21,"B",L)) S E=1
  1.  ...I 'E,BDMOT S J=$P($G(^AUPNVLAB(X,11)),U,13) I J]"",$$LOINC(J,BDMOT) S E=1
  1.  ...Q:'E
  1.  ...I $P(^AUPNVLAB(X,0),U,4)["<"!($$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["LESS") S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_1_U_5
  1.  ...I $P(^AUPNVLAB(X,0),U,4)[">"!($$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["GREATER") S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_1_U_999
  1.  ..I 'G S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_1_U_R,$P(G,U,12)=$$VAL^XBDIQ1(9000010.09,+$P(BDM(D,C),U,4),1101)
  1.  .S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_1_U_R,$P(G,U,12)=$$VAL^XBDIQ1(9000010.09,+$P(BDM(D,C),U,4),1101)
  1.  Q G
  1.  ;OLD STUFF
  1.  I G]"" Q G
  1.  K BDMACRA
  1. 2 ;
  1.  K BDM
  1.  S BDMC=0
  1.  S BDMOT="DM AUDIT P/C RATIO LOINC"
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0))
  1.  D GATHER
  1.  S D=0,C=0,G="" F  S D=$O(BDM(D)) Q:D'=+D!(G]"")  S C=0 F  S C=$O(BDM(D,C)) Q:C'=+C!(G]"")  D
  1.  .S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_2
  1.  I G]"" Q G
  1. 3 ;
  1.  K BDM
  1.  S BDMC=0
  1.  S BDMOT=""
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT 24HR URINE PROTEIN",0))
  1.  D GATHER
  1.  S D=0,C=0,G="" F  S D=$O(BDM(D)) Q:D'=+D!(G]"")  S C=0 F  S C=$O(BDM(D,C)) Q:C'=+C!(G]"")  D
  1.  .S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_3
  1.  I G]"" Q G
  1. 4 ;
  1.  K BDM
  1.  S BDMC=0
  1.  S BDMOT=""
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT SEMI QUANT UACR",0))
  1.  D GATHER
  1.  S D=0,C=0,G="" F  S D=$O(BDM(D)) Q:D'=+D!(G]"")  S C=0 F  S C=$O(BDM(D,C)) Q:C'=+C!(G]"")  D
  1.  .S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_4
  1.  I G]"" Q G
  1. 5 ;
  1.  K BDM
  1.  S BDMC=0
  1.  S BDMOT=$O(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
  1.  D GATHER
  1.  S D=0,C=0,G="" F  S D=$O(BDM(D)) Q:D'=+D!(G]"")  S C=0 F  S C=$O(BDM(D,C)) Q:C'=+C!(G]"")  D
  1.  .S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_5
  1.  I G]"" Q G
  1. 6 ;
  1.  K BDM
  1.  S BDMC=0
  1.  S BDMOT=$O(^ATXAX("B","BGP URINE PROTEIN LOINC CODES",0))
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
  1.  D GATHER
  1.  S D=0,C=0,G="" F  S D=$O(BDM(D)) Q:D'=+D!(G]"")  S C=0 F  S C=$O(BDM(D,C)) Q:C'=+C!(G]"")  D
  1.  .S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$DATE^BDMS9B1($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_6
  1.  I G]"" Q G
  1.  Q "2  No"
  1. SEMIE(V) ;EP - called from epi
  1.  I V="" Q ""
  1.  I V["-" Q 2
  1.  I V["300" Q 3
  1.  I V[">" Q 3
  1.  I V["<" Q 1
  1.  S V=$$STV^BDMDG18(V,5,1)
  1.  S V=+V
  1.  I 'V Q ""
  1.  I +V>299.99 Q 3
  1.  I +V>29.9999,+V<299.9999 Q 2
  1.  I +V<30 Q 1
  1.  Q ""
  1. UPE(%) ;EP - called from epi
  1.  I %="" Q ""
  1.  I %["+" Q 2
  1.  I %[">" Q 2
  1.  I $E(%)="P" Q 2
  1.  I $E(%)="p" Q 2
  1.  I $E($$UP^XLFSTR(%))="S" Q 2
  1.  I $E($$UP^XLFSTR(%))="M" Q 2
  1.  I $E($$UP^XLFSTR(%))="L" Q 2
  1.  I +%>29 Q 2
  1.  Q 1