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

BDMDA1D.m

Go to the documentation of this file. 
  1. BDMDA1D ; IHS/CMI/LAB - BDM Continuation of BDMDA1C 1/11/2013 1:54:57 PM ;
  1.  ;;2.0;DIABETES MANAGEMENT SYSTEM;**6**;JUN 14, 2007;Build 6
  1.  ;
  1.  ;
  1.  ;
  1. MICRO ;EP
  1.  NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
  1.  K BDM 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.  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
  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.  ...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
  1.  ...Q:'BDMOT
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,BDMOT)
  1.  ...D SETV
  1.  ...Q
  1.  I '$D(BDM(1)) S %1="" D ACRATIOM^BDMDA1C Q %1
  1.  D SETN
  1.  NEW % S %=$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)
  1.  S %1=$S(%="":"No result",%["+":"Pos ",%[">":"Pos ",$E(%)="P":"Pos ",$E(%)="p":"Pos ",$E(%)="c":"No result ",$E(%)="C":"No result ",+%>29:"Pos ",1:"Neg ")
  1.  Q %1_%_" "_$$FMTE^XLFDT($P(BDM(N),U),"5")_" "_$P(BDM(N),U,3)
  1. HGBA1C ;EP
  1.  NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,G
  1.  K BDM
  1.  S BDMC=0
  1.  S BDMOT=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT HGB A1C 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)  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:$P(^AUPNVLAB(X,0),U,4)=""  ;no result
  1.  ...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
  1.  ...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["COMMENT"
  1.  ...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
  1.  ...Q:'BDMOT
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,BDMOT)
  1.  ...D SETV
  1.  ...Q
  1.  D SET3
  1.  ;K X S (%,C,R)="" F  S %=$O(BDM(%)) Q:%'=+%!(C>1)  S C=C+1,X(9999999-$P(BDM(%),U),C)=$P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)
  1.  ;S %=0,R="" F  S %=$O(X(%)) Q:%=""  S V=0 F  S V=$O(X(%,V)) Q:V=""  S R=R_X(%,V)_"^"_$$FMTE^XLFDT(9999999-%)_"^"_(9999999-%)_"^"
  1.  ;separate those with a result and those without a result
  1.  ;first put in reverse date order
  1.  S (N,C,R)=""
  1.  K BDMR
  1.  F  S N=$O(BDM(N)) Q:N'=+N  D
  1.  .S D=$P(BDM(N),U)
  1.  .S R=$P(BDM(N),U,2) I R="?" S R=""
  1.  .I R]"" S BDMR("R",(9999999-D),N)=BDM(N)
  1.  .I R="" S BDMR("NR",(9999999-D),N)=BDM(N)
  1.  S R=""
  1.  S D=0 F  S D=$O(BDMR("R",D)) Q:D'=+D!(R]"")  D
  1.  .S N=0 F  S N=$O(BDMR("R",D,N)) Q:N'=+N!(R]"")  D
  1.  ..S R=BDMR("R",D,N)
  1.  I R]"" Q R
  1.  S D=0 F  S D=$O(BDMR("NR",D)) Q:D'=+D!(R]"")  D
  1.  .S N=0 F  S N=$O(BDMR("NR",D,N)) Q:N'=+N!(R]"")  D
  1.  ..S R=BDMR("NR",D,N)
  1.  Q R
  1. BS ;EP
  1.  NEW BDM,X,%,E,R,V,C
  1.  K BDM
  1.  S %=P_"^LAST 200 LAB [DM AUDIT GLUCOSE TESTS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
  1.  I '$D(BDM(1)) Q ""
  1.  D SET3
  1.  S (%,C,R)="" F  S %=$O(BDM(%)) Q:%=""!(C>2)  S R=R_$P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(%),U))_"^",C=C+1
  1.  Q R
  1.  ;
  1. FGLUCOSE ;EP
  1.  I $G(F)="" S F="E"
  1.  NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
  1.  K BDM
  1.  S BDMC=0
  1.  S BDMOT=$O(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",0))
  1.  D GATHER
  1.  I '$D(BDM(1)) Q ""
  1.  D SETN
  1.  I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
  1.  Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(N),U),5)
  1. G75 ;EP
  1.  I $G(F)="" S F="E"
  1.  NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
  1.  K BDM
  1.  S BDMC=0
  1.  S BDMOT=$O(^ATXAX("B","DM AUDIT 75GM 2HR LOINC",0))
  1.  S BDMLT=$O(^ATXLAB("B","DM AUDIT 75GM 2HR GLUCOSE",0))
  1.  D GATHER
  1.  I '$D(BDM(1)) Q ""
  1.  D SETN
  1.  I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
  1.  Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(N),U),5)
  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.  ...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
  1.  ...Q:'BDMOT
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,BDMOT)
  1.  ...D SETV
  1.  ...Q
  1.  I '$D(BDM(1)) Q
  1.  S D=$P(BDM(1),U),D=9999999-D
  1.  K BDM S BDMC=0
  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.  ..I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
  1.  ..Q:'BDMOT
  1.  ..S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ..Q:'$$LOINC(J,BDMOT)
  1.  ..D SETV
  1.  ..Q
  1.  Q
  1. LOINC(A,B) ;EP - is loinc code A in taxonomy 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 ""
  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 S (A,G)=0 F  S A=$O(BDM(A)) Q:A'=+A!(G)  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,G,N
  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