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

BDMD91H.m

Go to the documentation of this file. 
  1. BDMD91H ; IHS/CMI/LAB - 2009 DIABETES AUDIT ;
  1.  ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
  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 '$D(BDMNROK) 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
  1. 1 ;
  1.  K BDM S BDMC=0
  1.  S BDMOT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT A/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.  .;EVALUATE RESULT, if contains < or > strip that off and use the number
  1.  .S R=$P(BDM(D,C),U,2)
  1.  .I R["<"!(R[">") S R=$$STV^BDMD918(R,8) I R]"" S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$FMTE^XLFDT($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_1_U_R
  1.  .S R=$$STV^BDMD918(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)["<" S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$FMTE^XLFDT($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_1_U_5
  1.  ..I 'G S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$FMTE^XLFDT($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_1_U_R
  1.  .S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$FMTE^XLFDT($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_1_U_R
  1.  I G]"" Q G
  1. 2 ;
  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_$$FMTE^XLFDT($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="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_$$FMTE^XLFDT($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="BGP QUANT URINE PROT LOINC"
  1.  S BDMLT=$O(^ATXLAB("B","BGP QUANT 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_$$FMTE^XLFDT($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 URINE PROTEIN LOINC",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 %=$P(BDM(D,C),U,2)
  1.  .S %1=$S(%="":"No result ",%["+":"Yes ",%[">":"Yes ",$E(%)="P":"Yes ",$E(%)="p":"Yes ",$$UP^XLFSTR($E(%))="S":"Yes ",$$UP^XLFSTR($E(%))="M":"Yes ",$$UP^XLFSTR($E(%))="L":"Yes ",$E(%)="c":"No result ",$E(%)="C":"No result ",+%>29:"Yes ",1:"No ")
  1.  .Q:$E(%1)'="Y"
  1.  .S G="1  Yes  "_U_$P(BDM(D,C),U,2)_U_$$FMTE^XLFDT($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","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_$$FMTE^XLFDT($P(BDM(D,C),U))_U_$P(BDM(D,C),U,3)_U_6
  1.  I G]"" Q G
  1. R ;
  1.  S G=0
  1.  S T=$O(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
  1.  S X=0 F  S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G)  I $$REFUSAL^BDMD917(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
  1.  I G Q "3  Refused"
  1.  S G=0
  1.  S T=$O(^ATXLAB("B","BGP QUANT URINE PROTEIN",0))
  1.  S X=0 F  S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G)  I $$REFUSAL^BDMD917(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
  1.  I G Q "3  Refused"
  1.  S G=0
  1.  S T=$O(^ATXLAB("B","DM AUDIT SEMI QUANT UACR",0))
  1.  S X=0 F  S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G)  I $$REFUSAL^BDMD917(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
  1.  I G Q "3  Refused"
  1.  S G=0
  1.  S T=$O(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
  1.  S X=0 F  S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G)  I $$REFUSAL^BDMD917(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
  1.  I G Q "3  Refused"
  1.  S G=0
  1.  S T=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
  1.  S X=0 F  S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G)  I $$REFUSAL^BDMD917(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
  1.  I G Q "3  Refused"
  1.  Q "2  No"