APCLD811 ; IHS/CMI/LAB -IHS -CUMULATIVE REPORT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
IMM ;
S:'$D(APCLCUML(140)) APCLCUML(140)="IMMUNIZATIONS"
S $P(APCLCUML(140),U,2)=$P(APCLCUML(140),U,2)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,64))
I $E(V)="Y" S $P(APCLCUML(140),U,3)=$P(APCLCUML(140),U,3)+1
I $E(V)="R" S $P(APCLCUML(140),U,6)=$P(APCLCUML(140),U,6)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,66))
I $E(V)="Y" S $P(APCLCUML(140),U,4)=$P(APCLCUML(140),U,4)+1
I $E(V)="R" S $P(APCLCUML(140),U,7)=$P(APCLCUML(140),U,7)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,68))
I $E(V)="Y" S $P(APCLCUML(140),U,5)=$P(APCLCUML(140),U,5)+1
I $E(V)="R" S $P(APCLCUML(140),U,8)=$P(APCLCUML(140),U,8)+1
;
QUAN ;
;145
;title^total^uacr^upcr^other quant^albumin normal^micro present^overt present
K APCLOFLG
S APCLOFLG=0
;I '$D(^MAW($J,"UACR")) S ^MAW($J,"UACR")=0
;I '$D(^MAW($J,"UPCR")) S ^MAW($J,"UPCR")=0
;I '$D(^MAW($J,"OTH")) S ^MAW($J,"OTH")=0
S:'$D(APCLCUML(145)) APCLCUML(145)="URINALYSIS"
;S:'$D(APCLCUML(146)) APCLCUML(146)="Total Urine Prot Not Known"
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,91))
;S V=$$UACR^APCLD81C(APCLPD,APCLBDAT,APCLADAT) ;cmi/maw 12/17/2007 DM2008
;S A=$$UPCR^APCLD81C(APCLPD,APCLBDAT,APCLADAT) ;cmi/maw 12/17/2007 DM2008
;S O=$$QUAN^APCLD81C(APCLPD,APCLBDAT,APCLADAT) ;cmi/maw 12/17/2007 DM2008
S A=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,93))
S O=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,95))
I $E(V)="X" D
.;S $P(APCLCUML(146),U,2)=$P(APCLCUML(146),U,2)+1 ;1/9/08
.S $P(APCLCUML(145),U,2)=$P(APCLCUML(145),U,2)+1 ;added for total 1/9/08
.S $P(APCLCUML(145),U,3)=$P(APCLCUML(145),U,3)+1
.;S ^MAW($J,"UACR")=^MAW($J,"UACR")+1
.I $P(V,U,2)]"",$P(V,U,2)["<" S $P(APCLCUML(145),U,6)=$P(APCLCUML(145),U,6)+1 Q ;albumin normal
.I $P(V,U,2)]"",$P(V,U,2)["-" S $P(APCLCUML(145),U,7)=$P(APCLCUML(145),U,7)+1 Q ;micro
.I $P(V,U,2)]"",$P(V,U,2)[">" S $P(APCLCUML(145),U,8)=$P(APCLCUML(145),U,8)+1 Q ;overt
.I $P(V,U,2)]"" S $P(V,U,2)=$$STV^APCLD818($P(V,U,2),9) ;if stripping chars evals to null quit
.Q:$P(V,U,2)="" ;don't count if all chars were alpha
.I $P(V,U,2)]"",$P(V,U,2)<30 S $P(APCLCUML(145),U,6)=$P(APCLCUML(145),U,6)+1 ;albumin normal
.I $P(V,U,2)]"",$P(V,U,2)>30,$P(V,U,2)<299.9 S $P(APCLCUML(145),U,7)=$P(APCLCUML(145),U,7)+1 ;micro present
.I $P(V,U,2)]"",$P(V,U,2)>299.9 S $P(APCLCUML(145),U,8)=$P(APCLCUML(145),U,8)+1 ;overt
I $E(A)="X" D
. ;S APCLOFLG=1,$P(APCLCUML(146),U,2)=$P(APCLCUML(146),U,2)+1 ;1/9/08
. S $P(APCLCUML(145),U,2)=$P(APCLCUML(145),U,2)+1 ;added for total 1/9/08
. Q:$E(V)="X"
. ;S ^MAW($J,"UPCR")=^MAW($J,"UPCR")+1
. S $P(APCLCUML(145),U,4)=$P(APCLCUML(145),U,4)+1
I $E(O)="X" D
. ;S APCLOFLG=1,$P(APCLCUML(146),U,2)=$P(APCLCUML(146),U,2)+1 ;1/9/08
. S $P(APCLCUML(145),U,2)=$P(APCLCUML(145),U,2)+1 ;added for total 1/9/08
. Q:$E(V)="X"
. Q:$E(A)="X"
. ;S ^MAW($J,"OTH")=^MAW($J,"OTH")+1
. S $P(APCLCUML(145),U,5)=$P(APCLCUML(145),U,5)+1
;S OV=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,94))
;I $E(OV)="Y" S $P(APCLCUML(145),U,8)=$P(APCLCUML(145),U,8)+1
;S Q=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,96))
;I $E(Q,1,3)="Pos" S $P(APCLCUML(145),U,7)=$P(APCLCUML(145),U,7)+1
K APCLOFLG ;1/9/08
URIN ;cmi/maw 12/26/2007 no longer needed DM2008
;title^total^total with urinalysis^protein present^protein absent^protein not done^micro present^micro absent^micro not done
;145
;'$D(APCLCUML(146)) APCLCUML(146)="URINALYSIS"
;S $P(APCLCUML(146),U,2)=$P(APCLCUML(146),U,2)+1
;S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,92))
;S A=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,94))
;I $E(V)="Y" S $P(APCLCUML(145),U,3)=$P(APCLCUML(145),U,3)+1
;I $E(A)="Y" S $P(APCLCUML(145),U,4)=$P(APCLCUML(145),U,4)+1
;I A["No result" S $P(APCLCUML(145),U,6)=$P(APCLCUML(145),U,6)+1 G EKG
;I $E(A)="N" S $P(APCLCUML(145),U,5)=$P(APCLCUML(145),U,5)+1 D
;.S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,96))
;.I $E(V,1,3)="Pos" S $P(APCLCUML(145),U,7)=$P(APCLCUML(145),U,7)+1 Q
;.I $E(V,1,3)="Neg" S $P(APCLCUML(145),U,8)=$P(APCLCUML(145),U,8)+1 Q
;.S $P(APCLCUML(145),U,9)=$P(APCLCUML(145),U,9)+1
;.Q
EKG ;need date of last ekg
S:'$D(APCLCUML(150)) APCLCUML(150)="EKG"
G:$$AGE^AUPNPAT(APCLPD,APCLADAT)<30 CREAT
S $P(APCLCUML(150),U,2)=$P(APCLCUML(150),U,2)+1
S V=$$EKG^APCLD812(APCLPD,APCLRED,"I")
I V]"" D
.S E=$$FMDIFF^XLFDT(APCLADAT,V)
.I E<(365.25*3) S $P(APCLCUML(150),U,3)=$P(APCLCUML(150),U,3)+1
.I E<(365.25*5) S $P(APCLCUML(150),U,4)=$P(APCLCUML(150),U,4)+1
.S $P(APCLCUML(150),U,5)=$P(APCLCUML(150),U,5)+1
CREAT ;
S:'$D(APCLCUML(170)) APCLCUML(170)="Creatinine obtained in the past 12 months"
S $P(APCLCUML(170),U,2)=$P(APCLCUML(170),U,2)+1
S V=$$CREAT^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
I V="" S $P(APCLCUML(170),U,5)=$P(APCLCUML(170),U,5)+1 G TCHOL
S V=$P(V,U)
I $E(V)'=+$E(V),$E(V)'="." S $P(APCLCUML(170),U,6)=$P(APCLCUML(170),U,6)+1 G TCHOL ;unable to determine result, not a number
I V>1.9 S $P(APCLCUML(170),U,3)=$P(APCLCUML(170),U,3)+1
I V<2.0 S $P(APCLCUML(170),U,4)=$P(APCLCUML(170),U,4)+1
;
GFR ;
S:'$D(APCLCUML(175)) APCLCUML(175)="Estimated GFR documented in the past 12 months"
S $P(APCLCUML(175),U,2)=$P(APCLCUML(175),U,2)+1
;S V=$$GFR^APCLD81C(APCLPD,APCLBDAT,APCLADAT)
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,79)) ;maw 1/18/08
I V="Yes" S $P(APCLCUML(175),U,5)=$P(APCLCUML(175),U,5)+1
;
TCHOL ;
S:'$D(APCLCUML(180)) APCLCUML(180)="Total Cholesterol obtained in past 12 months"
S $P(APCLCUML(180),U,2)=$P(APCLCUML(180),U,2)+1
S V=$$CHOL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
I V="" S $P(APCLCUML(180),U,6)=$P(APCLCUML(180),U,6)+1 G LDL
S V=$P(V,U)
I $E(V)'=+$E(V) S $P(APCLCUML(180),U,7)=$P(APCLCUML(180),U,7)+1 G LDL ;unable to determine result, not a number or is blank
I V<200 S $P(APCLCUML(180),U,3)=$P(APCLCUML(180),U,3)+1 G LDL
I V<240 S $P(APCLCUML(180),U,4)=$P(APCLCUML(180),U,4)+1 G LDL
S $P(APCLCUML(180),U,5)=$P(APCLCUML(180),U,5)+1
LDL ;
S:'$D(APCLCUML(190)) APCLCUML(190)="LDL Cholesterol obtained in the past 12 months"
S $P(APCLCUML(190),U,2)=$P(APCLCUML(190),U,2)+1
S V=$$LDL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
I V="" S $P(APCLCUML(190),U,7)=$P(APCLCUML(190),U,7)+1 G HDL
S V=$P(V,U)
I $E(V)'=+$E(V) S $P(APCLCUML(190),U,8)=$P(APCLCUML(190),U,8)+1 G HDL ;unable to determine result, not a number or blank
I V<100 S $P(APCLCUML(190),U,3)=$P(APCLCUML(190),U,3)+1 G HDL
I V<130 S $P(APCLCUML(190),U,4)=$P(APCLCUML(190),U,4)+1 G HDL
I V<160.1 S $P(APCLCUML(190),U,5)=$P(APCLCUML(190),U,5)+1 G HDL
S $P(APCLCUML(190),U,6)=$P(APCLCUML(190),U,6)+1
HDL ;
S:'$D(APCLCUML(195)) APCLCUML(195)="HDL Cholesterol obtained in the past 12 months"
S $P(APCLCUML(195),U,2)=$P(APCLCUML(195),U,2)+1
S V=$$HDL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
I V="" S $P(APCLCUML(195),U,7)=$P(APCLCUML(195),U,7)+1 G TRIG
S V=$P(V,U)
I $E(V)'=+$E(V) S $P(APCLCUML(195),U,8)=$P(APCLCUML(195),U,8)+1 G TRIG ;unable to determine result, not a number
S V=$P(V,".")
I V<35 S $P(APCLCUML(195),U,3)=$P(APCLCUML(195),U,3)+1 G TRIG
I V<46 S $P(APCLCUML(195),U,4)=$P(APCLCUML(195),U,4)+1 G TRIG
I V<55.1 S $P(APCLCUML(195),U,5)=$P(APCLCUML(195),U,5)+1 G TRIG
S $P(APCLCUML(195),U,6)=$P(APCLCUML(195),U,6)+1
TRIG ;
S:'$D(APCLCUML(200)) APCLCUML(200)="Triglycerides obtained in past 12 months"
S $P(APCLCUML(200),U,2)=$P(APCLCUML(200),U,2)+1
S V=$$TRIG^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
I V="" S $P(APCLCUML(200),U,7)=$P(APCLCUML(200),U,7)+1 G SELF
S V=$P(V,U)
I $E(V)'=+$E(V) S $P(APCLCUML(200),U,8)=$P(APCLCUML(200),U,8)+1 G SELF ;unable to determine result, not a number
I V<150 S $P(APCLCUML(200),U,3)=$P(APCLCUML(200),U,3)+1 G SELF
I V<200 S $P(APCLCUML(200),U,4)=$P(APCLCUML(200),U,4)+1 G SELF
I V<401 S $P(APCLCUML(200),U,5)=$P(APCLCUML(200),U,5)+1 G SELF
S $P(APCLCUML(200),U,6)=$P(APCLCUML(200),U,6)+1
SELF ;
;S:'$D(APCLCUML(210)) APCLCUML(210)="Self monitoring of blood glucose documented"
;S $P(APCLCUML(210),U,2)=$P(APCLCUML(210),U,2)+1
;S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,98))
;S P=$S($E(V)="Y":3,$E(V)="N":4,$E(V)="R":5,1:6)
;S $P(APCLCUML(210),U,P)=$P(APCLCUML(210),U,P)+1
SDM ;
;Q ;NOT IN 2008
;S:'$D(APCLCUML(220)) APCLCUML(220)="Participating in SDM"
;S $P(APCLCUML(220),U,2)=$P(APCLCUML(220),U,2)+1
;S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,100))
;S P=$S($E(V)="Y":3,1:4)
;S $P(APCLCUML(220),U,P)=$P(APCLCUML(220),U,P)+1
Q
PED(P,BDATE,EDATE) ;EP
K APCLALED
NEW Y,B,D,T,A,G,Z,V,X
S Y="APCLALED("
S X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(APCLALED(1)) S %="" D I %]"" Q %
.S (X,D)=0,%="",T="" F S X=$O(APCLALED(X)) Q:X'=+X!(%]"") D
..S T=$P(^AUPNVPED(+$P(APCLALED(X),U,4),0),U)
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $E(T,1,4)="TO-Q" S %="Yes-"_T_" "_$$FMTE^XLFDT($P(APCLALED(X),U),5) Q
..I T="TO-LA" S %="Yes-"_T_" "_$$FMTE^XLFDT($P(APCLALED(X),U),5) Q
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S X=0,G="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G]"") S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S B=$$CLINIC^APCLV(V,"C")
.I B=94 S G="Yes-"_$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),"."),5)_" CL 94" Q
.S Z=0 F S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G) S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320 S G="Yes-"_$$FMTE^XLFDT($P($P(^AUPNVSIT(V,0),U),"."),5)_" ADA 1320" Q
.Q
Q G
CESS(P,B,D) ;EP - find any cessation hf in 12 months before E
I '$G(P) Q ""
I $E($$TOBACCO^APCLD816(P,D))'=1 Q ""
NEW APCL,E,X,G,T
K APCL
S X=P_"^LAST HEALTH [DM AUDIT CESSATION HLTH FACTOR;DURING "_B_"-"_D S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "Yes-"_$$FMTE^XLFDT($P(APCL(1),U),5)
S X=P_"^EDUC [DM AUDIT SMOKING CESS EDUC;DURING "_B_"-"_D S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "Yes-"_$$FMTE^XLFDT($P(APCL(1),U),5)
S APCL=$$PED(P,B,D)
I APCL]"" Q APCL
NEW T S T=$O(^ATXAX("B","DM AUDIT SMOKING CESS EDUC",0))
;I 'T Q "No"
S (X,G)=0
I T F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) I $$REFUSAL^APCLD817(P,9999999.09,$P(^ATXAX(T,21,X,0),U),B,D) S G=1
I G Q "Refused"
S X=$O(^AUTTEDT("C","TO-Q",0))
I X,$$REFUSAL^APCLD817(P,9999999.09,X,B,D) Q "Refused"
S X=$O(^AUTTEDT("C","TO-LA",0))
I X,$$REFUSAL^APCLD817(P,9999999.09,X,B,D) Q "Refused"
S X=$O(^AUTTEDT("C","TO-QT",0))
I X,$$REFUSAL^APCLD817(P,9999999.09,X,B,D) Q "Refused"
S X=$O(^AUTTEDT("C","TO-QU",0))
I X,$$REFUSAL^APCLD817(P,9999999.09,X,B,D) Q "Refused"
Q "No"
;
APCLD811 ; IHS/CMI/LAB -IHS -CUMULATIVE REPORT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
IMM ;
+1 IF '$DATA(APCLCUML(140))
SET APCLCUML(140)="IMMUNIZATIONS"
+2 SET $PIECE(APCLCUML(140),U,2)=$PIECE(APCLCUML(140),U,2)+1
+3 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,64))
+4 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(140),U,3)=$PIECE(APCLCUML(140),U,3)+1
+5 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(140),U,6)=$PIECE(APCLCUML(140),U,6)+1
+6 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,66))
+7 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(140),U,4)=$PIECE(APCLCUML(140),U,4)+1
+8 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(140),U,7)=$PIECE(APCLCUML(140),U,7)+1
+9 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,68))
+10 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(140),U,5)=$PIECE(APCLCUML(140),U,5)+1
+11 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(140),U,8)=$PIECE(APCLCUML(140),U,8)+1
+12 ;
QUAN ;
+1 ;145
+2 ;title^total^uacr^upcr^other quant^albumin normal^micro present^overt present
+3 KILL APCLOFLG
+4 SET APCLOFLG=0
+5 ;I '$D(^MAW($J,"UACR")) S ^MAW($J,"UACR")=0
+6 ;I '$D(^MAW($J,"UPCR")) S ^MAW($J,"UPCR")=0
+7 ;I '$D(^MAW($J,"OTH")) S ^MAW($J,"OTH")=0
+8 IF '$DATA(APCLCUML(145))
SET APCLCUML(145)="URINALYSIS"
+9 ;S:'$D(APCLCUML(146)) APCLCUML(146)="Total Urine Prot Not Known"
+10 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,91))
+11 ;S V=$$UACR^APCLD81C(APCLPD,APCLBDAT,APCLADAT) ;cmi/maw 12/17/2007 DM2008
+12 ;S A=$$UPCR^APCLD81C(APCLPD,APCLBDAT,APCLADAT) ;cmi/maw 12/17/2007 DM2008
+13 ;S O=$$QUAN^APCLD81C(APCLPD,APCLBDAT,APCLADAT) ;cmi/maw 12/17/2007 DM2008
+14 SET A=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,93))
+15 SET O=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,95))
+16 IF $EXTRACT(V)="X"
Begin DoDot:1
+17 ;S $P(APCLCUML(146),U,2)=$P(APCLCUML(146),U,2)+1 ;1/9/08
+18 ;added for total 1/9/08
SET $PIECE(APCLCUML(145),U,2)=$PIECE(APCLCUML(145),U,2)+1
+19 SET $PIECE(APCLCUML(145),U,3)=$PIECE(APCLCUML(145),U,3)+1
+20 ;S ^MAW($J,"UACR")=^MAW($J,"UACR")+1
+21 ;albumin normal
IF $PIECE(V,U,2)]""
IF $PIECE(V,U,2)["<"
SET $PIECE(APCLCUML(145),U,6)=$PIECE(APCLCUML(145),U,6)+1
QUIT
+22 ;micro
IF $PIECE(V,U,2)]""
IF $PIECE(V,U,2)["-"
SET $PIECE(APCLCUML(145),U,7)=$PIECE(APCLCUML(145),U,7)+1
QUIT
+23 ;overt
IF $PIECE(V,U,2)]""
IF $PIECE(V,U,2)[">"
SET $PIECE(APCLCUML(145),U,8)=$PIECE(APCLCUML(145),U,8)+1
QUIT
+24 ;if stripping chars evals to null quit
IF $PIECE(V,U,2)]""
SET $PIECE(V,U,2)=$$STV^APCLD818($PIECE(V,U,2),9)
+25 ;don't count if all chars were alpha
IF $PIECE(V,U,2)=""
QUIT
+26 ;albumin normal
IF $PIECE(V,U,2)]""
IF $PIECE(V,U,2)<30
SET $PIECE(APCLCUML(145),U,6)=$PIECE(APCLCUML(145),U,6)+1
+27 ;micro present
IF $PIECE(V,U,2)]""
IF $PIECE(V,U,2)>30
IF $PIECE(V,U,2)<299.9
SET $PIECE(APCLCUML(145),U,7)=$PIECE(APCLCUML(145),U,7)+1
+28 ;overt
IF $PIECE(V,U,2)]""
IF $PIECE(V,U,2)>299.9
SET $PIECE(APCLCUML(145),U,8)=$PIECE(APCLCUML(145),U,8)+1
End DoDot:1
+29 IF $EXTRACT(A)="X"
Begin DoDot:1
+30 ;S APCLOFLG=1,$P(APCLCUML(146),U,2)=$P(APCLCUML(146),U,2)+1 ;1/9/08
+31 ;added for total 1/9/08
SET $PIECE(APCLCUML(145),U,2)=$PIECE(APCLCUML(145),U,2)+1
+32 IF $EXTRACT(V)="X"
QUIT
+33 ;S ^MAW($J,"UPCR")=^MAW($J,"UPCR")+1
+34 SET $PIECE(APCLCUML(145),U,4)=$PIECE(APCLCUML(145),U,4)+1
End DoDot:1
+35 IF $EXTRACT(O)="X"
Begin DoDot:1
+36 ;S APCLOFLG=1,$P(APCLCUML(146),U,2)=$P(APCLCUML(146),U,2)+1 ;1/9/08
+37 ;added for total 1/9/08
SET $PIECE(APCLCUML(145),U,2)=$PIECE(APCLCUML(145),U,2)+1
+38 IF $EXTRACT(V)="X"
QUIT
+39 IF $EXTRACT(A)="X"
QUIT
+40 ;S ^MAW($J,"OTH")=^MAW($J,"OTH")+1
+41 SET $PIECE(APCLCUML(145),U,5)=$PIECE(APCLCUML(145),U,5)+1
End DoDot:1
+42 ;S OV=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,94))
+43 ;I $E(OV)="Y" S $P(APCLCUML(145),U,8)=$P(APCLCUML(145),U,8)+1
+44 ;S Q=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,96))
+45 ;I $E(Q,1,3)="Pos" S $P(APCLCUML(145),U,7)=$P(APCLCUML(145),U,7)+1
+46 ;1/9/08
KILL APCLOFLG
URIN ;cmi/maw 12/26/2007 no longer needed DM2008
+1 ;title^total^total with urinalysis^protein present^protein absent^protein not done^micro present^micro absent^micro not done
+2 ;145
+3 ;'$D(APCLCUML(146)) APCLCUML(146)="URINALYSIS"
+4 ;S $P(APCLCUML(146),U,2)=$P(APCLCUML(146),U,2)+1
+5 ;S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,92))
+6 ;S A=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,94))
+7 ;I $E(V)="Y" S $P(APCLCUML(145),U,3)=$P(APCLCUML(145),U,3)+1
+8 ;I $E(A)="Y" S $P(APCLCUML(145),U,4)=$P(APCLCUML(145),U,4)+1
+9 ;I A["No result" S $P(APCLCUML(145),U,6)=$P(APCLCUML(145),U,6)+1 G EKG
+10 ;I $E(A)="N" S $P(APCLCUML(145),U,5)=$P(APCLCUML(145),U,5)+1 D
+11 ;.S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,96))
+12 ;.I $E(V,1,3)="Pos" S $P(APCLCUML(145),U,7)=$P(APCLCUML(145),U,7)+1 Q
+13 ;.I $E(V,1,3)="Neg" S $P(APCLCUML(145),U,8)=$P(APCLCUML(145),U,8)+1 Q
+14 ;.S $P(APCLCUML(145),U,9)=$P(APCLCUML(145),U,9)+1
+15 ;.Q
EKG ;need date of last ekg
+1 IF '$DATA(APCLCUML(150))
SET APCLCUML(150)="EKG"
+2 IF $$AGE^AUPNPAT(APCLPD,APCLADAT)<30
GOTO CREAT
+3 SET $PIECE(APCLCUML(150),U,2)=$PIECE(APCLCUML(150),U,2)+1
+4 SET V=$$EKG^APCLD812(APCLPD,APCLRED,"I")
+5 IF V]""
Begin DoDot:1
+6 SET E=$$FMDIFF^XLFDT(APCLADAT,V)
+7 IF E<(365.25*3)
SET $PIECE(APCLCUML(150),U,3)=$PIECE(APCLCUML(150),U,3)+1
+8 IF E<(365.25*5)
SET $PIECE(APCLCUML(150),U,4)=$PIECE(APCLCUML(150),U,4)+1
+9 SET $PIECE(APCLCUML(150),U,5)=$PIECE(APCLCUML(150),U,5)+1
End DoDot:1
CREAT ;
+1 IF '$DATA(APCLCUML(170))
SET APCLCUML(170)="Creatinine obtained in the past 12 months"
+2 SET $PIECE(APCLCUML(170),U,2)=$PIECE(APCLCUML(170),U,2)+1
+3 SET V=$$CREAT^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
+4 IF V=""
SET $PIECE(APCLCUML(170),U,5)=$PIECE(APCLCUML(170),U,5)+1
GOTO TCHOL
+5 SET V=$PIECE(V,U)
+6 ;unable to determine result, not a number
IF $EXTRACT(V)'=+$EXTRACT(V)
IF $EXTRACT(V)'="."
SET $PIECE(APCLCUML(170),U,6)=$PIECE(APCLCUML(170),U,6)+1
GOTO TCHOL
+7 IF V>1.9
SET $PIECE(APCLCUML(170),U,3)=$PIECE(APCLCUML(170),U,3)+1
+8 IF V<2.0
SET $PIECE(APCLCUML(170),U,4)=$PIECE(APCLCUML(170),U,4)+1
+9 ;
GFR ;
+1 IF '$DATA(APCLCUML(175))
SET APCLCUML(175)="Estimated GFR documented in the past 12 months"
+2 SET $PIECE(APCLCUML(175),U,2)=$PIECE(APCLCUML(175),U,2)+1
+3 ;S V=$$GFR^APCLD81C(APCLPD,APCLBDAT,APCLADAT)
+4 ;maw 1/18/08
SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,79))
+5 IF V="Yes"
SET $PIECE(APCLCUML(175),U,5)=$PIECE(APCLCUML(175),U,5)+1
+6 ;
TCHOL ;
+1 IF '$DATA(APCLCUML(180))
SET APCLCUML(180)="Total Cholesterol obtained in past 12 months"
+2 SET $PIECE(APCLCUML(180),U,2)=$PIECE(APCLCUML(180),U,2)+1
+3 SET V=$$CHOL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
+4 IF V=""
SET $PIECE(APCLCUML(180),U,6)=$PIECE(APCLCUML(180),U,6)+1
GOTO LDL
+5 SET V=$PIECE(V,U)
+6 ;unable to determine result, not a number or is blank
IF $EXTRACT(V)'=+$EXTRACT(V)
SET $PIECE(APCLCUML(180),U,7)=$PIECE(APCLCUML(180),U,7)+1
GOTO LDL
+7 IF V<200
SET $PIECE(APCLCUML(180),U,3)=$PIECE(APCLCUML(180),U,3)+1
GOTO LDL
+8 IF V<240
SET $PIECE(APCLCUML(180),U,4)=$PIECE(APCLCUML(180),U,4)+1
GOTO LDL
+9 SET $PIECE(APCLCUML(180),U,5)=$PIECE(APCLCUML(180),U,5)+1
LDL ;
+1 IF '$DATA(APCLCUML(190))
SET APCLCUML(190)="LDL Cholesterol obtained in the past 12 months"
+2 SET $PIECE(APCLCUML(190),U,2)=$PIECE(APCLCUML(190),U,2)+1
+3 SET V=$$LDL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
+4 IF V=""
SET $PIECE(APCLCUML(190),U,7)=$PIECE(APCLCUML(190),U,7)+1
GOTO HDL
+5 SET V=$PIECE(V,U)
+6 ;unable to determine result, not a number or blank
IF $EXTRACT(V)'=+$EXTRACT(V)
SET $PIECE(APCLCUML(190),U,8)=$PIECE(APCLCUML(190),U,8)+1
GOTO HDL
+7 IF V<100
SET $PIECE(APCLCUML(190),U,3)=$PIECE(APCLCUML(190),U,3)+1
GOTO HDL
+8 IF V<130
SET $PIECE(APCLCUML(190),U,4)=$PIECE(APCLCUML(190),U,4)+1
GOTO HDL
+9 IF V<160.1
SET $PIECE(APCLCUML(190),U,5)=$PIECE(APCLCUML(190),U,5)+1
GOTO HDL
+10 SET $PIECE(APCLCUML(190),U,6)=$PIECE(APCLCUML(190),U,6)+1
HDL ;
+1 IF '$DATA(APCLCUML(195))
SET APCLCUML(195)="HDL Cholesterol obtained in the past 12 months"
+2 SET $PIECE(APCLCUML(195),U,2)=$PIECE(APCLCUML(195),U,2)+1
+3 SET V=$$HDL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
+4 IF V=""
SET $PIECE(APCLCUML(195),U,7)=$PIECE(APCLCUML(195),U,7)+1
GOTO TRIG
+5 SET V=$PIECE(V,U)
+6 ;unable to determine result, not a number
IF $EXTRACT(V)'=+$EXTRACT(V)
SET $PIECE(APCLCUML(195),U,8)=$PIECE(APCLCUML(195),U,8)+1
GOTO TRIG
+7 SET V=$PIECE(V,".")
+8 IF V<35
SET $PIECE(APCLCUML(195),U,3)=$PIECE(APCLCUML(195),U,3)+1
GOTO TRIG
+9 IF V<46
SET $PIECE(APCLCUML(195),U,4)=$PIECE(APCLCUML(195),U,4)+1
GOTO TRIG
+10 IF V<55.1
SET $PIECE(APCLCUML(195),U,5)=$PIECE(APCLCUML(195),U,5)+1
GOTO TRIG
+11 SET $PIECE(APCLCUML(195),U,6)=$PIECE(APCLCUML(195),U,6)+1
TRIG ;
+1 IF '$DATA(APCLCUML(200))
SET APCLCUML(200)="Triglycerides obtained in past 12 months"
+2 SET $PIECE(APCLCUML(200),U,2)=$PIECE(APCLCUML(200),U,2)+1
+3 SET V=$$TRIG^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
+4 IF V=""
SET $PIECE(APCLCUML(200),U,7)=$PIECE(APCLCUML(200),U,7)+1
GOTO SELF
+5 SET V=$PIECE(V,U)
+6 ;unable to determine result, not a number
IF $EXTRACT(V)'=+$EXTRACT(V)
SET $PIECE(APCLCUML(200),U,8)=$PIECE(APCLCUML(200),U,8)+1
GOTO SELF
+7 IF V<150
SET $PIECE(APCLCUML(200),U,3)=$PIECE(APCLCUML(200),U,3)+1
GOTO SELF
+8 IF V<200
SET $PIECE(APCLCUML(200),U,4)=$PIECE(APCLCUML(200),U,4)+1
GOTO SELF
+9 IF V<401
SET $PIECE(APCLCUML(200),U,5)=$PIECE(APCLCUML(200),U,5)+1
GOTO SELF
+10 SET $PIECE(APCLCUML(200),U,6)=$PIECE(APCLCUML(200),U,6)+1
SELF ;
+1 ;S:'$D(APCLCUML(210)) APCLCUML(210)="Self monitoring of blood glucose documented"
+2 ;S $P(APCLCUML(210),U,2)=$P(APCLCUML(210),U,2)+1
+3 ;S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,98))
+4 ;S P=$S($E(V)="Y":3,$E(V)="N":4,$E(V)="R":5,1:6)
+5 ;S $P(APCLCUML(210),U,P)=$P(APCLCUML(210),U,P)+1
SDM ;
+1 ;Q ;NOT IN 2008
+2 ;S:'$D(APCLCUML(220)) APCLCUML(220)="Participating in SDM"
+3 ;S $P(APCLCUML(220),U,2)=$P(APCLCUML(220),U,2)+1
+4 ;S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,100))
+5 ;S P=$S($E(V)="Y":3,1:4)
+6 ;S $P(APCLCUML(220),U,P)=$P(APCLCUML(220),U,P)+1
+7 QUIT
PED(P,BDATE,EDATE) ;EP
+1 KILL APCLALED
+2 NEW Y,B,D,T,A,G,Z,V,X
+3 SET Y="APCLALED("
+4 SET X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(APCLALED(1))
SET %=""
Begin DoDot:1
+6 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(APCLALED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:2
+7 SET T=$PIECE(^AUPNVPED(+$PIECE(APCLALED(X),U,4),0),U)
+8 IF 'T
QUIT
+9 IF '$DATA(^AUTTEDT(T,0))
QUIT
+10 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+11 IF $EXTRACT(T,1,4)="TO-Q"
SET %="Yes-"_T_" "_$$FMTE^XLFDT($PIECE(APCLALED(X),U),5)
QUIT
+12 IF T="TO-LA"
SET %="Yes-"_T_" "_$$FMTE^XLFDT($PIECE(APCLALED(X),U),5)
QUIT
End DoDot:2
End DoDot:1
IF %]""
QUIT %
+13 KILL ^TMP($JOB,"A")
+14 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+15 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+16 SET X=0
SET G=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G]"")
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+17 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+18 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+19 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+20 SET B=$$CLINIC^APCLV(V,"C")
+21 IF B=94
SET G="Yes-"_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."),5)_" CL 94"
QUIT
+22 SET Z=0
FOR
SET Z=$ORDER(^AUPNVDEN("AD",V,Z))
IF Z'=+Z!(G)
QUIT
SET B=$PIECE($GET(^AUPNVDEN(Z,0)),U)
IF B
SET B=$PIECE($GET(^AUTTADA(B,0)),U)
IF B=1320
SET G="Yes-"_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."),5)_" ADA 1320"
QUIT
+23 QUIT
End DoDot:1
+24 QUIT G
CESS(P,B,D) ;EP - find any cessation hf in 12 months before E
+1 IF '$GET(P)
QUIT ""
+2 IF $EXTRACT($$TOBACCO^APCLD816(P,D))'=1
QUIT ""
+3 NEW APCL,E,X,G,T
+4 KILL APCL
+5 SET X=P_"^LAST HEALTH [DM AUDIT CESSATION HLTH FACTOR;DURING "_B_"-"_D
SET E=$$START1^APCLDF(X,"APCL(")
+6 IF $DATA(APCL(1))
QUIT "Yes-"_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
+7 SET X=P_"^EDUC [DM AUDIT SMOKING CESS EDUC;DURING "_B_"-"_D
SET E=$$START1^APCLDF(X,"APCL(")
+8 IF $DATA(APCL(1))
QUIT "Yes-"_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
+9 SET APCL=$$PED(P,B,D)
+10 IF APCL]""
QUIT APCL
+11 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT SMOKING CESS EDUC",0))
+12 ;I 'T Q "No"
+13 SET (X,G)=0
+14 IF T
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL^APCLD817(P,9999999.09,$PIECE(^ATXAX(T,21,X,0),U),B,D)
SET G=1
+15 IF G
QUIT "Refused"
+16 SET X=$ORDER(^AUTTEDT("C","TO-Q",0))
+17 IF X
IF $$REFUSAL^APCLD817(P,9999999.09,X,B,D)
QUIT "Refused"
+18 SET X=$ORDER(^AUTTEDT("C","TO-LA",0))
+19 IF X
IF $$REFUSAL^APCLD817(P,9999999.09,X,B,D)
QUIT "Refused"
+20 SET X=$ORDER(^AUTTEDT("C","TO-QT",0))
+21 IF X
IF $$REFUSAL^APCLD817(P,9999999.09,X,B,D)
QUIT "Refused"
+22 SET X=$ORDER(^AUTTEDT("C","TO-QU",0))
+23 IF X
IF $$REFUSAL^APCLD817(P,9999999.09,X,B,D)
QUIT "Refused"
+24 QUIT "No"
+25 ;
