APCLD81C.m

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