APCHS9B2 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
;IHS/CMI/LAB patch 3 - patch 3 fixes various problems
;
;
;1/13/98 IHS/CMI/LAB patch 3 - added Q APCHX to TD+3 and FLU+3
MORE ;EP
S APCHSBEG=$$FMADD^XLFDT(DT,-365)
S X="SMBG: "_$$SELF^APCHS9B3(APCHSDFN,APCHSBEG) D S(X,1)
S X="DM Education Provided (in past yr): " D S(X)
S X=" Last Dietitian Visit: "_$$DIETV^APCHS9B3(APCHSDFN) D S(X)
K APCHX D EDUC I $D(APCHX) D
.S %=0 F S %=$O(APCHX(%)) Q:%'=+% S X=" "_APCHX(%) D S(X)
K APCHX,APCHY,%
D EDUCREF^APCHS9B3 I $D(APCHX) S X="In the past year, the patient has declined the following Diabetes education:" D S(X,1) D
.S %="" F S %=$O(APCHX(%)) Q:%="" S X=" "_%_" "_APCHX(%) D S(X)
K APCHX,APCHY,%
S X="Immunizations:" D S(X,1)
S X="Flu vaccine since August 1st:",$E(X,32)=$$FLU^APCHS9B3(APCHSDFN) D S(X)
S X="Pneumovax ever:",$E(X,32)=$$PNEU^APCHS9B5(APCHSDFN) D S(X)
S X="Td in past 10 yrs:",$E(X,32)=$$TD^APCHS9B3(APCHSDFN,(DT-100000)) D S(X)
S Y=$$PPDS^APCHS9B5(APCHSDFN) I Y]"" S X="PPD Status: "_Y D S(X)
I Y="" S X="Last Documented PPD:",$E(X,27)=$$PPD^APCHS9B5(APCHSDFN) D S(X)
S X="Last TB Status Health Factor: "_$$TB(APCHSDFN) S $E(X,50)="Last CHEST X-RAY: "_$$CHEST^APCHS9B6(APCHSDFN) D S(X)
S APCHEKG=$$EKG^APCHS9B7(APCHSDFN),X="EKG:",$E(X,32)=$P(APCHEKG,U,1) S:$P(APCHEKG,U,2)]"" $E(X,54)=$P(APCHEKG,U,2) D S(X)
L ;
S X="Laboratory Results (most recent):" D S(X,1)
S X="HbA1c:" S Y=$$HBA1C(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S X="Next most recent HbA1c:" S Y=$$NLHGB(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S X="Nephropathy Assessment" D S(X)
S X=" Urine Protein:" S Y=$$URIN(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S X=" Microalbuminuria:" S Y=$$MICRO(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S X=" A/C Ratio:" S Y=$$ACRATIO(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S X=" Creatinine:" S Y=$$CREAT(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S X=" Estimated GFR:" S Y=$$GFR(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S X="Total Cholesterol:" S Y=$$TCHOL(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S X=" LDL Cholesterol:" S Y=$$CHOL(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S V=$P(Y,"|||") I V'=+V D
.;get last 3 and display next most recent 2
.S APCHIEN=$P(Y,"|||",4)
.S T=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)) D LDLLAB
.I $D(APCHX) S X=" Next most recent LDL values:" D S(X)
.S APCHY=0 F S APCHY=$O(APCHX(APCHY)) Q:APCHY'=+APCHY S X="",$E(X,27)=$P(APCHX(APCHY),U),$E(X,42)=$$FMTE^XLFDT($P(APCHX(APCHY),U,2)) D S(X)
S X=" HDL Cholesterol:" S Y=$$HDL(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
S X=" Triglycerides:" S Y=$$TRIG(APCHSDFN),$E(X,27)=$P(Y,"|||"),$E(X,42)=$P(Y,"|||",2),$E(X,56)=$P(Y,"|||",3) D S(X)
Q
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW %,X
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP("APCHS",$J,"DCS",0),U)+1,$P(^TMP("APCHS",$J,"DCS",0),U)=%
S ^TMP("APCHS",$J,"DCS",%)=X
Q
EDUC ;EP - gather up all education provided in past year in APCHX
K APCHX,APCHY S %=APCHSDFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(APCHSBEG)_"-"_$$FMTE^XLFDT(DT) S E=$$START1^APCLDF(%,"APCHY(") ;IHS/CMI/LAB patch 3 1/13/98 added $$FMTE^XLFDT to _DT replaced " - " with "-"
I '$D(APCHY) S APCHX(1)=" <No Education Topics recorded in past year>" K APCHY Q
NEW X,APCHP K APCHP S X=0,E="" F S X=$O(APCHY(X)) Q:X'=+X S E=+$P(APCHY(X),U,4) I $P(^AUPNVPED(E,0),U,6)'=5 S E=$P(^AUPNVPED(E,0),U) I $$EDT(E) S APCHP($P(APCHY(X),U,2))=$$FMTE^XLFDT($P(APCHY(X),U))
S %=0,E="" F S E=$O(APCHP(E)) Q:E="" S %=%+1,APCHX(%)=$E(E,1,24),$E(APCHX(%),27)=APCHP(E)
K APCHY,APCHP
Q
EDT(E) ;
;is this ien in any taxonomy
NEW T
S T=$O(^ATXAX("B","DM AUDIT DIABETES EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$O(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$O(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$O(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$P(^AUTTEDT(E,0),U,2)
I $P(T,"-")="DM" Q 1
I $P(T,"-")="DMC" Q 1
Q ""
TB(P) ;
I '$G(P) Q ""
NEW APCHS,E,X
K APCHS
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"APCHS(")
I $D(APCHS(1)) Q $P($G(APCHS(1)),U,3)
NEW %,Y
S %=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
I '% Q ""
S (X,Y)=0 F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(Y) I $D(^ATXAX(%,21,"B",X)) S Y=X
I 'Y Q ""
Q $P(^AUTTHF(Y,0),U)
GFR(P) ;
I '$G(P) Q ""
S APCHC=""
NEW T,T1,T2
S T=$O(^LAB(60,"B","ESTIMATED GFR",0))
S T1=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
S T2=$O(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
NEW D,V,G,X,J S (D,G)=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(APCHC]"") D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(APCHC]"") D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y D
...Q:'$D(^AUPNVLAB(Y,0))
...I T,$P(^AUPNVLAB(Y,0),U)=T D
....I APCHC]"",$P(^AUPNVLAB(Y,0),U,4)="" Q
....S APCHC=$P(^AUPNVLAB(Y,0),U,4)_"|||"_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVLAB(Y,0),U,3),0),U),"."))_"|||"_""_"|||"_Y Q
...I T1,$P(^AUPNVLAB(Y,0),U),$D(^ATXLAB(T1,21,"B",$P(^AUPNVLAB(Y,0),U))) D
....I APCHC]"",$P(^AUPNVLAB(Y,0),U,4)="" Q
....S APCHC=$P(^AUPNVLAB(Y,0),U,4)_"|||"_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVLAB(Y,0),U,3),0),U),"."))_"|||"_""_"|||"_Y Q
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T2)
...S APCHC=$P(^AUPNVLAB(Y,0),U,4)_"|||"_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVLAB(Y,0),U,3),0),U),"."))_"|||"_""_"|||"_Y
...Q
I APCHC]"" Q APCHC
S T=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0)) I 'T Q ""
Q $$LAB(P,T)
CHOL(P) ;EP
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),LT=$O(^ATXAX("B","BGP LDL LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
HDL(P) ;EP
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT HDL TAX",0)),LT=$O(^ATXAX("B","BGP HDL LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
TCHOL(P) ;EP
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0)),LT=$O(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
TRIG(P) ;EP
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0)),LT=$O(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
CREAT(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0)),LT=$O(^ATXAX("B","BGP CREATININE LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
;
LAB(P,T,LT) ;EP
I '$G(LT) S LT=""
NEW D,V,G,X,J S (D,G)=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G) D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(G) D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y!(G) D
...I $D(^ATXLAB(T,21,"B",X)),$P(^AUPNVLAB(Y,0),U,4)]"" S G=Y Q
...;IHS/CMI/LAB - don't check loinc code for now
...;IHS/CMI/LAB - yes, check loinc in patch 14
...;Q
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...S G=Y
...Q
..Q
.Q
I 'G S R=$$REF(P,T) Q "||||||"_R
Q $P(^AUPNVLAB(G,0),U,4)_"|||"_$$FMTE^XLFDT($P($P($G(^AUPNVSIT($P(^AUPNVLAB(G,0),U,3),0)),U),"."))_"|||"_$$VAL^XBDIQ1(9000010.09,G,.01)_" "_$$REF(P,T,$P($P($G(^AUPNVSIT($P(^AUPNVLAB(G,0),U,3),0)),U),"."))_"|||"_G
LOINC(A,B) ;EP
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 ""
LDLLAB ;EP
K APCHX
NEW LT S LT=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
NEW D,V,X,G S (D,G)=0 F S D=$O(^AUPNVLAB("AE",APCHSPAT,D)) Q:D'=+D!(G>2) D
.S X=0 F S X=$O(^AUPNVLAB("AE",APCHSPAT,D,X)) Q:X'=+X!(G>2) D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",APCHSPAT,D,X,Y)) Q:Y'=+Y!(G>2) D
...Q:'$D(^AUPNVLAB(Y,0))
...I $P(^AUPNVLAB(Y,0),U,4)="" Q
...I Y=APCHIEN Q
...I $D(^ATXLAB(T,21,"B",X)) D Q
....S R=$P(^AUPNVLAB(Y,0),U,4) Q:R'=+R
....S APCHX(Y)=R_"^"_(9999999-D),G=G+1
...;Q ;IHS/CMI/LAB - don't check loinc codes for now
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...S R=$P(^AUPNVLAB(Y,0),U,4) Q:R'=+R
...S APCHX(Y)=R_"^"_(9999999-D),G=G+1
...Q
..Q
.Q
Q
DATE(D) ;EP - convert to slashed date
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
REF(P,T,D) ;return refusal string after date D for test is tax T
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(D) S D=""
N APCHREF,APCHT,V S APCHT=0 F S APCHT=$O(^ATXLAB(T,21,"B",APCHT)) Q:APCHT'=+APCHT D
.S V=$$REF1(P,60,APCHT,D) I V]"" S APCHREF(9999999-$P(V,U,3))=V
I $D(APCHREF) S %=0,%=$O(APCHREF(%)) I % S V=APCHREF(%) Q V
Q ""
REF1(P,F,I,D,T) ; ;
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(D)="" S D=""
I $G(T)="" S T="E"
NEW X,N S X=$O(^AUPNPREF("AA",P,F,I,0))
I 'X Q "" ;none of this item was refused
S N=$O(^AUPNPREF("AA",P,F,I,X,0))
NEW Y S Y=9999999-X
I D]"",Y>D Q $S(T="I":Y,1:$$TYPEREF(N)_"-"_$$DATE(Y))
I T="I" Q Y ;quit on internal form of date
Q $$TYPEREF(N)_"-"_$$DATE(Y)
;
TYPEREF(N) ;
NEW % S %=$P(^AUPNPREF(N,0),U,7)
I %="R"!(%="") Q "Declined"
I %="N" Q "Not Med Ind"
I %="F" Q "No Resp to F/U"
Q ""
NLHGB(P) ;return next to last HGBA1C
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0)) I 'T Q "<Taxonomy Missing>"
NEW LT S LT=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
NEW D,V,G,X,E S (D,G)=0,E="" F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G=2) D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(G=2) D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y!(G=2) D
...I $D(^ATXLAB(T,21,"B",X)),$P(^AUPNVLAB(Y,0),U,4)]"" S G=G+1,E=Y Q
...;Q ;IHS/CMI/LAB - DON'T CHECK LOINC CODES FOR NOW
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...S G=G+1,E=Y
...Q
..Q
.Q
I G'=2 Q ""
I 'E Q ""
Q $P(^AUPNVLAB(E,0),U,4)_"|||"_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVLAB(E,0),U,3),0),U),"."))
HBA1C(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0)),LT=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
URIN(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0)),LT=$O(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
MICRO(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0)),LT=$O(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
ACRATIO(P) ;
I '$G(P) Q ""
NEW T S T=$O(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0)),LT=$O(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0)) I 'T Q "<Taxonomy Missing>"
Q $$LAB(P,T,LT)
APCHS9B2 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
+1 ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
+2 ;IHS/CMI/LAB patch 3 - patch 3 fixes various problems
+3 ;
+4 ;
+5 ;1/13/98 IHS/CMI/LAB patch 3 - added Q APCHX to TD+3 and FLU+3
MORE ;EP
+1 SET APCHSBEG=$$FMADD^XLFDT(DT,-365)
+2 SET X="SMBG: "_$$SELF^APCHS9B3(APCHSDFN,APCHSBEG)
DO S(X,1)
+3 SET X="DM Education Provided (in past yr): "
DO S(X)
+4 SET X=" Last Dietitian Visit: "_$$DIETV^APCHS9B3(APCHSDFN)
DO S(X)
+5 KILL APCHX
DO EDUC
IF $DATA(APCHX)
Begin DoDot:1
+6 SET %=0
FOR
SET %=$ORDER(APCHX(%))
IF %'=+%
QUIT
SET X=" "_APCHX(%)
DO S(X)
End DoDot:1
+7 KILL APCHX,APCHY,%
+8 DO EDUCREF^APCHS9B3
IF $DATA(APCHX)
SET X="In the past year, the patient has declined the following Diabetes education:"
DO S(X,1)
Begin DoDot:1
+9 SET %=""
FOR
SET %=$ORDER(APCHX(%))
IF %=""
QUIT
SET X=" "_%_" "_APCHX(%)
DO S(X)
End DoDot:1
+10 KILL APCHX,APCHY,%
+11 SET X="Immunizations:"
DO S(X,1)
+12 SET X="Flu vaccine since August 1st:"
SET $EXTRACT(X,32)=$$FLU^APCHS9B3(APCHSDFN)
DO S(X)
+13 SET X="Pneumovax ever:"
SET $EXTRACT(X,32)=$$PNEU^APCHS9B5(APCHSDFN)
DO S(X)
+14 SET X="Td in past 10 yrs:"
SET $EXTRACT(X,32)=$$TD^APCHS9B3(APCHSDFN,(DT-100000))
DO S(X)
+15 SET Y=$$PPDS^APCHS9B5(APCHSDFN)
IF Y]""
SET X="PPD Status: "_Y
DO S(X)
+16 IF Y=""
SET X="Last Documented PPD:"
SET $EXTRACT(X,27)=$$PPD^APCHS9B5(APCHSDFN)
DO S(X)
+17 SET X="Last TB Status Health Factor: "_$$TB(APCHSDFN)
SET $EXTRACT(X,50)="Last CHEST X-RAY: "_$$CHEST^APCHS9B6(APCHSDFN)
DO S(X)
+18 SET APCHEKG=$$EKG^APCHS9B7(APCHSDFN)
SET X="EKG:"
SET $EXTRACT(X,32)=$PIECE(APCHEKG,U,1)
IF $PIECE(APCHEKG,U,2)]""
SET $EXTRACT(X,54)=$PIECE(APCHEKG,U,2)
DO S(X)
L ;
+1 SET X="Laboratory Results (most recent):"
DO S(X,1)
+2 SET X="HbA1c:"
SET Y=$$HBA1C(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+3 SET X="Next most recent HbA1c:"
SET Y=$$NLHGB(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+4 SET X="Nephropathy Assessment"
DO S(X)
+5 SET X=" Urine Protein:"
SET Y=$$URIN(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+6 SET X=" Microalbuminuria:"
SET Y=$$MICRO(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+7 SET X=" A/C Ratio:"
SET Y=$$ACRATIO(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+8 SET X=" Creatinine:"
SET Y=$$CREAT(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+9 SET X=" Estimated GFR:"
SET Y=$$GFR(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+10 SET X="Total Cholesterol:"
SET Y=$$TCHOL(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+11 SET X=" LDL Cholesterol:"
SET Y=$$CHOL(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+12 SET V=$PIECE(Y,"|||")
IF V'=+V
Begin DoDot:1
+13 ;get last 3 and display next most recent 2
+14 SET APCHIEN=$PIECE(Y,"|||",4)
+15 SET T=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
DO LDLLAB
+16 IF $DATA(APCHX)
SET X=" Next most recent LDL values:"
DO S(X)
+17 SET APCHY=0
FOR
SET APCHY=$ORDER(APCHX(APCHY))
IF APCHY'=+APCHY
QUIT
SET X=""
SET $EXTRACT(X,27)=$PIECE(APCHX(APCHY),U)
SET $EXTRACT(X,42)=$$FMTE^XLFDT($PIECE(APCHX(APCHY),U,2))
DO S(X)
End DoDot:1
+18 SET X=" HDL Cholesterol:"
SET Y=$$HDL(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+19 SET X=" Triglycerides:"
SET Y=$$TRIG(APCHSDFN)
SET $EXTRACT(X,27)=$PIECE(Y,"|||")
SET $EXTRACT(X,42)=$PIECE(Y,"|||",2)
SET $EXTRACT(X,56)=$PIECE(Y,"|||",3)
DO S(X)
+20 QUIT
S(Y,F,C,T) ;set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 NEW %,X
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("APCHS",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("APCHS",$JOB,"DCS",0),U)=%
+2 SET ^TMP("APCHS",$JOB,"DCS",%)=X
+3 QUIT
EDUC ;EP - gather up all education provided in past year in APCHX
+1 ;IHS/CMI/LAB patch 3 1/13/98 added $$FMTE^XLFDT to _DT replaced " - " with "-"
KILL APCHX,APCHY
SET %=APCHSDFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(APCHSBEG)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,"APCHY(")
+2 IF '$DATA(APCHY)
SET APCHX(1)=" <No Education Topics recorded in past year>"
KILL APCHY
QUIT
+3 NEW X,APCHP
KILL APCHP
SET X=0
SET E=""
FOR
SET X=$ORDER(APCHY(X))
IF X'=+X
QUIT
SET E=+$PIECE(APCHY(X),U,4)
IF $PIECE(^AUPNVPED(E,0),U,6)'=5
SET E=$PIECE(^AUPNVPED(E,0),U)
IF $$EDT(E)
SET APCHP($PIECE(APCHY(X),U,2))=$$FMTE^XLFDT($PIECE(APCHY(X),U))
+4 SET %=0
SET E=""
FOR
SET E=$ORDER(APCHP(E))
IF E=""
QUIT
SET %=%+1
SET APCHX(%)=$EXTRACT(E,1,24)
SET $EXTRACT(APCHX(%),27)=APCHP(E)
+5 KILL APCHY,APCHP
+6 QUIT
EDT(E) ;
+1 ;is this ien in any taxonomy
+2 NEW T
+3 SET T=$ORDER(^ATXAX("B","DM AUDIT DIABETES EDUC TOPICS",0))
+4 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+5 SET T=$ORDER(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
+6 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+7 SET T=$ORDER(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
+8 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+9 SET T=$ORDER(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
+10 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+11 SET T=$PIECE(^AUTTEDT(E,0),U,2)
+12 IF $PIECE(T,"-")="DM"
QUIT 1
+13 IF $PIECE(T,"-")="DMC"
QUIT 1
+14 QUIT ""
TB(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW APCHS,E,X
+3 KILL APCHS
+4 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"APCHS(")
+5 IF $DATA(APCHS(1))
QUIT $PIECE($GET(APCHS(1)),U,3)
+6 NEW %,Y
+7 SET %=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
+8 IF '%
QUIT ""
+9 SET (X,Y)=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X!(Y)
QUIT
IF $DATA(^ATXAX(%,21,"B",X))
SET Y=X
+10 IF 'Y
QUIT ""
+11 QUIT $PIECE(^AUTTHF(Y,0),U)
GFR(P) ;
+1 IF '$GET(P)
QUIT ""
+2 SET APCHC=""
+3 NEW T,T1,T2
+4 SET T=$ORDER(^LAB(60,"B","ESTIMATED GFR",0))
+5 SET T1=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
+6 SET T2=$ORDER(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
+7 NEW D,V,G,X,J
SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(APCHC]"")
QUIT
Begin DoDot:1
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(APCHC]"")
QUIT
Begin DoDot:2
+9 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(Y,0))
QUIT
+11 IF T
IF $PIECE(^AUPNVLAB(Y,0),U)=T
Begin DoDot:4
+12 IF APCHC]""
IF $PIECE(^AUPNVLAB(Y,0),U,4)=""
QUIT
+13 SET APCHC=$PIECE(^AUPNVLAB(Y,0),U,4)_"|||"_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(Y,0),U,3),0),U),"."))_"|||"_""_"|||"_Y
QUIT
End DoDot:4
+14 IF T1
IF $PIECE(^AUPNVLAB(Y,0),U)
IF $DATA(^ATXLAB(T1,21,"B",$PIECE(^AUPNVLAB(Y,0),U)))
Begin DoDot:4
+15 IF APCHC]""
IF $PIECE(^AUPNVLAB(Y,0),U,4)=""
QUIT
+16 SET APCHC=$PIECE(^AUPNVLAB(Y,0),U,4)_"|||"_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(Y,0),U,3),0),U),"."))_"|||"_""_"|||"_Y
QUIT
End DoDot:4
+17 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+18 IF '$$LOINC(J,T2)
QUIT
+19 SET APCHC=$PIECE(^AUPNVLAB(Y,0),U,4)_"|||"_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(Y,0),U,3),0),U),"."))_"|||"_""_"|||"_Y
+20 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF APCHC]""
QUIT APCHC
+22 SET T=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
IF 'T
QUIT ""
+23 QUIT $$LAB(P,T)
CHOL(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
HDL(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT HDL TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP HDL LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
TCHOL(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
TRIG(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
CREAT(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP CREATININE LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
+4 ;
LAB(P,T,LT) ;EP
+1 IF '$GET(LT)
SET LT=""
+2 NEW D,V,G,X,J
SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+4 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+5 IF $DATA(^ATXLAB(T,21,"B",X))
IF $PIECE(^AUPNVLAB(Y,0),U,4)]""
SET G=Y
QUIT
+6 ;IHS/CMI/LAB - don't check loinc code for now
+7 ;IHS/CMI/LAB - yes, check loinc in patch 14
+8 ;Q
+9 IF 'LT
QUIT
+10 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+11 IF '$$LOINC(J,LT)
QUIT
+12 SET G=Y
+13 QUIT
End DoDot:3
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 IF 'G
SET R=$$REF(P,T)
QUIT "||||||"_R
+17 QUIT $PIECE(^AUPNVLAB(G,0),U,4)_"|||"_$$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT($PIECE(^AUPNVLAB(G,0),U,3),0)),U),"."))_"|||"_$$VAL^XBDIQ1(9000010.09,G,.01)_" "_$$REF(P,T,$PIECE($PIECE($GET(^AUPNVSIT($PIECE(^AUPNVLAB(G,0),U,3),0)),U),"."))_"||
|"_G
LOINC(A,B) ;EP
+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 ""
LDLLAB ;EP
+1 KILL APCHX
+2 NEW LT
SET LT=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
+3 NEW D,V,X,G
SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",APCHSPAT,D))
IF D'=+D!(G>2)
QUIT
Begin DoDot:1
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",APCHSPAT,D,X))
IF X'=+X!(G>2)
QUIT
Begin DoDot:2
+5 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",APCHSPAT,D,X,Y))
IF Y'=+Y!(G>2)
QUIT
Begin DoDot:3
+6 IF '$DATA(^AUPNVLAB(Y,0))
QUIT
+7 IF $PIECE(^AUPNVLAB(Y,0),U,4)=""
QUIT
+8 IF Y=APCHIEN
QUIT
+9 IF $DATA(^ATXLAB(T,21,"B",X))
Begin DoDot:4
+10 SET R=$PIECE(^AUPNVLAB(Y,0),U,4)
IF R'=+R
QUIT
+11 SET APCHX(Y)=R_"^"_(9999999-D)
SET G=G+1
End DoDot:4
QUIT
+12 ;Q ;IHS/CMI/LAB - don't check loinc codes for now
+13 IF 'LT
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC(J,LT)
QUIT
+16 SET R=$PIECE(^AUPNVLAB(Y,0),U,4)
IF R'=+R
QUIT
+17 SET APCHX(Y)=R_"^"_(9999999-D)
SET G=G+1
+18 QUIT
End DoDot:3
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
DATE(D) ;EP - convert to slashed date
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
REF(P,T,D) ;return refusal string after date D for test is tax T
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(D)
SET D=""
+4 NEW APCHREF,APCHT,V
SET APCHT=0
FOR
SET APCHT=$ORDER(^ATXLAB(T,21,"B",APCHT))
IF APCHT'=+APCHT
QUIT
Begin DoDot:1
+5 SET V=$$REF1(P,60,APCHT,D)
IF V]""
SET APCHREF(9999999-$PIECE(V,U,3))=V
End DoDot:1
+6 IF $DATA(APCHREF)
SET %=0
SET %=$ORDER(APCHREF(%))
IF %
SET V=APCHREF(%)
QUIT V
+7 QUIT ""
REF1(P,F,I,D,T) ; ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(D)=""
SET D=""
+5 IF $GET(T)=""
SET T="E"
+6 NEW X,N
SET X=$ORDER(^AUPNPREF("AA",P,F,I,0))
+7 ;none of this item was refused
IF 'X
QUIT ""
+8 SET N=$ORDER(^AUPNPREF("AA",P,F,I,X,0))
+9 NEW Y
SET Y=9999999-X
+10 IF D]""
IF Y>D
QUIT $SELECT(T="I":Y,1:$$TYPEREF(N)_"-"_$$DATE(Y))
+11 ;quit on internal form of date
IF T="I"
QUIT Y
+12 QUIT $$TYPEREF(N)_"-"_$$DATE(Y)
+13 ;
TYPEREF(N) ;
+1 NEW %
SET %=$PIECE(^AUPNPREF(N,0),U,7)
+2 IF %="R"!(%="")
QUIT "Declined"
+3 IF %="N"
QUIT "Not Med Ind"
+4 IF %="F"
QUIT "No Resp to F/U"
+5 QUIT ""
NLHGB(P) ;return next to last HGBA1C
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 NEW LT
SET LT=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
+4 NEW D,V,G,X,E
SET (D,G)=0
SET E=""
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G=2)
QUIT
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(G=2)
QUIT
Begin DoDot:2
+6 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y!(G=2)
QUIT
Begin DoDot:3
+7 IF $DATA(^ATXLAB(T,21,"B",X))
IF $PIECE(^AUPNVLAB(Y,0),U,4)]""
SET G=G+1
SET E=Y
QUIT
+8 ;Q ;IHS/CMI/LAB - DON'T CHECK LOINC CODES FOR NOW
+9 IF 'LT
QUIT
+10 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+11 IF '$$LOINC(J,LT)
QUIT
+12 SET G=G+1
SET E=Y
+13 QUIT
End DoDot:3
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 IF G'=2
QUIT ""
+17 IF 'E
QUIT ""
+18 QUIT $PIECE(^AUPNVLAB(E,0),U,4)_"|||"_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(E,0),U,3),0),U),"."))
HBA1C(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
SET LT=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
URIN(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))
SET LT=$ORDER(^ATXAX("B","DM AUDIT URINE PROTEIN LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
MICRO(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
SET LT=$ORDER(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
ACRATIO(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
SET LT=$ORDER(^ATXAX("B","DM AUDIT A/C RATIO LOINC",0))
IF 'T
QUIT "<Taxonomy Missing>"
+3 QUIT $$LAB(P,T,LT)
