APCLD81C ; IHS/CMI/LAB - 2008 DIABETES AUDIT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
GATHER ;
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
.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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'APCLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLOT)
...D SETV
...Q
I '$D(APCL(1)) Q
S D=$P(APCL(1),U),D=9999999-D
K APCL S APCLC=0
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))
..I APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
..Q:'APCLOT
..S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
..Q:'$$LOINC(J,APCLOT)
..D SETV
..Q
Q
LOINC(A,B) ;EP - is loinc code A in taxonomy B
NEW %
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 APCLC=APCLC+1
S V=$P(^AUPNVLAB(X,0),U,3),APCLV=$P($P($G(^AUPNVSIT(V,0)),U),".") Q:'APCLV
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
Q
SETN ;
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
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(APCL(X)) Q:X'=+X S A($P(APCL(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(APCL(N),U,4),0),U,4)]"",$$UP^XLFSTR($P(^AUPNVLAB(+$P(APCL(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(APCL(N),U,4),0),U,4)="" K APCL(N)
.Q
Q
GFR(P,BDATE,EDATE) ;EP - Estimated GFR
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL
S APCLC=0
S APCLOT=$O(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
S APCLLT=$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:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...I APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'APCLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLOT)
...D SETV
...Q
I $D(APCL(1)) Q "Yes"
Q "No"
CREAT ;EP
I $G(F)="" S F="E"
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL
S APCLC=0
S APCLOT=$O(^ATXAX("B","BGP CREATININE LOINC CODES",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
D GATHER
I '$D(APCL(1)) Q ""
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_"^"_$P(APCL(N),U)
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)
CHOL ;EP
S:$G(F)="" F="E"
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL
S APCLC=0
S APCLOT=$O(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
D GATHER
I '$D(APCL(1)) Q ""
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_"^"_$P(APCL(N),U)
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)
LPROF ;
K APCL,APCLX S APCLX=""
S %=P_"^LAST LAB [DM AUDIT LIPID PROFILE TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q
I F="I" S APCLX=$P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_"^"_$P(APCL(1),U) Q
S APCLX=$P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)]"":" mg/dl",1:"")_$$FMTE^XLFDT($P(APCL(1),U),5)
Q
HDL ;EP
I $G(F)="" S F="E"
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL
S APCLC=0
S APCLOT=$O(^ATXAX("B","BGP HDL LOINC CODES",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT HDL TAX",0))
D GATHER
I '$D(APCL(1)) K APCL,APCLX S APCLX="" D LPROF Q APCLX
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_"^"_$P(APCL(N),U)
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)
LDL ;EP
I $G(F)="" S F="E"
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL
S APCLC=0
S APCLOT=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL 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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'APCLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLOT)
...D SETV
...Q
I '$D(APCL(1)) K APCL,APCLX S APCLX="" D LPROF Q APCLX
K APCLLDL S X=0 F S X=$O(APCL(X)) Q:X'=+X S APCLLDL(9999999-$P(APCL(X),U),X)=APCL(X)
S X=0,G=0 F S X=$O(APCLLDL(X)) Q:X'=+X!G S Y=0 F S Y=$O(APCLLDL(X,Y)) Q:Y'=+Y!(G) I +$P(^AUPNVLAB(+$P(APCLLDL(X,Y),U,4),0),U,4) S G=Y
I 'G S X=$O(APCLLDL(0)),G=$O(APCLLDL(X,0))
;NEW N D SETN
I F="I" Q $P(^AUPNVLAB(+$P(APCL(G),U,4),0),U,4)_"^"_$P(APCL(G),U)
Q $P(^AUPNVLAB(+$P(APCL(G),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(G),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(APCL(G),U),5)
TRIG ;EP
I $G(F)="" S F="E"
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL
S APCLC=0
S APCLOT=$O(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
D GATHER
I '$D(APCL(1)) K APCL,APCLX S APCLX="" D LPROF Q APCLX
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_"^"_$P(APCL(N),U)
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)
URIN ;EP
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL
S APCLC=0
;S %=P_"^LAST LAB [DM AUDIT URINALYSIS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
;gather up all labs in the date range for hemoglobin a1c
S APCLOT=$O(^ATXAX("B","DM AUDIT URINALYSIS LOINC",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT URINALYSIS 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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'APCLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLOT)
...D SETV
...Q
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U),5)_" Urinalysis"
K APCL S APCLC=0
S APCLOT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT A/C RATIO 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))
...I APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'APCLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLOT)
...D SETV
...Q
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U),5)_" A/C Ratio"
K APCL
S APCLC=0
S APCLOT=$O(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0))
S APCLLT=$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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'APCLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLOT)
...D SETV
...Q
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U),5)_" Urine Prot"
NEW G S G=0
NEW T S T=$O(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0))
S X=0 F S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G) I $$REFUSAL^APCLD817(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
I G Q "Refused"
S G=0
NEW T S T=$O(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
S X=0 F S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G) I $$REFUSAL^APCLD817(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
I G Q "Refused"
S G=0
NEW T S T=$O(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
S X=0 F S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G) I $$REFUSAL^APCLD817(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
Q $S(G:"Refused",1:"No")
UACR(P,BDATE,EDATE) ;EP - albumin/creatinine ration UACR
K APCL S APCLC=0
S APCLOT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
D GATHER
I '$D(APCL(1)) Q ""
D SETN
I $D(APCL(1)) Q "X^"_$P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)]"":" mg/g ",1:"")
Q ""
;
UPCR(P,BDATE,EDATE) ;EP - protein/creatinine ratio UPCR
;NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL S APCLC=0
S APCLOT=$O(^ATXAX("B","DM AUDIT P/C RATIO LOINC",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0))
D GATHER
I '$D(APCL(1)) Q ""
D SETN
I $D(APCL(1)) Q "X^"_$P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)]"":" mg/g ",1:"")
Q ""
;
QUAN(P,BDATE,EDATE) ;EP - other quantitative urine protein test
K APCL
S APCLC=0
S APCLOT=$O(^ATXAX("B","BGP QUANT URINE PROT LOINC",0))
S APCLLT=$O(^ATXLAB("B","BGP QUANT URINE PROTEIN",0))
D GATHER
I '$D(APCL(1)) Q ""
D SETN
I $D(APCL(1)) Q "X"
Q ""
;
PROTEIN ;EP
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL
S APCLC=0
S APCLOT=$O(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0))
S APCLLT=$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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'APCLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLOT)
...D SETV
...Q
I '$D(APCL(1)) S %1="" D ACRATIO Q %1
D SETN
NEW %,%1 S %=$P(^AUPNVLAB(+$P(APCL(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 %1_%_" "_$$FMTE^XLFDT($P(APCL(N),U),"5")_" "_$P(APCL(N),U,3)
ACRATIO ;EP
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL S APCLC=0
S APCLOT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT A/C RATIO 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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'APCLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLOT)
...D SETV
...Q
I '$D(APCL) S %1="" Q
D SETN
NEW % S %=$P(^AUPNVLAB(+$P(APCL(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_" "_%_" "_$$FMTE^XLFDT($P(APCL(N),U),"5")_" "_$P(APCL(N),U,3)
Q
ACRATIOM ;EP
NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
K APCL S APCLC=0
S APCLOT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
S APCLLT=$O(^ATXLAB("B","DM AUDIT A/C RATIO 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 APCLLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'APCLOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLOT)
...D SETV
...Q
I '$D(APCL) S %1="" Q
D SETN
NEW % S %=$P(^AUPNVLAB(+$P(APCL(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_" "_%_" "_$$FMTE^XLFDT($P(APCL(N),U),"5")_" "_$P(APCL(N),U,3)
Q
;
APCLD81C ; IHS/CMI/LAB - 2008 DIABETES AUDIT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
GATHER ;
+1 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)!($DATA(APCL))
QUIT
Begin DoDot:1
+2 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+4 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+5 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+6 IF APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+7 IF 'APCLOT
QUIT
+8 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+9 IF '$$LOINC(J,APCLOT)
QUIT
+10 DO SETV
+11 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF '$DATA(APCL(1))
QUIT
+13 SET D=$PIECE(APCL(1),U)
SET D=9999999-D
+14 KILL APCL
SET APCLC=0
+15 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:2
+17 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+18 IF APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+19 IF 'APCLOT
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC(J,APCLOT)
QUIT
+22 DO SETV
+23 QUIT
End DoDot:2
End DoDot:1
+24 QUIT
LOINC(A,B) ;EP - is loinc code A in taxonomy B
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
SETV ;
+1 SET APCLC=APCLC+1
+2 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
SET APCLV=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
IF 'APCLV
QUIT
+3 SET APCL(APCLC)=APCLV_"^"_$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
SET (A,G)=0
FOR
SET A=$ORDER(APCL(A))
IF A'=+A!(G)
QUIT
SET R=$PIECE(^AUPNVLAB(+$PIECE(APCL(A),U,4),0),U,4)
IF R]""
IF $$UP^XLFSTR(R)'="COMMENT"
SET G=A
+2 SET N=$SELECT(G:G,1:1)
+3 QUIT
SET3 ;
+1 NEW X,N1,N2,N3,A,T
+2 KILL A
+3 SET X=0
FOR
SET X=$ORDER(APCL(X))
IF X'=+X
QUIT
SET A($PIECE(APCL(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(APCL(N),U,4),0),U,4)]""
IF $$UP^XLFSTR($PIECE(^AUPNVLAB(+$PIECE(APCL(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(APCL(N),U,4),0),U,4)=""
KILL APCL(N)
+8 QUIT
End DoDot:1
+9 QUIT
GFR(P,BDATE,EDATE) ;EP - Estimated GFR
+1 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+2 KILL APCL
+3 SET APCLC=0
+4 SET APCLOT=$ORDER(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
+5 SET APCLLT=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR 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 APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+12 IF 'APCLOT
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,APCLOT)
QUIT
+15 DO SETV
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF $DATA(APCL(1))
QUIT "Yes"
+18 QUIT "No"
CREAT ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+3 KILL APCL
+4 SET APCLC=0
+5 SET APCLOT=$ORDER(^ATXAX("B","BGP CREATININE LOINC CODES",0))
+6 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
+7 DO GATHER
+8 IF '$DATA(APCL(1))
QUIT ""
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_"^"_$PIECE(APCL(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(N),U),5)
CHOL ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+3 KILL APCL
+4 SET APCLC=0
+5 SET APCLOT=$ORDER(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
+6 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
+7 DO GATHER
+8 IF '$DATA(APCL(1))
QUIT ""
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_"^"_$PIECE(APCL(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(N),U),5)
LPROF ;
+1 KILL APCL,APCLX
SET APCLX=""
+2 SET %=P_"^LAST LAB [DM AUDIT LIPID PROFILE TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+3 IF '$DATA(APCL(1))
QUIT
+4 IF F="I"
SET APCLX=$PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_"^"_$PIECE(APCL(1),U)
QUIT
+5 SET APCLX=$PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)]"":" mg/dl",1:"")_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
+6 QUIT
HDL ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+3 KILL APCL
+4 SET APCLC=0
+5 SET APCLOT=$ORDER(^ATXAX("B","BGP HDL LOINC CODES",0))
+6 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT HDL TAX",0))
+7 DO GATHER
+8 IF '$DATA(APCL(1))
KILL APCL,APCLX
SET APCLX=""
DO LPROF
QUIT APCLX
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_"^"_$PIECE(APCL(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(N),U),5)
LDL ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+3 KILL APCL
+4 SET APCLC=0
+5 SET APCLOT=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
+6 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
+7 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
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+12 IF APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+13 IF 'APCLOT
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC(J,APCLOT)
QUIT
+16 DO SETV
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF '$DATA(APCL(1))
KILL APCL,APCLX
SET APCLX=""
DO LPROF
QUIT APCLX
+19 KILL APCLLDL
SET X=0
FOR
SET X=$ORDER(APCL(X))
IF X'=+X
QUIT
SET APCLLDL(9999999-$PIECE(APCL(X),U),X)=APCL(X)
+20 SET X=0
SET G=0
FOR
SET X=$ORDER(APCLLDL(X))
IF X'=+X!G
QUIT
SET Y=0
FOR
SET Y=$ORDER(APCLLDL(X,Y))
IF Y'=+Y!(G)
QUIT
IF +$PIECE(^AUPNVLAB(+$PIECE(APCLLDL(X,Y),U,4),0),U,4)
SET G=Y
+21 IF 'G
SET X=$ORDER(APCLLDL(0))
SET G=$ORDER(APCLLDL(X,0))
+22 ;NEW N D SETN
+23 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(G),U,4),0),U,4)_"^"_$PIECE(APCL(G),U)
+24 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(G),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(G),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(G),U),5)
TRIG ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+3 KILL APCL
+4 SET APCLC=0
+5 SET APCLOT=$ORDER(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
+6 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
+7 DO GATHER
+8 IF '$DATA(APCL(1))
KILL APCL,APCLX
SET APCLX=""
DO LPROF
QUIT APCLX
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_"^"_$PIECE(APCL(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(N),U),5)
URIN ;EP
+1 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+2 KILL APCL
+3 SET APCLC=0
+4 ;S %=P_"^LAST LAB [DM AUDIT URINALYSIS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
+5 ;gather up all labs in the date range for hemoglobin a1c
+6 SET APCLOT=$ORDER(^ATXAX("B","DM AUDIT URINALYSIS LOINC",0))
+7 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT URINALYSIS 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 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+13 IF APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+14 IF 'APCLOT
QUIT
+15 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+16 IF '$$LOINC(J,APCLOT)
QUIT
+17 DO SETV
+18 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U),5)_" Urinalysis"
+20 KILL APCL
SET APCLC=0
+21 SET APCLOT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+22 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
+23 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
+24 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+25 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+26 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+27 IF APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+28 IF 'APCLOT
QUIT
+29 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+30 IF '$$LOINC(J,APCLOT)
QUIT
+31 DO SETV
+32 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+33 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U),5)_" A/C Ratio"
+34 KILL APCL
+35 SET APCLC=0
+36 SET APCLOT=$ORDER(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0))
+37 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
+38 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
+39 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+40 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+41 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+42 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+43 IF APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+44 IF 'APCLOT
QUIT
+45 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+46 IF '$$LOINC(J,APCLOT)
QUIT
+47 DO SETV
+48 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+49 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U),5)_" Urine Prot"
+50 NEW G
SET G=0
+51 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0))
+52 SET X=0
FOR
SET X=$ORDER(^ATXLAB(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL^APCLD817(P,60,$PIECE(^ATXLAB(T,21,X,0),U),BDATE,EDATE)
SET G=1
+53 IF G
QUIT "Refused"
+54 SET G=0
+55 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
+56 SET X=0
FOR
SET X=$ORDER(^ATXLAB(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL^APCLD817(P,60,$PIECE(^ATXLAB(T,21,X,0),U),BDATE,EDATE)
SET G=1
+57 IF G
QUIT "Refused"
+58 SET G=0
+59 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
+60 SET X=0
FOR
SET X=$ORDER(^ATXLAB(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL^APCLD817(P,60,$PIECE(^ATXLAB(T,21,X,0),U),BDATE,EDATE)
SET G=1
+61 QUIT $SELECT(G:"Refused",1:"No")
UACR(P,BDATE,EDATE) ;EP - albumin/creatinine ration UACR
+1 KILL APCL
SET APCLC=0
+2 SET APCLOT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+3 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
+4 DO GATHER
+5 IF '$DATA(APCL(1))
QUIT ""
+6 DO SETN
+7 IF $DATA(APCL(1))
QUIT "X^"_$PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)]"":" mg/g ",1:"")
+8 QUIT ""
+9 ;
UPCR(P,BDATE,EDATE) ;EP - protein/creatinine ratio UPCR
+1 ;NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+2 KILL APCL
SET APCLC=0
+3 SET APCLOT=$ORDER(^ATXAX("B","DM AUDIT P/C RATIO LOINC",0))
+4 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT P/C RATIO TAX",0))
+5 DO GATHER
+6 IF '$DATA(APCL(1))
QUIT ""
+7 DO SETN
+8 IF $DATA(APCL(1))
QUIT "X^"_$PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)]"":" mg/g ",1:"")
+9 QUIT ""
+10 ;
QUAN(P,BDATE,EDATE) ;EP - other quantitative urine protein test
+1 KILL APCL
+2 SET APCLC=0
+3 SET APCLOT=$ORDER(^ATXAX("B","BGP QUANT URINE PROT LOINC",0))
+4 SET APCLLT=$ORDER(^ATXLAB("B","BGP QUANT URINE PROTEIN",0))
+5 DO GATHER
+6 IF '$DATA(APCL(1))
QUIT ""
+7 DO SETN
+8 IF $DATA(APCL(1))
QUIT "X"
+9 QUIT ""
+10 ;
PROTEIN ;EP
+1 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+2 KILL APCL
+3 SET APCLC=0
+4 SET APCLOT=$ORDER(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0))
+5 SET APCLLT=$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 APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+12 IF 'APCLOT
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,APCLOT)
QUIT
+15 DO SETV
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF '$DATA(APCL(1))
SET %1=""
DO ACRATIO
QUIT %1
+18 DO SETN
+19 NEW %,%1
SET %=$PIECE(^AUPNVLAB(+$PIECE(APCL(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 %1_%_" "_$$FMTE^XLFDT($PIECE(APCL(N),U),"5")_" "_$PIECE(APCL(N),U,3)
ACRATIO ;EP
+1 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+2 KILL APCL
SET APCLC=0
+3 SET APCLOT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+4 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",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 APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+11 IF 'APCLOT
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC(J,APCLOT)
QUIT
+14 DO SETV
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF '$DATA(APCL)
SET %1=""
QUIT
+17 DO SETN
+18 NEW %
SET %=$PIECE(^AUPNVLAB(+$PIECE(APCL(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_" "_%_" "_$$FMTE^XLFDT($PIECE(APCL(N),U),"5")_" "_$PIECE(APCL(N),U,3)
+21 QUIT
ACRATIOM ;EP
+1 NEW APCL,X,%,E,R,V,APCLLT,APCLOT,B,D,L,J,APCLC,APCLV,V
+2 KILL APCL
SET APCLC=0
+3 SET APCLOT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
+4 SET APCLLT=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",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 APCLLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+11 IF 'APCLOT
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC(J,APCLOT)
QUIT
+14 DO SETV
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF '$DATA(APCL)
SET %1=""
QUIT
+17 DO SETN
+18 NEW %
SET %=$PIECE(^AUPNVLAB(+$PIECE(APCL(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_" "_%_" "_$$FMTE^XLFDT($PIECE(APCL(N),U),"5")_" "_$PIECE(APCL(N),U,3)
+21 QUIT
+22 ;
