APCLD815 ; IHS/CMI/LAB -IHS -CUMULATIVE REPORT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
CUML ;EP
K APCLCUML
S APCLCUML(10)="Gender"
S APCLCUML(20)="Age"
S APCLCUML(25)="Diabetes Type"
S APCLCUML(30)="Duration of Diabetes"
S APCLCUML(40)="Weight Control (BMI)"
S APCLCUML(50)="Blood Sugar Control - uses last HGB A1C value"
S APCLCUML(70)="Tuberculosis Status"
S APCLCUML(60)="Blood Pressure Control - based on mean of last 3 bp's"
S APCLCUML(80)="Tobacco use"
S APCLCUML(90)="DIABETES TREATMENT"
S APCLCUML(100)="ANTIPLATELET THERAPY"
S APCLCUML(110)="ACE INHIBITOR (OR ARB) USE"
S APCLCUML(115)="LIPID LOWERING AGENT USE"
S APCLCUML(300)="Depression on Problem List or as POVs"
S APCLCUML(301)="Depression Screening?"
;
PROCESS ;
S APCLPD=0 F S APCLPD=$O(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD)) Q:APCLPD'=+APCLPD D CUML1
Q
;
CUML1 ;
GENDER ;
;gender APCLCUML(10)="Gender^total^females^males"
S $P(APCLCUML(10),U,2)=$P(APCLCUML(10),U,2)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,20))
S P=$S($E(V)="F":3,$E(V)="M":4,1:5)
S $P(APCLCUML(10),U,P)=$P(APCLCUML(10),U,P)+1
AGE ;
S V=$$AGE^AUPNPAT(APCLPD,APCLADAT)
;APCLCUML(20)="Age^total^<15^15-44^45-64^>65^unknown"
S $P(APCLCUML(20),U,2)=$P(APCLCUML(20),U,2)+1
S P=$S(V<15:3,V>14&(V<45):4,V>44&(V<65):5,V>64:6,1:7)
S $P(APCLCUML(20),U,P)=$P(APCLCUML(20),U,P)+1
TYPE ;
;APCLCUML(25)="Total^Type 1^Type 2"
S X=$$TYPE^APCLD816(APCLPD,APCLDMRG,APCLADAT)
S $P(APCLCUML(25),U,2)=$P(APCLCUML(25),U,2)+1
S P=$S(X="":5,X=1:3,X=2:4,1:5)
S $P(APCLCUML(25),U,P)=$P(APCLCUML(25),U,P)+1
DURDMC ;
;APCLCUML(30)="Duration of Diabetes^total^<10^10 or more^do date of dx on problem list or cms register"
S $P(APCLCUML(30),U,2)=$P(APCLCUML(30),U,2)+1
S V=$$DURDM^APCLD814(APCLPD,APCLDMRG,APCLADAT)
S P=$S(V="":5,V<10:3,V>9:4,1:5)
S $P(APCLCUML(30),U,P)=$P(APCLCUML(30),U,P)+1
BMI ;
;APCLCUML(40)="Weight Control (BMI) - does not add up to 100%^total^total^overweight^obese^height or weight missing"
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,112))
S $P(APCLCUML(40),U,2)=$P(APCLCUML(40),U,2)+1
D
.I V="" S $P(APCLCUML(40),U,5)=$P(APCLCUML(40),U,5)+1 Q
.I $$OW^APCLD814(APCLPD,V,APCLADAT) S $P(APCLCUML(40),U,3)=$P(APCLCUML(40),U,3)+1 Q
.I $$OB^APCLD814(APCLPD,V,APCLADAT) S $P(APCLCUML(40),U,4)=$P(APCLCUML(40),U,4)+1 Q
.S $P(APCLCUML(40),U,6)=$P(APCLCUML(40),U,6)+1 Q
HGB ;
;use last hgba1c value only
;APCLCUML(50)=
S $P(APCLCUML(50),U,2)=$P(APCLCUML(50),U,2)+1
S V=$P($G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,78)),U)
;S V=$$STV^APCLD818(V,4)
S P=$S(V="":9,V[">":8,$E(V)'=+$E(V):9,V<7.0:3,V>6.9&(V<8.0):4,V>7.9&(V<9.0):5,V>8.9&(V<10.0):6,V<11.0&(V>9.9):7,V>10.9:8,1:9)
S $P(APCLCUML(50),U,P)=$P(APCLCUML(50),U,P)+1
BPC ;blood pressure control
;take last 3 bp's and get mean systolic and mean diastolic
S $P(APCLCUML(60),U,2)=$P(APCLCUML(60),U,2)+1
S S=$$SYSMEAN(APCLPD,APCLRBD,APCLRED)
S D=$$DIAMEAN(APCLPD,APCLRBD,APCLRED)
D
.I S=""!(D="") S $P(APCLCUML(60),U,8)=$P(APCLCUML(60),U,8)+1 Q
.I S<120&(D<70) S $P(APCLCUML(60),U,3)=$P(APCLCUML(60),U,3)+1 Q
.I S<130&(D<80) S $P(APCLCUML(60),U,4)=$P(APCLCUML(60),U,4)+1 Q
.I S<140&(D<90) S $P(APCLCUML(60),U,5)=$P(APCLCUML(60),U,5)+1 Q
.I S<160&(D<95) S $P(APCLCUML(60),U,6)=$P(APCLCUML(60),U,6)+1 Q
.S $P(APCLCUML(60),U,7)=$P(APCLCUML(60),U,7)+1
TBSTAT ;
S $P(APCLCUML(70),U,2)=$P(APCLCUML(70),U,2)+1
S V=$$TBCODE^APCLD816(APCLPD,APCLRED,APCLDMRG)
S $P(APCLCUML(70),U,(V+2))=$P(APCLCUML(70),U,(V+2))+1
TOBACCO ;
S $P(APCLCUML(80),U,2)=$P(APCLCUML(80),U,2)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,27))
S V1=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,28))
I +V=1 S $P(APCLCUML(80),U,3)=$P(APCLCUML(80),U,3)+1 S P=$S($E(V1)="Y":4,$E(V1)="N":5,1:5) S $P(APCLCUML(80),U,P)=$P(APCLCUML(80),U,P)+1
I +V=2 S $P(APCLCUML(80),U,6)=$P(APCLCUML(80),U,6)+1
I +V=3 S $P(APCLCUML(80),U,7)=$P(APCLCUML(80),U,7)+1
DMTX ;diabetes treatment
S APCL6MBD=$$FMADD^XLFDT(APCLADAT,-(6*31)),APCL6MBD=$$FMTE^XLFDT(APCL6MBD)
S $P(APCLCUML(90),U,2)=$P(APCLCUML(90),U,2)+1
S V=$$THERAPY^APCLD816(APCLPD,APCL6MBD,APCLRED)
I V=1 S $P(APCLCUML(90),U,3)=$P(APCLCUML(90),U,3)+1
I V=9 S $P(APCLCUML(90),U,11)=$P(APCLCUML(90),U,11)+1
;I $L(V)=1 S P=$S(V=2:4,V=3:5,V=4:6,V=5:7,V=6:8,1:"") S $P(APCLCUML(90),U,P)=$P(APCLCUML(90),U,P)+1 ;cmi/maw 12/26/2007 orig line
;I $L(V)=1 S P=$S(V=2:4,V=3:5,V=4:6,V=5:7,V=6:8,V=7:12,V=8:13,1:"") S $P(APCLCUML(90),U,P)=$P(APCLCUML(90),U,P)+1 ;cmi/maw 12/26/2007 DM2008
N I
F I=1:1:$L(V) D
. N Q
. S Q=$E(V,I,I)
. S P=$S(Q=2:4,Q=3:5,Q=4:6,Q=5:7,Q=6:8,Q=7:13,Q=8:12,1:"") S $P(APCLCUML(90),U,P)=$P(APCLCUML(90),U,P)+1 ;cmi/maw 4/2/2008 modified for incretin/dpp4 per gary
I $L(V)>1,V["2" S $P(APCLCUML(90),U,10)=$P(APCLCUML(90),U,10)+1
I $L(V)>1,V'[2 S $P(APCLCUML(90),U,9)=$P(APCLCUML(90),U,9)+1
ASPIRIN ;
;only tally if patient is 30 and older
G ACE:$$AGE^AUPNPAT(APCLPD,APCLADAT)<30
S $P(APCLCUML(100),U,2)=$P(APCLCUML(100),U,2)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,62))
S P=$S($E(V)="A":3,$E(V)="R":7,$E(V)="N":6,1:6)
S $P(APCLCUML(100),U,P)=$P(APCLCUML(100),U,P)+1
ACE ;110 title^total pts^total pts with protein^# of those on ace^# with htn^# of those on ace"
S $P(APCLCUML(110),U,2)=$P(APCLCUML(110),U,2)+1
;set 3rd piece with # with proteinuria
S P=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,91)) ;01/09/08
;S P=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,94))
S H=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,34))
S A=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,60))
I $P(P,U,2)[">" S $P(P,U,2)=300 ;cmi/maw 3/26/2008 convert to 300 if it contains a > signaling overt
I $E(P)]"",$P(P,U,2)>299.9 S $P(APCLCUML(110),U,3)=$P(APCLCUML(110),U,3)+1 I $E(A)="Y",+$P(P,U,2)>299.9 S $P(APCLCUML(110),U,4)=$P(APCLCUML(110),U,4)+1 ;01/09/08
;I $E(P)="Y" S $P(APCLCUML(110),U,3)=$P(APCLCUML(110),U,3)+1 I $E(A)="Y" S $P(APCLCUML(110),U,4)=$P(APCLCUML(110),U,4)+1
I $E(H)="Y" S $P(APCLCUML(110),U,5)=$P(APCLCUML(110),U,5)+1 I $E(A)="Y" S $P(APCLCUML(110),U,6)=$P(APCLCUML(110),U,6)+1
LIPID ;115
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,61))
S L=$$LDL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I"),L=$P(L,U)
S T=$$CHOL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I"),T=$P(T,U)
I T]"",T'<240 S $P(APCLCUML(115),U,3)=$P(APCLCUML(115),U,3)+1 I "SOB"[$E(V) S $P(APCLCUML(115),U,4)=$P(APCLCUML(115),U,4)+1
I L]"",L>100 S $P(APCLCUML(115),U,5)=$P(APCLCUML(115),U,5)+1 I "SOB"[$E(V) S $P(APCLCUML(115),U,6)=$P(APCLCUML(115),U,6)+1
;lipid agents
;7 - all w/agent 8 - all with statin only 9 - all with non-statin 10 - both.fx
I "SOB"[$E(V) S $P(APCLCUML(115),U,7)=$P(APCLCUML(115),U,7)+1
I $E(V)="S" S $P(APCLCUML(115),U,8)=$P(APCLCUML(115),U,8)+1
I $E(V)="O" S $P(APCLCUML(115),U,9)=$P(APCLCUML(115),U,9)+1
I $E(V)="B" S $P(APCLCUML(115),U,10)=$P(APCLCUML(115),U,10)+1
I $E(V)="R" S $P(APCLCUML(115),U,11)=$P(APCLCUML(115),U,11)+1
DEP ;
S $P(APCLCUML(300),U,2)=$P(APCLCUML(300),U,2)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,200))
I $E(V)="Y" S $P(APCLCUML(300),U,3)=$P(APCLCUML(300),U,3)+1
I $E(V)'="Y" S $P(APCLCUML(301),U,2)=$P(APCLCUML(301),U,2)+1 D
.S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,210))
.I $E(V)="Y" S $P(APCLCUML(301),U,3)=$P(APCLCUML(301),U,3)+1
.I $E(V)="N" S $P(APCLCUML(301),U,4)=$P(APCLCUML(301),U,4)+1
.I $E(V)="R" S $P(APCLCUML(301),U,5)=$P(APCLCUML(301),U,5)+1
EXAMS ;
S:'$D(APCLCUML(120)) APCLCUML(120)="EXAMS - Yearly"
S $P(APCLCUML(120),U,2)=$P(APCLCUML(120),U,2)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,38))
I $E(V)="Y" S $P(APCLCUML(120),U,3)=$P(APCLCUML(120),U,3)+1
I $E(V)="R" S $P(APCLCUML(120),U,6)=$P(APCLCUML(120),U,6)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,40))
I $E(V)="Y" S $P(APCLCUML(120),U,4)=$P(APCLCUML(120),U,4)+1
I $E(V)="R" S $P(APCLCUML(120),U,7)=$P(APCLCUML(120),U,7)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,42))
I $E(V)="Y" S $P(APCLCUML(120),U,5)=$P(APCLCUML(120),U,5)+1
I $E(V)="R" S $P(APCLCUML(120),U,8)=$P(APCLCUML(120),U,8)+1
I $P(^DPT(APCLPD,0),U,2)="F" S $P(APCLCUML(120),U,9)=$P(APCLCUML(120),U,9)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,108))
I $E(V)="Y" S $P(APCLCUML(120),U,10)=$P(APCLCUML(120),U,10)+1
I $E(V)="R" S $P(APCLCUML(120),U,11)=$P(APCLCUML(120),U,11)+1
EDUC ;
S:'$D(APCLCUML(130)) APCLCUML(130)="DIABETES-RELATED EDUCATION - Yearly"
S $P(APCLCUML(130),U,2)=$P(APCLCUML(130),U,2)+1
S G=0,V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,44))
I $E(V)="Y" S $P(APCLCUML(130),U,3)=$P(APCLCUML(130),U,3)+1 S G=1
I $E(V)="R" S $P(APCLCUML(130),U,7)=$P(APCLCUML(130),U,7)+1
I $G(V)="Yes (RD)" S $P(APCLCUML(130),U,10)=$P(APCLCUML(130),U,10)+1 S G=1
I $G(V)="Yes (RD & Non RD - Other)" S $P(APCLCUML(130),U,10)=$P(APCLCUML(130),U,10)+1 S G=1 ;cmi/maw 1/15/08
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,46))
I $E(V)="Y" S $P(APCLCUML(130),U,4)=$P(APCLCUML(130),U,4)+1 S G=1
I $E(V)="R" S $P(APCLCUML(130),U,8)=$P(APCLCUML(130),U,8)+1
S V=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,48))
I $E(V)="R" S $P(APCLCUML(130),U,9)=$P(APCLCUML(130),U,9)+1
I $E(V)="Y" S $P(APCLCUML(130),U,5)=$P(APCLCUML(130),U,5)+1 S G=1
I G S $P(APCLCUML(130),U,6)=$P(APCLCUML(130),U,6)+1
D ^APCLD811
Q
SYSMEAN(P,BDATE,EDATE) ;EP
NEW X S X=$$BPS^APCLD813(P,BDATE,EDATE,"I")
I X="" Q ""
NEW Y,C S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C'=3 Q ""
S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/")+C
Q C\3
Q ""
DIAMEAN(P,BDATE,EDATE) ;EP
NEW X S X=$$BPS^APCLD813(P,BDATE,EDATE,"I")
I X="" Q ""
NEW Y,C S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C'=3 Q ""
S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/",2)+C
Q C\3
APCLD815 ; IHS/CMI/LAB -IHS -CUMULATIVE REPORT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
CUML ;EP
+1 KILL APCLCUML
+2 SET APCLCUML(10)="Gender"
+3 SET APCLCUML(20)="Age"
+4 SET APCLCUML(25)="Diabetes Type"
+5 SET APCLCUML(30)="Duration of Diabetes"
+6 SET APCLCUML(40)="Weight Control (BMI)"
+7 SET APCLCUML(50)="Blood Sugar Control - uses last HGB A1C value"
+8 SET APCLCUML(70)="Tuberculosis Status"
+9 SET APCLCUML(60)="Blood Pressure Control - based on mean of last 3 bp's"
+10 SET APCLCUML(80)="Tobacco use"
+11 SET APCLCUML(90)="DIABETES TREATMENT"
+12 SET APCLCUML(100)="ANTIPLATELET THERAPY"
+13 SET APCLCUML(110)="ACE INHIBITOR (OR ARB) USE"
+14 SET APCLCUML(115)="LIPID LOWERING AGENT USE"
+15 SET APCLCUML(300)="Depression on Problem List or as POVs"
+16 SET APCLCUML(301)="Depression Screening?"
+17 ;
PROCESS ;
+1 SET APCLPD=0
FOR
SET APCLPD=$ORDER(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD))
IF APCLPD'=+APCLPD
QUIT
DO CUML1
+2 QUIT
+3 ;
CUML1 ;
GENDER ;
+1 ;gender APCLCUML(10)="Gender^total^females^males"
+2 SET $PIECE(APCLCUML(10),U,2)=$PIECE(APCLCUML(10),U,2)+1
+3 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,20))
+4 SET P=$SELECT($EXTRACT(V)="F":3,$EXTRACT(V)="M":4,1:5)
+5 SET $PIECE(APCLCUML(10),U,P)=$PIECE(APCLCUML(10),U,P)+1
AGE ;
+1 SET V=$$AGE^AUPNPAT(APCLPD,APCLADAT)
+2 ;APCLCUML(20)="Age^total^<15^15-44^45-64^>65^unknown"
+3 SET $PIECE(APCLCUML(20),U,2)=$PIECE(APCLCUML(20),U,2)+1
+4 SET P=$SELECT(V<15:3,V>14&(V<45):4,V>44&(V<65):5,V>64:6,1:7)
+5 SET $PIECE(APCLCUML(20),U,P)=$PIECE(APCLCUML(20),U,P)+1
TYPE ;
+1 ;APCLCUML(25)="Total^Type 1^Type 2"
+2 SET X=$$TYPE^APCLD816(APCLPD,APCLDMRG,APCLADAT)
+3 SET $PIECE(APCLCUML(25),U,2)=$PIECE(APCLCUML(25),U,2)+1
+4 SET P=$SELECT(X="":5,X=1:3,X=2:4,1:5)
+5 SET $PIECE(APCLCUML(25),U,P)=$PIECE(APCLCUML(25),U,P)+1
DURDMC ;
+1 ;APCLCUML(30)="Duration of Diabetes^total^<10^10 or more^do date of dx on problem list or cms register"
+2 SET $PIECE(APCLCUML(30),U,2)=$PIECE(APCLCUML(30),U,2)+1
+3 SET V=$$DURDM^APCLD814(APCLPD,APCLDMRG,APCLADAT)
+4 SET P=$SELECT(V="":5,V<10:3,V>9:4,1:5)
+5 SET $PIECE(APCLCUML(30),U,P)=$PIECE(APCLCUML(30),U,P)+1
BMI ;
+1 ;APCLCUML(40)="Weight Control (BMI) - does not add up to 100%^total^total^overweight^obese^height or weight missing"
+2 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,112))
+3 SET $PIECE(APCLCUML(40),U,2)=$PIECE(APCLCUML(40),U,2)+1
+4 Begin DoDot:1
+5 IF V=""
SET $PIECE(APCLCUML(40),U,5)=$PIECE(APCLCUML(40),U,5)+1
QUIT
+6 IF $$OW^APCLD814(APCLPD,V,APCLADAT)
SET $PIECE(APCLCUML(40),U,3)=$PIECE(APCLCUML(40),U,3)+1
QUIT
+7 IF $$OB^APCLD814(APCLPD,V,APCLADAT)
SET $PIECE(APCLCUML(40),U,4)=$PIECE(APCLCUML(40),U,4)+1
QUIT
+8 SET $PIECE(APCLCUML(40),U,6)=$PIECE(APCLCUML(40),U,6)+1
QUIT
End DoDot:1
HGB ;
+1 ;use last hgba1c value only
+2 ;APCLCUML(50)=
+3 SET $PIECE(APCLCUML(50),U,2)=$PIECE(APCLCUML(50),U,2)+1
+4 SET V=$PIECE($GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,78)),U)
+5 ;S V=$$STV^APCLD818(V,4)
+6 SET P=$SELECT(V="":9,V[">":8,$EXTRACT(V)'=+$EXTRACT(V):9,V<7.0:3,V>6.9&(V<8.0):4,V>7.9&(V<9.0):5,V>8.9&(V<10.0):6,V<11.0&(V>9.9):7,V>10.9:8,1:9)
+7 SET $PIECE(APCLCUML(50),U,P)=$PIECE(APCLCUML(50),U,P)+1
BPC ;blood pressure control
+1 ;take last 3 bp's and get mean systolic and mean diastolic
+2 SET $PIECE(APCLCUML(60),U,2)=$PIECE(APCLCUML(60),U,2)+1
+3 SET S=$$SYSMEAN(APCLPD,APCLRBD,APCLRED)
+4 SET D=$$DIAMEAN(APCLPD,APCLRBD,APCLRED)
+5 Begin DoDot:1
+6 IF S=""!(D="")
SET $PIECE(APCLCUML(60),U,8)=$PIECE(APCLCUML(60),U,8)+1
QUIT
+7 IF S<120&(D<70)
SET $PIECE(APCLCUML(60),U,3)=$PIECE(APCLCUML(60),U,3)+1
QUIT
+8 IF S<130&(D<80)
SET $PIECE(APCLCUML(60),U,4)=$PIECE(APCLCUML(60),U,4)+1
QUIT
+9 IF S<140&(D<90)
SET $PIECE(APCLCUML(60),U,5)=$PIECE(APCLCUML(60),U,5)+1
QUIT
+10 IF S<160&(D<95)
SET $PIECE(APCLCUML(60),U,6)=$PIECE(APCLCUML(60),U,6)+1
QUIT
+11 SET $PIECE(APCLCUML(60),U,7)=$PIECE(APCLCUML(60),U,7)+1
End DoDot:1
TBSTAT ;
+1 SET $PIECE(APCLCUML(70),U,2)=$PIECE(APCLCUML(70),U,2)+1
+2 SET V=$$TBCODE^APCLD816(APCLPD,APCLRED,APCLDMRG)
+3 SET $PIECE(APCLCUML(70),U,(V+2))=$PIECE(APCLCUML(70),U,(V+2))+1
TOBACCO ;
+1 SET $PIECE(APCLCUML(80),U,2)=$PIECE(APCLCUML(80),U,2)+1
+2 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,27))
+3 SET V1=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,28))
+4 IF +V=1
SET $PIECE(APCLCUML(80),U,3)=$PIECE(APCLCUML(80),U,3)+1
SET P=$SELECT($EXTRACT(V1)="Y":4,$EXTRACT(V1)="N":5,1:5)
SET $PIECE(APCLCUML(80),U,P)=$PIECE(APCLCUML(80),U,P)+1
+5 IF +V=2
SET $PIECE(APCLCUML(80),U,6)=$PIECE(APCLCUML(80),U,6)+1
+6 IF +V=3
SET $PIECE(APCLCUML(80),U,7)=$PIECE(APCLCUML(80),U,7)+1
DMTX ;diabetes treatment
+1 SET APCL6MBD=$$FMADD^XLFDT(APCLADAT,-(6*31))
SET APCL6MBD=$$FMTE^XLFDT(APCL6MBD)
+2 SET $PIECE(APCLCUML(90),U,2)=$PIECE(APCLCUML(90),U,2)+1
+3 SET V=$$THERAPY^APCLD816(APCLPD,APCL6MBD,APCLRED)
+4 IF V=1
SET $PIECE(APCLCUML(90),U,3)=$PIECE(APCLCUML(90),U,3)+1
+5 IF V=9
SET $PIECE(APCLCUML(90),U,11)=$PIECE(APCLCUML(90),U,11)+1
+6 ;I $L(V)=1 S P=$S(V=2:4,V=3:5,V=4:6,V=5:7,V=6:8,1:"") S $P(APCLCUML(90),U,P)=$P(APCLCUML(90),U,P)+1 ;cmi/maw 12/26/2007 orig line
+7 ;I $L(V)=1 S P=$S(V=2:4,V=3:5,V=4:6,V=5:7,V=6:8,V=7:12,V=8:13,1:"") S $P(APCLCUML(90),U,P)=$P(APCLCUML(90),U,P)+1 ;cmi/maw 12/26/2007 DM2008
+8 NEW I
+9 FOR I=1:1:$LENGTH(V)
Begin DoDot:1
+10 NEW Q
+11 SET Q=$EXTRACT(V,I,I)
+12 ;cmi/maw 4/2/2008 modified for incretin/dpp4 per gary
SET P=$SELECT(Q=2:4,Q=3:5,Q=4:6,Q=5:7,Q=6:8,Q=7:13,Q=8:12,1:"")
SET $PIECE(APCLCUML(90),U,P)=$PIECE(APCLCUML(90),U,P)+1
End DoDot:1
+13 IF $LENGTH(V)>1
IF V["2"
SET $PIECE(APCLCUML(90),U,10)=$PIECE(APCLCUML(90),U,10)+1
+14 IF $LENGTH(V)>1
IF V'[2
SET $PIECE(APCLCUML(90),U,9)=$PIECE(APCLCUML(90),U,9)+1
ASPIRIN ;
+1 ;only tally if patient is 30 and older
+2 IF $$AGE^AUPNPAT(APCLPD,APCLADAT)<30
GOTO ACE
+3 SET $PIECE(APCLCUML(100),U,2)=$PIECE(APCLCUML(100),U,2)+1
+4 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,62))
+5 SET P=$SELECT($EXTRACT(V)="A":3,$EXTRACT(V)="R":7,$EXTRACT(V)="N":6,1:6)
+6 SET $PIECE(APCLCUML(100),U,P)=$PIECE(APCLCUML(100),U,P)+1
ACE ;110 title^total pts^total pts with protein^# of those on ace^# with htn^# of those on ace"
+1 SET $PIECE(APCLCUML(110),U,2)=$PIECE(APCLCUML(110),U,2)+1
+2 ;set 3rd piece with # with proteinuria
+3 ;01/09/08
SET P=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,91))
+4 ;S P=$G(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,94))
+5 SET H=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,34))
+6 SET A=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,60))
+7 ;cmi/maw 3/26/2008 convert to 300 if it contains a > signaling overt
IF $PIECE(P,U,2)[">"
SET $PIECE(P,U,2)=300
+8 ;01/09/08
IF $EXTRACT(P)]""
IF $PIECE(P,U,2)>299.9
SET $PIECE(APCLCUML(110),U,3)=$PIECE(APCLCUML(110),U,3)+1
IF $EXTRACT(A)="Y"
IF +$PIECE(P,U,2)>299.9
SET $PIECE(APCLCUML(110),U,4)=$PIECE(APCLCUML(110),U,4)+1
+9 ;I $E(P)="Y" S $P(APCLCUML(110),U,3)=$P(APCLCUML(110),U,3)+1 I $E(A)="Y" S $P(APCLCUML(110),U,4)=$P(APCLCUML(110),U,4)+1
+10 IF $EXTRACT(H)="Y"
SET $PIECE(APCLCUML(110),U,5)=$PIECE(APCLCUML(110),U,5)+1
IF $EXTRACT(A)="Y"
SET $PIECE(APCLCUML(110),U,6)=$PIECE(APCLCUML(110),U,6)+1
LIPID ;115
+1 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,61))
+2 SET L=$$LDL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
SET L=$PIECE(L,U)
+3 SET T=$$CHOL^APCLD818(APCLPD,APCLBDAT,APCLADAT,"I")
SET T=$PIECE(T,U)
+4 IF T]""
IF T'<240
SET $PIECE(APCLCUML(115),U,3)=$PIECE(APCLCUML(115),U,3)+1
IF "SOB"[$EXTRACT(V)
SET $PIECE(APCLCUML(115),U,4)=$PIECE(APCLCUML(115),U,4)+1
+5 IF L]""
IF L>100
SET $PIECE(APCLCUML(115),U,5)=$PIECE(APCLCUML(115),U,5)+1
IF "SOB"[$EXTRACT(V)
SET $PIECE(APCLCUML(115),U,6)=$PIECE(APCLCUML(115),U,6)+1
+6 ;lipid agents
+7 ;7 - all w/agent 8 - all with statin only 9 - all with non-statin 10 - both.fx
+8 IF "SOB"[$EXTRACT(V)
SET $PIECE(APCLCUML(115),U,7)=$PIECE(APCLCUML(115),U,7)+1
+9 IF $EXTRACT(V)="S"
SET $PIECE(APCLCUML(115),U,8)=$PIECE(APCLCUML(115),U,8)+1
+10 IF $EXTRACT(V)="O"
SET $PIECE(APCLCUML(115),U,9)=$PIECE(APCLCUML(115),U,9)+1
+11 IF $EXTRACT(V)="B"
SET $PIECE(APCLCUML(115),U,10)=$PIECE(APCLCUML(115),U,10)+1
+12 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(115),U,11)=$PIECE(APCLCUML(115),U,11)+1
DEP ;
+1 SET $PIECE(APCLCUML(300),U,2)=$PIECE(APCLCUML(300),U,2)+1
+2 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,200))
+3 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(300),U,3)=$PIECE(APCLCUML(300),U,3)+1
+4 IF $EXTRACT(V)'="Y"
SET $PIECE(APCLCUML(301),U,2)=$PIECE(APCLCUML(301),U,2)+1
Begin DoDot:1
+5 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,210))
+6 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(301),U,3)=$PIECE(APCLCUML(301),U,3)+1
+7 IF $EXTRACT(V)="N"
SET $PIECE(APCLCUML(301),U,4)=$PIECE(APCLCUML(301),U,4)+1
+8 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(301),U,5)=$PIECE(APCLCUML(301),U,5)+1
End DoDot:1
EXAMS ;
+1 IF '$DATA(APCLCUML(120))
SET APCLCUML(120)="EXAMS - Yearly"
+2 SET $PIECE(APCLCUML(120),U,2)=$PIECE(APCLCUML(120),U,2)+1
+3 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,38))
+4 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(120),U,3)=$PIECE(APCLCUML(120),U,3)+1
+5 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(120),U,6)=$PIECE(APCLCUML(120),U,6)+1
+6 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,40))
+7 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(120),U,4)=$PIECE(APCLCUML(120),U,4)+1
+8 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(120),U,7)=$PIECE(APCLCUML(120),U,7)+1
+9 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,42))
+10 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(120),U,5)=$PIECE(APCLCUML(120),U,5)+1
+11 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(120),U,8)=$PIECE(APCLCUML(120),U,8)+1
+12 IF $PIECE(^DPT(APCLPD,0),U,2)="F"
SET $PIECE(APCLCUML(120),U,9)=$PIECE(APCLCUML(120),U,9)+1
+13 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,108))
+14 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(120),U,10)=$PIECE(APCLCUML(120),U,10)+1
+15 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(120),U,11)=$PIECE(APCLCUML(120),U,11)+1
EDUC ;
+1 IF '$DATA(APCLCUML(130))
SET APCLCUML(130)="DIABETES-RELATED EDUCATION - Yearly"
+2 SET $PIECE(APCLCUML(130),U,2)=$PIECE(APCLCUML(130),U,2)+1
+3 SET G=0
SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,44))
+4 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(130),U,3)=$PIECE(APCLCUML(130),U,3)+1
SET G=1
+5 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(130),U,7)=$PIECE(APCLCUML(130),U,7)+1
+6 IF $GET(V)="Yes (RD)"
SET $PIECE(APCLCUML(130),U,10)=$PIECE(APCLCUML(130),U,10)+1
SET G=1
+7 ;cmi/maw 1/15/08
IF $GET(V)="Yes (RD & Non RD - Other)"
SET $PIECE(APCLCUML(130),U,10)=$PIECE(APCLCUML(130),U,10)+1
SET G=1
+8 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,46))
+9 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(130),U,4)=$PIECE(APCLCUML(130),U,4)+1
SET G=1
+10 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(130),U,8)=$PIECE(APCLCUML(130),U,8)+1
+11 SET V=$GET(^XTMP("APCLDM81",APCLJOB,APCLBTH,"AUDIT",APCLPD,48))
+12 IF $EXTRACT(V)="R"
SET $PIECE(APCLCUML(130),U,9)=$PIECE(APCLCUML(130),U,9)+1
+13 IF $EXTRACT(V)="Y"
SET $PIECE(APCLCUML(130),U,5)=$PIECE(APCLCUML(130),U,5)+1
SET G=1
+14 IF G
SET $PIECE(APCLCUML(130),U,6)=$PIECE(APCLCUML(130),U,6)+1
+15 DO ^APCLD811
+16 QUIT
SYSMEAN(P,BDATE,EDATE) ;EP
+1 NEW X
SET X=$$BPS^APCLD813(P,BDATE,EDATE,"I")
+2 IF X=""
QUIT ""
+3 NEW Y,C
SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C'=3
QUIT ""
+5 SET C=0
FOR Y=1:1:3
SET C=$PIECE($PIECE(X,";",Y),"/")+C
+6 QUIT C\3
+7 QUIT ""
DIAMEAN(P,BDATE,EDATE) ;EP
+1 NEW X
SET X=$$BPS^APCLD813(P,BDATE,EDATE,"I")
+2 IF X=""
QUIT ""
+3 NEW Y,C
SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C'=3
QUIT ""
+5 SET C=0
FOR Y=1:1:3
SET C=$PIECE($PIECE(X,";",Y),"/",2)+C
+6 QUIT C\3
