BDMDG1C ; IHS/CMI/LAB - 2019 DIABETES AUDIT 09 Nov 2015 11:34 AM ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
;
GATHER ;
NEW R,B,E,D,L
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
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["COMMENT"
...Q:$P(^AUPNVLAB(X,0),U,4)="" ;no result
...;STRIP ALL NON-NUMERICS AND "."
...S R=$P(^AUPNVLAB(X,0),U,4),R=$$STV^BDMDG18(R,8,1) I R="" Q ;no numeric result
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
Q ;do not look for tests with no result per Ray Shields.
;
LOINC(A,B) ;EP - is loinc code A in taxonomy B
NEW %
I '$G(B) Q ""
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
SETV ;
S BDMC=BDMC+1
S V=$P(^AUPNVLAB(X,0),U,3),BDMV=$P($P($G(^AUPNVSIT(V,0)),U),".") Q:'BDMV
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
Q
SETN ;
S N="" NEW A,G,BDMR,D
S A=0 F S A=$O(BDM(A)) Q:A'=+A S BDMR(9999999-$P(BDM(A),U,1),A)=BDM(A)
S (A,D,G)=0 F S D=$O(BDMR(D)) Q:D'=+D!(G) D
.S A=0 F S A=$O(BDMR(D,A)) Q:A'=+A!(G) D
..S R=$P(^AUPNVLAB(+$P(BDM(A),U,4),0),U,4) I R]"",$$UP^XLFSTR(R)'="COMMENT",$$UP^XLFSTR(R)'="N/A" S G=A
S N=$S(G:G,1:1)
Q
SET3 ;
NEW X,N1,N2,N3,A,T
K A
S X=0 F S X=$O(BDM(X)) Q:X'=+X S A($P(BDM(X),U),X)=""
NEW D S D=0 F S D=$O(A(D)) Q:D'=+D D
.S G=0,N=0 F S N=$O(A(D,N)) Q:N'=+N D
..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
.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)
.Q
Q
GFR(P,BDATE,EDATE,NOCALC) ;EP - Estimated GFR
I $$AGE^AUPNPAT(P,EDATE)<18 Q ""
S NOCALC=$G(NOCALC)
NEW BDM,BDMC,BDMOT,BDMLT,B,E,D,L,X,Y
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
S BDMLT=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
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
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)="" ;dm2014 display value only
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["COMMENT"
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
I '$D(BDM(1)),NOCALC Q ""
I '$D(BDM(1)),'NOCALC S X=$$CALCGFR^BDMDG18(P,BDATE,EDATE) D Q X
.I X="" Q
.S X=1_U_$P(X,U,2)_U_$$DATE^BDMS9B1($P(X,U,1))_U_$P(X,U,3)_U_$P(X,U,1)
D SETN
Q 1_U_$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_U_$$DATE^BDMS9B1($P(BDM(N),U))_U_$E($P(BDM(N),U,3),1,25)_U_$P(BDM(N),U)
CREAT ;EP
I $G(F)="" S F="E"
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","BGP CREATININE LOINC CODES",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
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:"")_U_$$DATE^BDMS9B1($P(BDM(N),U))_U_$E($P(BDM(N),U,3),1,25)
CHOL ;EP
S:$G(F)="" F="E"
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
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:"")_U_$$DATE^BDMS9B1($P(BDM(N),U))_U_$E($P(BDM(N),U,3),1,25)
LPROF ;
K BDM,BDMX S BDMX=""
Q ;no longer count lipid profile because there is no result 2014 per Ray.
S %=P_"^LAST LAB [DM AUDIT LIPID PROFILE TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I '$D(BDM(1)) Q
I F="I" S BDMX=$P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_"^"_$P(BDM(1),U) Q
S BDMX=$P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)]"":" mg/dl",1:"")_$$DATE^BDMS9B1($P(BDM(1),U))
Q
HDL ;EP
I $G(F)="" S F="E"
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","BGP HDL LOINC CODES",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT HDL TAX",0))
D GATHER
I '$D(BDM(1)) K BDM,BDMX S BDMX="" D LPROF Q BDMX
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
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:"")_U_$$DATE^BDMS9B1($P(BDM(N),U))_U_$E($P(BDM(N),U,3),1,25)
LDL ;EP
I $G(F)="" S F="E"
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,BDMLDL,G
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
D GATHER
I '$D(BDM(1)) K BDM,BDMX S BDMX="" D LPROF Q BDMX
K BDMLDL S X=0 F S X=$O(BDM(X)) Q:X'=+X S BDMLDL(9999999-$P(BDM(X),U),X)=BDM(X)
S X=0,G=0 F S X=$O(BDMLDL(X)) Q:X'=+X!G S Y=0 F S Y=$O(BDMLDL(X,Y)) Q:Y'=+Y!(G) I +$P(^AUPNVLAB(+$P(BDMLDL(X,Y),U,4),0),U,4) S G=Y
I 'G S X=$O(BDMLDL(0)),G=$O(BDMLDL(X,0))
;NEW N D SETN
I F="I" Q $P(^AUPNVLAB(+$P(BDM(G),U,4),0),U,4)_"^"_$P(BDM(G),U)
Q $P(^AUPNVLAB(+$P(BDM(G),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(G),U,4),0),U,4)]"":" mg/dl ",1:"")_U_$$DATE^BDMS9B1($P(BDM(G),U))_U_$E($P(BDM(G),U,3),1,25)
TRIG ;EP
I $G(F)="" S F="E"
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
D GATHER
I '$D(BDM(1)) K BDM,BDMX S BDMX="" D LPROF Q BDMX
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
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:"")_U_$$DATE^BDMS9B1($P(BDM(N),U))_U_$E($P(BDM(N),U,3),1,25)
UACR(P,BDATE,EDATE) ;EP - albumin/creatinine ration UACR
NEW BDM,BDMC,BDMOT,BDMLT
K BDM S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT QUANT UACR",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I $D(BDM(N)) Q "X^"_$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($P(BDM(N),U,1))_U_$E($P(BDM(N),U,3),1,30)
Q ""
;
SEMI(P,BDATE,EDATE) ;EP - albumin/creatinine ration UACR
NEW BDM,BDMC,BDMOT,BDMLT
K BDM S BDMC=0
S BDMOT=""
S BDMLT=$O(^ATXLAB("B","DM AUDIT SEMI QUANT UACR",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I $D(BDM(1)) Q "X^"_$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($P(BDM(N),U,1))_U_$E($P(BDM(N),U,3),1,30)
Q ""
;
UPCR(P,BDATE,EDATE) ;EP - protein/creatinine ratio UPCR
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT P/C RATIO LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I $D(BDM(1)) Q "X^"_$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($P(BDM(N),U,1))_U_$E($P(BDM(N),U,3),1,30)
Q ""
;
QUAN(P,BDATE,EDATE) ;EP - other quantitative urine protein test
NEW BDM,BDMC
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","BGP QUANT URINE PROT LOINC",0))
S BDMLT=$O(^ATXLAB("B","BGP QUANT URINE PROTEIN",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I $D(BDM(1)) Q "X^"_$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($P(BDM(N),U,1))_U_$E($P(BDM(N),U,3),1,30)
Q ""
;
PROTEIN ;EP
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,%1
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
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
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
I '$D(BDM(1)) S %1="" Q %1
D SETN
NEW %,%1 S %=$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)
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 ")
Q $S($E(%1)="Y":"X",1:"")_"^"_%_"^"_$$DATE^BDMS9B1($P(BDM(N),U,1))_U_$P(BDM(N),U,3)
ACRATIO ;EP
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT QUANT UACR",0))
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
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
I '$D(BDM) S %1="" Q
D SETN
NEW % S %=$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)
S %1=$S(%="":"No result",%[">":"Yes ",$E(%)="c":"No result ",$E(%)="C":"No result ",+%>299:"Yes ",1:"No ")
S %1=%1_" "_%_"^ "_$P(BDM(N),U,3)_" "_$$DATE^BDMS9B1($P(BDM(N),U,1))
Q
ACRATIOM ;EP
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT QUANT UACR",0))
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
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
I '$D(BDM) S %1="" Q
D SETN
NEW % S %=$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)
S %1=$S(%="":"No result",%="30-300":"Pos ",$E(%)="c":"No result ",$E(%)="C":"No result ",+%>29&(+%<300):"Pos ",1:"No ")
S %1=%1_" "_%_" "_$$DATE^BDMS9B1($P(BDM(N),U),"5")_" "_$P(BDM(N),U,3)
Q
;
MICRO(P,BDATE,EDATE) ;EP - other quantitative urine protein test
NEW BDM,BDMOT,BDMC,BDMLT
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I $D(BDM(1)) Q "X^"_$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($P(BDM(N),U,1))_U_$P(BDM(N),U,3)
Q ""
COMBINED(P,BDMBDAT,BDMADAT,BDM6MBD) ;EP
NEW A1C,LDL,BP,ALL,G,V,S,D,STATIN,BDMRBD,BDMRED ;ADDED FOR ICARE 12/06/17
S BDMRBD=$$FMTE^XLFDT(BDMBDAT) ;ADDED FOR ICARE 12/06/17
S BDMRED=$$FMTE^XLFDT(BDMADAT) ;ADDED FOR ICARE 12/06/17
S G=0,ALL=""
;S A1C=$P(^XTMP("BDMDM19",BDMJOB,BDMBTH,"AUDIT",P,78),U,2)
S A1C=$P($$HGBA1C^BDMDG18(BDMPD,BDMBDAT,BDMADAT),U,2)
S V=A1C
S ALL="A1C: "_$S(A1C]"":A1C,1:"<Not Documented>")
I V=""!(V="?") S G=0 G CSTAT
I V["<" S G=G+1 G CSTAT
I V[">" S G=G+0 G CSTAT
S V=$$STV^BDMDG18(V,5)
I V="" S G=G+0 G CSTAT
S V=+V
S S=$S(V="":0,V<8.0:1,1:0)
S G=G+S
CSTAT ;
;S STATIN=+^XTMP("BDMDM19",BDMJOB,BDMBTH,"AUDIT",P,300)
S STATIN=+$$STATIN^BDMDG16(BDMPD,BDM6MBD,BDMADAT)
S ALL=ALL_"; statin prescribed: "_$S(STATIN=1:"Yes",1:"No")
I STATIN=1 S G=G+1
BP ;
S S=$$SYSMEAN^BDMDG15(P,BDMRBD,BDMRED)
S D=$$DIAMEAN^BDMDG15(P,BDMRBD,BDMRED)
D
.I S=""!(D="") Q
.I S<140&(D<90) S G=G+1 Q
S ALL=ALL_"; Mean BP: "_$S(S:S_"/"_D,1:"")
I G=3 Q "1 Yes "_ALL
Q "2 No "_ALL
EGFRUACR(P,BD,ED,F) ;EP -
I $$AGE^AUPNPAT(P,BDMADAT)<18 Q "" ;ONLY 18 AND OVER
S F=$G(F)
NEW G,R
S G=$$GFR^BDMDG1C(BDMPD,BD,ED)
S R=$$URIN^BDMDG18(BDMPD,BD,ED)
I $E(G),$E(R) Q $S(F:1,1:"Yes")
Q $S(F:0,1:"No")
BDMDG1C ; IHS/CMI/LAB - 2019 DIABETES AUDIT 09 Nov 2015 11:34 AM ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
+2 ;
GATHER ;
+1 NEW R,B,E,D,L
+2 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+3 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+5 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+6 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+7 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["COMMENT"
QUIT
+8 ;no result
IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+9 ;STRIP ALL NON-NUMERICS AND "."
+10 ;no numeric result
SET R=$PIECE(^AUPNVLAB(X,0),U,4)
SET R=$$STV^BDMDG18(R,8,1)
IF R=""
QUIT
+11 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+12 IF 'BDMOT
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,BDMOT)
QUIT
+15 DO SETV
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;do not look for tests with no result per Ray Shields.
QUIT
+18 ;
LOINC(A,B) ;EP - is loinc code A in taxonomy B
+1 NEW %
+2 IF '$GET(B)
QUIT ""
+3 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+4 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+5 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+6 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+7 QUIT ""
SETV ;
+1 SET BDMC=BDMC+1
+2 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
SET BDMV=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
IF 'BDMV
QUIT
+3 SET BDM(BDMC)=BDMV_"^"_$SELECT($PIECE(^AUPNVLAB(X,0),U,4)]"":$PIECE(^AUPNVLAB(X,0),U,4),1:"")_"^"_$$VAL^XBDIQ1(9000010.09,X,.01)_"^"_X_";AUPNVLAB^"_V
+4 QUIT
SETN ;
+1 SET N=""
NEW A,G,BDMR,D
+2 SET A=0
FOR
SET A=$ORDER(BDM(A))
IF A'=+A
QUIT
SET BDMR(9999999-$PIECE(BDM(A),U,1),A)=BDM(A)
+3 SET (A,D,G)=0
FOR
SET D=$ORDER(BDMR(D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+4 SET A=0
FOR
SET A=$ORDER(BDMR(D,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+5 SET R=$PIECE(^AUPNVLAB(+$PIECE(BDM(A),U,4),0),U,4)
IF R]""
IF $$UP^XLFSTR(R)'="COMMENT"
IF $$UP^XLFSTR(R)'="N/A"
SET G=A
End DoDot:2
End DoDot:1
+6 SET N=$SELECT(G:G,1:1)
+7 QUIT
SET3 ;
+1 NEW X,N1,N2,N3,A,T
+2 KILL A
+3 SET X=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X
QUIT
SET A($PIECE(BDM(X),U),X)=""
+4 NEW D
SET D=0
FOR
SET D=$ORDER(A(D))
IF D'=+D
QUIT
Begin DoDot:1
+5 SET G=0
SET N=0
FOR
SET N=$ORDER(A(D,N))
IF N'=+N
QUIT
Begin DoDot:2
+6 IF $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]""
IF $$UP^XLFSTR($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4))'="COMMENT"
SET G=1
QUIT
End DoDot:2
+7 IF G
SET N=0
FOR
SET N=$ORDER(A(D,N))
IF N'=+N
QUIT
IF $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)=""
KILL BDM(N)
+8 QUIT
End DoDot:1
+9 QUIT
GFR(P,BDATE,EDATE,NOCALC) ;EP - Estimated GFR
+1 IF $$AGE^AUPNPAT(P,EDATE)<18
QUIT ""
+2 SET NOCALC=$GET(NOCALC)
+3 NEW BDM,BDMC,BDMOT,BDMLT,B,E,D,L,X,Y
+4 KILL BDM
+5 SET BDMC=0
+6 SET BDMOT=$ORDER(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
+7 SET BDMLT=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
+8 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 ;dm2014 display value only
IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+13 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+14 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["COMMENT"
QUIT
+15 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+16 IF 'BDMOT
QUIT
+17 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+18 IF '$$LOINC(J,BDMOT)
QUIT
+19 DO SETV
+20 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF '$DATA(BDM(1))
IF NOCALC
QUIT ""
+22 IF '$DATA(BDM(1))
IF 'NOCALC
SET X=$$CALCGFR^BDMDG18(P,BDATE,EDATE)
Begin DoDot:1
+23 IF X=""
QUIT
+24 SET X=1_U_$PIECE(X,U,2)_U_$$DATE^BDMS9B1($PIECE(X,U,1))_U_$PIECE(X,U,3)_U_$PIECE(X,U,1)
End DoDot:1
QUIT X
+25 DO SETN
+26 QUIT 1_U_$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_U_$$DATE^BDMS9B1($PIECE(BDM(N),U))_U_$EXTRACT($PIECE(BDM(N),U,3),1,25)_U_$PIECE(BDM(N),U)
CREAT ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+3 KILL BDM
+4 SET BDMC=0
+5 SET BDMOT=$ORDER(^ATXAX("B","BGP CREATININE LOINC CODES",0))
+6 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
+7 DO GATHER
+8 IF '$DATA(BDM(1))
QUIT ""
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_"^"_$PIECE(BDM(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(N),U))_U_$EXTRACT($PIECE(BDM(N),U,3),1,25)
CHOL ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+3 KILL BDM
+4 SET BDMC=0
+5 SET BDMOT=$ORDER(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
+6 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
+7 DO GATHER
+8 IF '$DATA(BDM(1))
QUIT ""
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_"^"_$PIECE(BDM(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(N),U))_U_$EXTRACT($PIECE(BDM(N),U,3),1,25)
LPROF ;
+1 KILL BDM,BDMX
SET BDMX=""
+2 ;no longer count lipid profile because there is no result 2014 per Ray.
QUIT
+3 SET %=P_"^LAST LAB [DM AUDIT LIPID PROFILE TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+4 IF '$DATA(BDM(1))
QUIT
+5 IF F="I"
SET BDMX=$PIECE(^AUPNVLAB(+$PIECE(BDM(1),U,4),0),U,4)_"^"_$PIECE(BDM(1),U)
QUIT
+6 SET BDMX=$PIECE(^AUPNVLAB(+$PIECE(BDM(1),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(1),U,4),0),U,4)]"":" mg/dl",1:"")_$$DATE^BDMS9B1($PIECE(BDM(1),U))
+7 QUIT
HDL ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+3 KILL BDM
+4 SET BDMC=0
+5 SET BDMOT=$ORDER(^ATXAX("B","BGP HDL LOINC CODES",0))
+6 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT HDL TAX",0))
+7 DO GATHER
+8 IF '$DATA(BDM(1))
KILL BDM,BDMX
SET BDMX=""
DO LPROF
QUIT BDMX
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_"^"_$PIECE(BDM(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(N),U))_U_$EXTRACT($PIECE(BDM(N),U,3),1,25)
LDL ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,BDMLDL,G
+3 KILL BDM
+4 SET BDMC=0
+5 SET BDMOT=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
+6 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
+7 DO GATHER
+8 IF '$DATA(BDM(1))
KILL BDM,BDMX
SET BDMX=""
DO LPROF
QUIT BDMX
+9 KILL BDMLDL
SET X=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X
QUIT
SET BDMLDL(9999999-$PIECE(BDM(X),U),X)=BDM(X)
+10 SET X=0
SET G=0
FOR
SET X=$ORDER(BDMLDL(X))
IF X'=+X!G
QUIT
SET Y=0
FOR
SET Y=$ORDER(BDMLDL(X,Y))
IF Y'=+Y!(G)
QUIT
IF +$PIECE(^AUPNVLAB(+$PIECE(BDMLDL(X,Y),U,4),0),U,4)
SET G=Y
+11 IF 'G
SET X=$ORDER(BDMLDL(0))
SET G=$ORDER(BDMLDL(X,0))
+12 ;NEW N D SETN
+13 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(G),U,4),0),U,4)_"^"_$PIECE(BDM(G),U)
+14 QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(G),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(G),U,4),0),U,4)]"":" mg/dl ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(G),U))_U_$EXTRACT($PIECE(BDM(G),U,3),1,25)
TRIG ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+3 KILL BDM
+4 SET BDMC=0
+5 SET BDMOT=$ORDER(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
+6 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
+7 DO GATHER
+8 IF '$DATA(BDM(1))
KILL BDM,BDMX
SET BDMX=""
DO LPROF
QUIT BDMX
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_"^"_$PIECE(BDM(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(N),U))_U_$EXTRACT($PIECE(BDM(N),U,3),1,25)
UACR(P,BDATE,EDATE) ;EP - albumin/creatinine ration UACR
+1 NEW BDM,BDMC,BDMOT,BDMLT
+2 KILL BDM
SET BDMC=0
+3 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+4 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT QUANT UACR",0))
+5 DO GATHER
+6 IF '$DATA(BDM(1))
QUIT ""
+7 DO SETN
+8 IF $DATA(BDM(N))
QUIT "X^"_$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(N),U,1))_U_$EXTRACT($PIECE(BDM(N),U,3),1,30)
+9 QUIT ""
+10 ;
SEMI(P,BDATE,EDATE) ;EP - albumin/creatinine ration UACR
+1 NEW BDM,BDMC,BDMOT,BDMLT
+2 KILL BDM
SET BDMC=0
+3 SET BDMOT=""
+4 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT SEMI QUANT UACR",0))
+5 DO GATHER
+6 IF '$DATA(BDM(1))
QUIT ""
+7 DO SETN
+8 IF $DATA(BDM(1))
QUIT "X^"_$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(N),U,1))_U_$EXTRACT($PIECE(BDM(N),U,3),1,30)
+9 QUIT ""
+10 ;
UPCR(P,BDATE,EDATE) ;EP - protein/creatinine ratio UPCR
+1 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+2 KILL BDM
SET BDMC=0
+3 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT P/C RATIO LOINC",0))
+4 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0))
+5 DO GATHER
+6 IF '$DATA(BDM(1))
QUIT ""
+7 DO SETN
+8 IF $DATA(BDM(1))
QUIT "X^"_$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(N),U,1))_U_$EXTRACT($PIECE(BDM(N),U,3),1,30)
+9 QUIT ""
+10 ;
QUAN(P,BDATE,EDATE) ;EP - other quantitative urine protein test
+1 NEW BDM,BDMC
+2 KILL BDM
+3 SET BDMC=0
+4 SET BDMOT=$ORDER(^ATXAX("B","BGP QUANT URINE PROT LOINC",0))
+5 SET BDMLT=$ORDER(^ATXLAB("B","BGP QUANT URINE PROTEIN",0))
+6 DO GATHER
+7 IF '$DATA(BDM(1))
QUIT ""
+8 DO SETN
+9 IF $DATA(BDM(1))
QUIT "X^"_$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(N),U,1))_U_$EXTRACT($PIECE(BDM(N),U,3),1,30)
+10 QUIT ""
+11 ;
PROTEIN ;EP
+1 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,%1
+2 KILL BDM
+3 SET BDMC=0
+4 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0))
+5 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
+6 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+11 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+12 IF 'BDMOT
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,BDMOT)
QUIT
+15 DO SETV
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF '$DATA(BDM(1))
SET %1=""
QUIT %1
+18 DO SETN
+19 NEW %,%1
SET %=$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)
+20 SET %1=$SELECT(%="":"No result",%["+":"Yes ",%[">":"Yes ",$EXTRACT(%)="P":"Yes ",...
... $EXTRACT(%)="p":"Yes ",$$UP^XLFSTR($EXTRACT(%))="S":"Yes ",$$UP^XLFSTR($EXTRACT(%))="M":"Yes ",$$UP^XLFSTR($EXTRACT(%))="L":"Yes ",$EXTRACT(%)="c":"No result ",$EXTRACT(%)="C":"No result ",+%>29:"Yes ",1:"No ")
+21 QUIT $SELECT($EXTRACT(%1)="Y":"X",1:"")_"^"_%_"^"_$$DATE^BDMS9B1($PIECE(BDM(N),U,1))_U_$PIECE(BDM(N),U,3)
ACRATIO ;EP
+1 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+2 KILL BDM
SET BDMC=0
+3 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+4 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT QUANT UACR",0))
+5 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+10 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+11 IF 'BDMOT
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC(J,BDMOT)
QUIT
+14 DO SETV
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF '$DATA(BDM)
SET %1=""
QUIT
+17 DO SETN
+18 NEW %
SET %=$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)
+19 SET %1=$SELECT(%="":"No result",%[">":"Yes ",$EXTRACT(%)="c":"No result ",$EXTRACT(%)="C":"No result ",+%>299:"Yes ",1:"No ")
+20 SET %1=%1_" "_%_"^ "_$PIECE(BDM(N),U,3)_" "_$$DATE^BDMS9B1($PIECE(BDM(N),U,1))
+21 QUIT
ACRATIOM ;EP
+1 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+2 KILL BDM
SET BDMC=0
+3 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+4 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT QUANT UACR",0))
+5 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+10 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+11 IF 'BDMOT
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC(J,BDMOT)
QUIT
+14 DO SETV
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF '$DATA(BDM)
SET %1=""
QUIT
+17 DO SETN
+18 NEW %
SET %=$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)
+19 SET %1=$SELECT(%="":"No result",%="30-300":"Pos ",$EXTRACT(%)="c":"No result ",$EXTRACT(%)="C":"No result ",+%>29&(+%<300):"Pos ",1:"No ")
+20 SET %1=%1_" "_%_" "_$$DATE^BDMS9B1($PIECE(BDM(N),U),"5")_" "_$PIECE(BDM(N),U,3)
+21 QUIT
+22 ;
MICRO(P,BDATE,EDATE) ;EP - other quantitative urine protein test
+1 NEW BDM,BDMOT,BDMC,BDMLT
+2 KILL BDM
+3 SET BDMC=0
+4 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
+5 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
+6 DO GATHER
+7 IF '$DATA(BDM(1))
QUIT ""
+8 DO SETN
+9 IF $DATA(BDM(1))
QUIT "X^"_$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/g ",1:"")_U_$$DATE^BDMS9B1($PIECE(BDM(N),U,1))_U_$PIECE(BDM(N),U,3)
+10 QUIT ""
COMBINED(P,BDMBDAT,BDMADAT,BDM6MBD) ;EP
+1 ;ADDED FOR ICARE 12/06/17
NEW A1C,LDL,BP,ALL,G,V,S,D,STATIN,BDMRBD,BDMRED
+2 ;ADDED FOR ICARE 12/06/17
SET BDMRBD=$$FMTE^XLFDT(BDMBDAT)
+3 ;ADDED FOR ICARE 12/06/17
SET BDMRED=$$FMTE^XLFDT(BDMADAT)
+4 SET G=0
SET ALL=""
+5 ;S A1C=$P(^XTMP("BDMDM19",BDMJOB,BDMBTH,"AUDIT",P,78),U,2)
+6 SET A1C=$PIECE($$HGBA1C^BDMDG18(BDMPD,BDMBDAT,BDMADAT),U,2)
+7 SET V=A1C
+8 SET ALL="A1C: "_$SELECT(A1C]"":A1C,1:"<Not Documented>")
+9 IF V=""!(V="?")
SET G=0
GOTO CSTAT
+10 IF V["<"
SET G=G+1
GOTO CSTAT
+11 IF V[">"
SET G=G+0
GOTO CSTAT
+12 SET V=$$STV^BDMDG18(V,5)
+13 IF V=""
SET G=G+0
GOTO CSTAT
+14 SET V=+V
+15 SET S=$SELECT(V="":0,V<8.0:1,1:0)
+16 SET G=G+S
CSTAT ;
+1 ;S STATIN=+^XTMP("BDMDM19",BDMJOB,BDMBTH,"AUDIT",P,300)
+2 SET STATIN=+$$STATIN^BDMDG16(BDMPD,BDM6MBD,BDMADAT)
+3 SET ALL=ALL_"; statin prescribed: "_$SELECT(STATIN=1:"Yes",1:"No")
+4 IF STATIN=1
SET G=G+1
BP ;
+1 SET S=$$SYSMEAN^BDMDG15(P,BDMRBD,BDMRED)
+2 SET D=$$DIAMEAN^BDMDG15(P,BDMRBD,BDMRED)
+3 Begin DoDot:1
+4 IF S=""!(D="")
QUIT
+5 IF S<140&(D<90)
SET G=G+1
QUIT
End DoDot:1
+6 SET ALL=ALL_"; Mean BP: "_$SELECT(S:S_"/"_D,1:"")
+7 IF G=3
QUIT "1 Yes "_ALL
+8 QUIT "2 No "_ALL
EGFRUACR(P,BD,ED,F) ;EP -
+1 ;ONLY 18 AND OVER
IF $$AGE^AUPNPAT(P,BDMADAT)<18
QUIT ""
+2 SET F=$GET(F)
+3 NEW G,R
+4 SET G=$$GFR^BDMDG1C(BDMPD,BD,ED)
+5 SET R=$$URIN^BDMDG18(BDMPD,BD,ED)
+6 IF $EXTRACT(G)
IF $EXTRACT(R)
QUIT $SELECT(F:1,1:"Yes")
+7 QUIT $SELECT(F:0,1:"No")
