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

APCLD81D.m

Go to the documentation of this file. 
  1. APCLD81D ; IHS/CMI/LAB - APCL Continuation of APCLD81C 1/11/2008 1:54:57 PM ; 
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1.  ;
  1.  ;
  1. MICRO ;EP
  1.  NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
  1.  K APCL S APCLC=0
  1.  S APCLOT=$O(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
  1.  S APCLLT=$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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
  1.  ...Q:'APCLOT
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,APCLOT)
  1.  ...D SETV
  1.  ...Q
  1.  I '$D(APCL(1)) S %1="" D ACRATIOM^APCLD81C Q %1
  1.  D SETN
  1.  NEW % S %=$P(^AUPNVLAB(+$P(APCL(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(APCL(N),U),"5")_" "_$P(APCL(N),U,3)
  1. HGBA1C ;EP
  1.  NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
  1.  K APCL
  1.  S APCLC=0
  1.  S APCLOT=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
  1.  S APCLLT=$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.  ...I APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
  1.  ...Q:'APCLOT
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,APCLOT)
  1.  ...D SETV
  1.  ...Q
  1.  D SET3
  1.  K X S (%,C,R)="" F  S %=$O(APCL(%)) Q:%'=+%!(C>1)  S X(9999999-$P(APCL(%),U),1)=$P(^AUPNVLAB(+$P(APCL(%),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.  Q R
  1. BS ;EP
  1.  NEW APCL,X,%,E,R,V,C
  1.  K APCL
  1.  S %=P_"^LAST 200 LAB [DM AUDIT GLUCOSE TESTS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
  1.  I '$D(APCL(1)) Q ""
  1.  D SET3
  1.  S (%,C,R)="" F  S %=$O(APCL(%)) Q:%=""!(C>2)  S R=R_$P(^AUPNVLAB(+$P(APCL(%),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(%),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(APCL(%),U))_"^",C=C+1
  1.  Q R
  1.  ;
  1. FGLUCOSE ;EP
  1.  I $G(F)="" S F="E"
  1.  NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
  1.  K APCL
  1.  S APCLC=0
  1.  S APCLOT=$O(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
  1.  S APCLLT=$O(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",0))
  1.  D GATHER
  1.  I '$D(APCL(1)) Q ""
  1.  D SETN
  1.  I F="I" Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_"^"_$P(APCL(N),U)
  1.  Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(APCL(N),U),5)
  1. G75 ;EP
  1.  I $G(F)="" S F="E"
  1.  NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
  1.  K APCL
  1.  S APCLC=0
  1.  S APCLOT=$O(^ATXAX("B","DM AUDIT 75GM 2HR LOINC",0))
  1.  S APCLLT=$O(^ATXLAB("B","DM AUDIT 75GM 2HR GLUCOSE",0))
  1.  D GATHER
  1.  I '$D(APCL(1)) Q ""
  1.  D SETN
  1.  I F="I" Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_"^"_$P(APCL(N),U)
  1.  Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(APCL(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(APCL))  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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
  1.  ...Q:'APCLOT
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,APCLOT)
  1.  ...D SETV
  1.  ...Q
  1.  I '$D(APCL(1)) Q
  1.  S D=$P(APCL(1),U),D=9999999-D
  1.  K APCL S APCLC=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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
  1.  ..Q:'APCLOT
  1.  ..S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ..Q:'$$LOINC(J,APCLOT)
  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 APCLC=APCLC+1
  1.  S V=$P(^AUPNVLAB(X,0),U,3),APCLV=$P($P($G(^AUPNVSIT(V,0)),U),".") Q:'APCLV
  1.  S APCL(APCLC)=APCLV_"^"_$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(APCL(A)) Q:A'=+A!(G)  S R=$P(^AUPNVLAB(+$P(APCL(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(APCL(X)) Q:X'=+X  S A($P(APCL(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(APCL(N),U,4),0),U,4)]"",$$UP^XLFSTR($P(^AUPNVLAB(+$P(APCL(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(APCL(N),U,4),0),U,4)="" K APCL(N)
  1.  .Q
  1.  Q