APCLD610 ; IHS/CMI/LAB -IHS -GETS DATA FOR DIABETES QA REPORT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
EN ; - ENTRY POINT - from ^APCLASK
K ^APCLDATA("APCLEPI",$J)
S ^XTMP("APCLDM61",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^DM AUDIT 2006"
S APCLEPIN=0
S APCLPD=0 F S APCLPD=$O(^XTMP("APCLDM61",APCLJOB,APCLBTH,"PATS",APCLPD)) Q:'APCLPD D
.I APCLTYPE'="P",APCLTYPE'="S" Q:$$DEMO^APCLUTL(APCLPD,$G(APCLDEMO))
.I APCLPREP=2 D EPIREC Q
.D GATHER
I APCLPREP=2 D WRITEF^APCLD61 Q
I APCLPREP=3!(APCLPREP=4) D CUML^APCLD615
Q
S(P,I,V) ;
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",P,I)=V
Q
REC(DFN,APCLRTYP,APCLRBD,APCLRED,APCLED,APCLDMRG,APCLBDAT) ;EP - called to send back a visit record as
NEW APCLX,APCLREC
S APCLREC=""
S APCLRTYP("IEN")=$O(^APCLRECD("B",APCLRTYP,0))
I 'APCLRTYP("IEN") Q APCLREC
PROC ;
S APCLEPIX=0
F S APCLEPIX=$O(^APCLRECD(APCLRTYP("IEN"),11,"AC",APCLEPIX)) Q:APCLEPIX'=+APCLEPIX!(APCLREC=-1) S APCLTTT=$O(^APCLRECD(APCLRTYP("IEN"),11,"AC",APCLEPIX,0)) D
.S X="" X:$D(^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,11)) ^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,11)
.S $E(APCLREC,$P(^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,0),U,2))=X ;W !,APCLTTT,?5,$P(^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,0),U),?40,X
Q APCLREC
EPIREC ;create epi info record in ^APCLDATA("APCLEPI",$J,n)
S APCLEPIR="",APCLEPIR=$$REC(APCLPD,"DM AUDIT 2006 EPI REC 1",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT),APCLEPIN=APCLEPIN+1,^APCLDATA("APCLEPI",$J,APCLEPIN)=APCLEPIR
S APCLTHER="",APCLEPIR="",APCLEPIR=$$REC(APCLPD,"DM AUDIT 2006 EPI REC 2",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT),APCLEPIN=APCLEPIN+1,^APCLDATA("APCLEPI",$J,APCLEPIN)=APCLEPIR
S APCLEPIR="",APCLEPIR=$$REC(APCLPD,"DM AUDIT 2006 EPI REC 3",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT),APCLEPIN=APCLEPIN+1,^APCLDATA("APCLEPI",$J,APCLEPIN)=APCLEPIR
;S APCLEPIR="",APCLEPIR=$$REC(APCLPD,"DM AUDIT 2006 EPI REC 4",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT),APCLEPIN=APCLEPIN+1,^APCLDATA("APCLEPI",$J,APCLEPIN)=APCLEPIR
Q
GATHER ;gather data for 1 patient
S APCLER=0
;set report dates
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,1)=$S($G(APCLFISC)]"":APCLFISC,1:APCLRBD_" - "_APCLRED)
;set audit date to DT
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,2)=$$FMTE^XLFDT(DT)
;set area, su, facility code and name
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,4)=$P(^DIC(4,DUZ(2),0),U)
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,6)=$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,8)=$E($P(^AUTTLOC(DUZ(2),0),U,10),3,4)
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,10)=$E($P(^AUTTLOC(DUZ(2),0),U,10),5,6)
;# pats in register
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,12)=$S(APCLDMRG:$$RSTAT^APCLDM6(APCLDMRG,"A"),1:"")
;reviewer
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,14)=$P(^VA(200,DUZ,0),U,2)
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,15)=$$VAL^XBDIQ1(9000001,APCLPD,.14)
DEMO ;pat demographics
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,16)=$$HRN^AUPNPAT(APCLPD,DUZ(2))
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,18)=$$DOB^AUPNPAT(APCLPD,"E")
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,20)=$$VAL^XBDIQ1(2,APCLPD,.02)
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,120)=$$TRIBE(APCLPD)
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,121)=$$COMM(APCLPD)
DXDT ;dates of and dm dxs
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,22)=$S(APCLDMRG:$$CMSFDX^APCLD613(APCLPD,APCLDMRG,"D"),1:"")
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)=$S(APCLDMRG:$$CMSFDX^APCLD613(APCLPD,APCLDMRG,"DX"),1:"")
S ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,23)=$$PLDMDOO^APCLD613(APCLPD)
D S(APCLPD,25,$$PLDMDXS^APCLD613(APCLPD))
D S(APCLPD,21,$$FRSTDMDX^APCLD613(APCLPD))
D S(APCLPD,26,$$LASTDMDX^APCLD613(APCLPD,APCLRED))
D S(APCLPD,27,$$TOBACCO^APCLD616(APCLPD,APCLRED))
S APCLTYDM="" D TYPEDM,S(APCLPD,29,APCLTYDM)
D S(APCLPD,28,$$CESS^APCLD611(APCLPD,APCLRBD,APCLRED))
VITAL ;
D S(APCLPD,30,$$LASTHT^APCLD613(APCLPD,APCLRED))
D S(APCLPD,32,$$LASTWT^APCLD613(APCLPD,APCLRED))
;htn dx
D S(APCLPD,34,$$HTNDX^APCLD613(APCLPD,APCLRED))
;last 3 BPs
D S(APCLPD,36,$$BPS^APCLD613(APCLPD,APCLRBD,APCLRED))
EXAMS ;
D S(APCLPD,38,$$DFE^APCLD617(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,40,$$EYE^APCLD617(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,42,$$DENTAL^APCLD617(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,44,$$DIETEDUC^APCLD617(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,46,$$EXEDUC^APCLD617(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,48,$$OTHEDUC^APCLD617(APCLPD,APCLRBD,APCLRED))
THERAPY ;
S APCL6MBD=$$FMADD^XLFDT(APCLADAT,-(6*31)),APCL6MBD=$$FMTE^XLFDT(APCL6MBD)
D S(APCLPD,52,$$INSULIN^APCLD612(APCLPD,APCL6MBD,APCLRED))
D S(APCLPD,53,$$SULF^APCLD612(APCLPD,APCL6MBD,APCLRED))
D S(APCLPD,54,$$MET^APCLD612(APCLPD,APCL6MBD,APCLRED))
D S(APCLPD,55,$$ACAR^APCLD612(APCLPD,APCL6MBD,APCLRED))
D S(APCLPD,56,$$TROG^APCLD612(APCLPD,APCL6MBD,APCLRED))
S Y=$$REFMED^APCLD612(APCLPD,APCLRBD,APCLRED) S Y=$S(Y="":"",1:"X"_U_$P(Y,U,2)) D S(APCLPD,57,Y)
S Y=0 F X=52:1:57 I $E(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,X))="X" S Y=1
D S(APCLPD,51,$S(Y:"",1:"X"))
D S(APCLPD,60,$$ACE^APCLD616(APCLPD,APCL6MBD,APCLRED))
IMM ;
D S(APCLPD,62,$$ASPIRIN^APCLD616(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,61,$$LIPID^APCLD616(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,64,$$FLU^APCLD613(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,66,$$PNEU^APCLD613(APCLPD,APCLRED))
D S(APCLPD,68,$$TD^APCLD61B(APCLPD,APCLRED))
PPD ;
D S(APCLPD,70,$$PPD^APCLD618(APCLPD,APCLRED))
D S(APCLPD,114,$$LASTNP^APCLD618(APCLPD,APCLRED))
D S(APCLPD,72,$$TBTX^APCLD612(APCLPD))
D S(APCLPD,76,$$EKG^APCLD612(APCLPD,APCLRED))
LABS ;
D S(APCLPD,78,$$HGBA1C^APCLD618(APCLPD,APCLBDAT,APCLADAT))
;D S(APCLPD,82,$$BS^APCLD618(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,84,$$CREAT^APCLD618(APCLPD,APCLBDAT,APCLADAT))
D S(APCLPD,86,$$CHOL^APCLD618(APCLPD,APCLBDAT,APCLADAT))
D S(APCLPD,88,$$LDL^APCLD618(APCLPD,APCLBDAT,APCLADAT))
D S(APCLPD,89,$$HDL^APCLD618(APCLPD,APCLBDAT,APCLADAT))
D S(APCLPD,90,$$TRIG^APCLD618(APCLPD,APCLBDAT,APCLADAT))
D S(APCLPD,92,$$URIN^APCLD618(APCLPD,APCLBDAT,APCLADAT))
D S(APCLPD,94,$$PROTEIN^APCLD618(APCLPD,APCLBDAT,APCLADAT))
D S(APCLPD,96,$$MICRO^APCLD618(APCLPD,APCLBDAT,APCLADAT))
;D S(APCLPD,98,$$SELF^APCLD616(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,112,$$BMI^APCLD618(APCLPD,APCLRBD,APCLRED))
D S(APCLPD,200,$$DEPDX^APCLD612(APCLPD,APCLBDAT,APCLADAT))
S APCLDEP=$E($G(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,200)))
D S(APCLPD,210,$S(APCLDEP="Y":"",1:$$DEPSCR^APCLD612(APCLPD,APCLBDAT,APCLADAT)))
;
Q
TYPEDM ;return type of DM in APCLTYDM
NEW X
I ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)="NIDDM" S APCLTYDM="2 Type 2" Q
I ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)="TYPE II" S APCLTYDM="2 Type 2" Q
I ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)[2 S APCLTYDM="2 Type 2" Q
I ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)="IDDM" S APCLTYDM="1 Type 1" Q
I ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)[1 S APCLTYDM="1 Type 1" Q
S X=^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,25) ;get problem list dxs
F I=1:1 S C=$P(X,";",I) Q:C=""!(APCLTYDM]"") I $E(C,6)=0!($E(C,6)=2) S APCLTYDM="2 Type 2"
Q:APCLTYDM]""
F I=1:1 S C=$P(X,";",I) Q:C=""!(APCLTYDM]"") I $E(C,6)=1!($E(C,6)=3) S APCLTYDM="1 Type 1"
Q:APCLTYDM]""
S X=^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,26) ;get pov list dxs
I X[2 S APCLTYDM="2 Type 2" Q
I X[1 S APCLTYDM="1 Type 1" Q
Q
DATE(D) ;EP
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+($E(D,1,3)))
TRIBE(P) ;EP
I '$G(P) Q ""
I '$D(^AUPNPAT(P,11)) Q ""
Q $$TRIBE^AUPNPAT(P,"C")_"^"_$$TRIBE^AUPNPAT(P,"E")
COMM(P) ;EP
I '$G(P) Q ""
I '$D(^AUPNPAT(P,11)) Q ""
Q $$COMMRES^AUPNPAT(P,"C")_"^"_$$COMMRES^AUPNPAT(P,"E")
EAUDIT ;EP
K ^APCLDATA("APCLEPI",$J)
S ^XTMP("APCLDM61",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^DM AUDIT 2006"
S APCLEPIN=0
S APCLBEGD=$$FMADD^XLFDT(APCLADAT,-365)
S APCL3YE=$$FMADD^XLFDT(APCLADAT,-1096)
I APCLACTI=1 D
.S APCLEAUT=0 F S APCLEAUT=$O(^ACM(41,"B",APCLDMRG,APCLEAUT)) Q:APCLEAUT'=+APCLEAUT D
..I $P($G(^ACM(41,APCLEAUT,"DT")),U,1)'="A" Q
..S APCLPD=$P(^ACM(41,APCLEAUT,0),U,2)
..Q:$$DEMO^APCLUTL(APCLPD,$G(APCLDEMO))
..S APCLX=$$ACTDMPT^APCLD61G(APCLPD,APCLBEGD,APCLADAT,APCLTAXI,APCLBEN,APCL3YE)
..I 'APCLX Q ;not active diabetic
..I APCLPREP=2 D EPIREC Q
..D GATHER
.Q
I APCLACTI=0 S APCLPD=0 F S APCLPD=$O(^AUPNPAT(APCLPD)) Q:'APCLPD D
.S APCLX=$$ACTDMPT^APCLD61G(APCLPD,APCLBEGD,APCLADAT,APCLTAXI,APCLBEN,APCL3YE)
.I 'APCLX Q ;not active diabetic
.I APCLACTI,'$$ACTONREG(APCLPD,APCLDMRG) Q
.I APCLPREP=2 D EPIREC Q
.D GATHER
I APCLPREP=2 D WRITEF^APCLD61 Q
I APCLPREP=3!(APCLPREP=4) D CUML^APCLD615
Q
ACTONREG(P,R) ;
I '$D(^ACM(41,"AC",P,R)) Q 0
S X=^ACM(41,"AC",P,R)
I $P($G(^ACM(41,X,"DT")),U,1)'="A" Q 0
Q 1
APCLD610 ; IHS/CMI/LAB -IHS -GETS DATA FOR DIABETES QA REPORT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
EN ; - ENTRY POINT - from ^APCLASK
+1 KILL ^APCLDATA("APCLEPI",$JOB)
+2 SET ^XTMP("APCLDM61",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^DM AUDIT 2006"
+3 SET APCLEPIN=0
+4 SET APCLPD=0
FOR
SET APCLPD=$ORDER(^XTMP("APCLDM61",APCLJOB,APCLBTH,"PATS",APCLPD))
IF 'APCLPD
QUIT
Begin DoDot:1
+5 IF APCLTYPE'="P"
IF APCLTYPE'="S"
IF $$DEMO^APCLUTL(APCLPD,$GET(APCLDEMO))
QUIT
+6 IF APCLPREP=2
DO EPIREC
QUIT
+7 DO GATHER
End DoDot:1
+8 IF APCLPREP=2
DO WRITEF^APCLD61
QUIT
+9 IF APCLPREP=3!(APCLPREP=4)
DO CUML^APCLD615
+10 QUIT
S(P,I,V) ;
+1 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",P,I)=V
+2 QUIT
REC(DFN,APCLRTYP,APCLRBD,APCLRED,APCLED,APCLDMRG,APCLBDAT) ;EP - called to send back a visit record as
+1 NEW APCLX,APCLREC
+2 SET APCLREC=""
+3 SET APCLRTYP("IEN")=$ORDER(^APCLRECD("B",APCLRTYP,0))
+4 IF 'APCLRTYP("IEN")
QUIT APCLREC
PROC ;
+1 SET APCLEPIX=0
+2 FOR
SET APCLEPIX=$ORDER(^APCLRECD(APCLRTYP("IEN"),11,"AC",APCLEPIX))
IF APCLEPIX'=+APCLEPIX!(APCLREC=-1)
QUIT
SET APCLTTT=$ORDER(^APCLRECD(APCLRTYP("IEN"),11,"AC",APCLEPIX,0))
Begin DoDot:1
+3 SET X=""
IF $DATA(^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,11))
XECUTE ^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,11)
+4 ;W !,APCLTTT,?5,$P(^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,0),U),?40,X
SET $EXTRACT(APCLREC,$PIECE(^APCLRECD(APCLRTYP("IEN"),11,APCLTTT,0),U,2))=X
End DoDot:1
+5 QUIT APCLREC
EPIREC ;create epi info record in ^APCLDATA("APCLEPI",$J,n)
+1 SET APCLEPIR=""
SET APCLEPIR=$$REC(APCLPD,"DM AUDIT 2006 EPI REC 1",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT)
SET APCLEPIN=APCLEPIN+1
SET ^APCLDATA("APCLEPI",$JOB,APCLEPIN)=APCLEPIR
+2 SET APCLTHER=""
SET APCLEPIR=""
SET APCLEPIR=$$REC(APCLPD,"DM AUDIT 2006 EPI REC 2",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT)
SET APCLEPIN=APCLEPIN+1
SET ^APCLDATA("APCLEPI",$JOB,APCLEPIN)=APCLEPIR
+3 SET APCLEPIR=""
SET APCLEPIR=$$REC(APCLPD,"DM AUDIT 2006 EPI REC 3",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT)
SET APCLEPIN=APCLEPIN+1
SET ^APCLDATA("APCLEPI",$JOB,APCLEPIN)=APCLEPIR
+4 ;S APCLEPIR="",APCLEPIR=$$REC(APCLPD,"DM AUDIT 2006 EPI REC 4",APCLRBD,APCLRED,APCLADAT,APCLDMRG,APCLBDAT),APCLEPIN=APCLEPIN+1,^APCLDATA("APCLEPI",$J,APCLEPIN)=APCLEPIR
+5 QUIT
GATHER ;gather data for 1 patient
+1 SET APCLER=0
+1 ;set report dates
+2 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,1)=$SELECT($GET(APCLFISC)]"":APCLFISC,1:APCLRBD_" - "_APCLRED)
+3 ;set audit date to DT
+4 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,2)=$$FMTE^XLFDT(DT)
+5 ;set area, su, facility code and name
+6 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,4)=$PIECE(^DIC(4,DUZ(2),0),U)
+7 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,6)=$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,2)
+8 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,8)=$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),3,4)
+9 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,10)=$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),5,6)
+10 ;# pats in register
+11 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,12)=$SELECT(APCLDMRG:$$RSTAT^APCLDM6(APCLDMRG,"A"),1:"")
+12 ;reviewer
+13 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,14)=$PIECE(^VA(200,DUZ,0),U,2)
+14 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,15)=$$VAL^XBDIQ1(9000001,APCLPD,.14)
DEMO ;pat demographics
+1 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,16)=$$HRN^AUPNPAT(APCLPD,DUZ(2))
+2 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,18)=$$DOB^AUPNPAT(APCLPD,"E")
+3 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,20)=$$VAL^XBDIQ1(2,APCLPD,.02)
+4 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,120)=$$TRIBE(APCLPD)
+5 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,121)=$$COMM(APCLPD)
DXDT ;dates of and dm dxs
+1 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,22)=$SELECT(APCLDMRG:$$CMSFDX^APCLD613(APCLPD,APCLDMRG,"D"),1:"")
+2 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)=$SELECT(APCLDMRG:$$CMSFDX^APCLD613(APCLPD,APCLDMRG,"DX"),1:"")
+3 SET ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,23)=$$PLDMDOO^APCLD613(APCLPD)
+4 DO S(APCLPD,25,$$PLDMDXS^APCLD613(APCLPD))
+5 DO S(APCLPD,21,$$FRSTDMDX^APCLD613(APCLPD))
+6 DO S(APCLPD,26,$$LASTDMDX^APCLD613(APCLPD,APCLRED))
+7 DO S(APCLPD,27,$$TOBACCO^APCLD616(APCLPD,APCLRED))
+8 SET APCLTYDM=""
DO TYPEDM
DO S(APCLPD,29,APCLTYDM)
+9 DO S(APCLPD,28,$$CESS^APCLD611(APCLPD,APCLRBD,APCLRED))
VITAL ;
+1 DO S(APCLPD,30,$$LASTHT^APCLD613(APCLPD,APCLRED))
+2 DO S(APCLPD,32,$$LASTWT^APCLD613(APCLPD,APCLRED))
+3 ;htn dx
+4 DO S(APCLPD,34,$$HTNDX^APCLD613(APCLPD,APCLRED))
+5 ;last 3 BPs
+6 DO S(APCLPD,36,$$BPS^APCLD613(APCLPD,APCLRBD,APCLRED))
EXAMS ;
+1 DO S(APCLPD,38,$$DFE^APCLD617(APCLPD,APCLRBD,APCLRED))
+2 DO S(APCLPD,40,$$EYE^APCLD617(APCLPD,APCLRBD,APCLRED))
+3 DO S(APCLPD,42,$$DENTAL^APCLD617(APCLPD,APCLRBD,APCLRED))
+4 DO S(APCLPD,44,$$DIETEDUC^APCLD617(APCLPD,APCLRBD,APCLRED))
+5 DO S(APCLPD,46,$$EXEDUC^APCLD617(APCLPD,APCLRBD,APCLRED))
+6 DO S(APCLPD,48,$$OTHEDUC^APCLD617(APCLPD,APCLRBD,APCLRED))
THERAPY ;
+1 SET APCL6MBD=$$FMADD^XLFDT(APCLADAT,-(6*31))
SET APCL6MBD=$$FMTE^XLFDT(APCL6MBD)
+2 DO S(APCLPD,52,$$INSULIN^APCLD612(APCLPD,APCL6MBD,APCLRED))
+3 DO S(APCLPD,53,$$SULF^APCLD612(APCLPD,APCL6MBD,APCLRED))
+4 DO S(APCLPD,54,$$MET^APCLD612(APCLPD,APCL6MBD,APCLRED))
+5 DO S(APCLPD,55,$$ACAR^APCLD612(APCLPD,APCL6MBD,APCLRED))
+6 DO S(APCLPD,56,$$TROG^APCLD612(APCLPD,APCL6MBD,APCLRED))
+7 SET Y=$$REFMED^APCLD612(APCLPD,APCLRBD,APCLRED)
SET Y=$SELECT(Y="":"",1:"X"_U_$PIECE(Y,U,2))
DO S(APCLPD,57,Y)
+8 SET Y=0
FOR X=52:1:57
IF $EXTRACT(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,X))="X"
SET Y=1
+9 DO S(APCLPD,51,$SELECT(Y:"",1:"X"))
+10 DO S(APCLPD,60,$$ACE^APCLD616(APCLPD,APCL6MBD,APCLRED))
IMM ;
+1 DO S(APCLPD,62,$$ASPIRIN^APCLD616(APCLPD,APCLRBD,APCLRED))
+2 DO S(APCLPD,61,$$LIPID^APCLD616(APCLPD,APCLRBD,APCLRED))
+3 DO S(APCLPD,64,$$FLU^APCLD613(APCLPD,APCLRBD,APCLRED))
+4 DO S(APCLPD,66,$$PNEU^APCLD613(APCLPD,APCLRED))
+5 DO S(APCLPD,68,$$TD^APCLD61B(APCLPD,APCLRED))
PPD ;
+1 DO S(APCLPD,70,$$PPD^APCLD618(APCLPD,APCLRED))
+2 DO S(APCLPD,114,$$LASTNP^APCLD618(APCLPD,APCLRED))
+3 DO S(APCLPD,72,$$TBTX^APCLD612(APCLPD))
+4 DO S(APCLPD,76,$$EKG^APCLD612(APCLPD,APCLRED))
LABS ;
+1 DO S(APCLPD,78,$$HGBA1C^APCLD618(APCLPD,APCLBDAT,APCLADAT))
+2 ;D S(APCLPD,82,$$BS^APCLD618(APCLPD,APCLRBD,APCLRED))
+3 DO S(APCLPD,84,$$CREAT^APCLD618(APCLPD,APCLBDAT,APCLADAT))
+4 DO S(APCLPD,86,$$CHOL^APCLD618(APCLPD,APCLBDAT,APCLADAT))
+5 DO S(APCLPD,88,$$LDL^APCLD618(APCLPD,APCLBDAT,APCLADAT))
+6 DO S(APCLPD,89,$$HDL^APCLD618(APCLPD,APCLBDAT,APCLADAT))
+7 DO S(APCLPD,90,$$TRIG^APCLD618(APCLPD,APCLBDAT,APCLADAT))
+8 DO S(APCLPD,92,$$URIN^APCLD618(APCLPD,APCLBDAT,APCLADAT))
+9 DO S(APCLPD,94,$$PROTEIN^APCLD618(APCLPD,APCLBDAT,APCLADAT))
+10 DO S(APCLPD,96,$$MICRO^APCLD618(APCLPD,APCLBDAT,APCLADAT))
+11 ;D S(APCLPD,98,$$SELF^APCLD616(APCLPD,APCLRBD,APCLRED))
+12 DO S(APCLPD,112,$$BMI^APCLD618(APCLPD,APCLRBD,APCLRED))
+13 DO S(APCLPD,200,$$DEPDX^APCLD612(APCLPD,APCLBDAT,APCLADAT))
+14 SET APCLDEP=$EXTRACT($GET(^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,200)))
+15 DO S(APCLPD,210,$SELECT(APCLDEP="Y":"",1:$$DEPSCR^APCLD612(APCLPD,APCLBDAT,APCLADAT)))
+16 ;
+17 QUIT
TYPEDM ;return type of DM in APCLTYDM
+1 NEW X
+2 IF ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)="NIDDM"
SET APCLTYDM="2 Type 2"
QUIT
+3 IF ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)="TYPE II"
SET APCLTYDM="2 Type 2"
QUIT
+4 IF ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)[2
SET APCLTYDM="2 Type 2"
QUIT
+5 IF ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)="IDDM"
SET APCLTYDM="1 Type 1"
QUIT
+6 IF ^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,24)[1
SET APCLTYDM="1 Type 1"
QUIT
+7 ;get problem list dxs
SET X=^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,25)
+8 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(APCLTYDM]"")
QUIT
IF $EXTRACT(C,6)=0!($EXTRACT(C,6)=2)
SET APCLTYDM="2 Type 2"
+9 IF APCLTYDM]""
QUIT
+10 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(APCLTYDM]"")
QUIT
IF $EXTRACT(C,6)=1!($EXTRACT(C,6)=3)
SET APCLTYDM="1 Type 1"
+11 IF APCLTYDM]""
QUIT
+12 ;get pov list dxs
SET X=^XTMP("APCLDM61",APCLJOB,APCLBTH,"AUDIT",APCLPD,26)
+13 IF X[2
SET APCLTYDM="2 Type 2"
QUIT
+14 IF X[1
SET APCLTYDM="1 Type 1"
QUIT
+15 QUIT
DATE(D) ;EP
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+($EXTRACT(D,1,3)))
TRIBE(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNPAT(P,11))
QUIT ""
+3 QUIT $$TRIBE^AUPNPAT(P,"C")_"^"_$$TRIBE^AUPNPAT(P,"E")
COMM(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNPAT(P,11))
QUIT ""
+3 QUIT $$COMMRES^AUPNPAT(P,"C")_"^"_$$COMMRES^AUPNPAT(P,"E")
EAUDIT ;EP
+1 KILL ^APCLDATA("APCLEPI",$JOB)
+2 SET ^XTMP("APCLDM61",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^DM AUDIT 2006"
+3 SET APCLEPIN=0
+4 SET APCLBEGD=$$FMADD^XLFDT(APCLADAT,-365)
+5 SET APCL3YE=$$FMADD^XLFDT(APCLADAT,-1096)
+6 IF APCLACTI=1
Begin DoDot:1
+7 SET APCLEAUT=0
FOR
SET APCLEAUT=$ORDER(^ACM(41,"B",APCLDMRG,APCLEAUT))
IF APCLEAUT'=+APCLEAUT
QUIT
Begin DoDot:2
+8 IF $PIECE($GET(^ACM(41,APCLEAUT,"DT")),U,1)'="A"
QUIT
+9 SET APCLPD=$PIECE(^ACM(41,APCLEAUT,0),U,2)
+10 IF $$DEMO^APCLUTL(APCLPD,$GET(APCLDEMO))
QUIT
+11 SET APCLX=$$ACTDMPT^APCLD61G(APCLPD,APCLBEGD,APCLADAT,APCLTAXI,APCLBEN,APCL3YE)
+12 ;not active diabetic
IF 'APCLX
QUIT
+13 IF APCLPREP=2
DO EPIREC
QUIT
+14 DO GATHER
End DoDot:2
+15 QUIT
End DoDot:1
+16 IF APCLACTI=0
SET APCLPD=0
FOR
SET APCLPD=$ORDER(^AUPNPAT(APCLPD))
IF 'APCLPD
QUIT
Begin DoDot:1
+17 SET APCLX=$$ACTDMPT^APCLD61G(APCLPD,APCLBEGD,APCLADAT,APCLTAXI,APCLBEN,APCL3YE)
+18 ;not active diabetic
IF 'APCLX
QUIT
+19 IF APCLACTI
IF '$$ACTONREG(APCLPD,APCLDMRG)
QUIT
+20 IF APCLPREP=2
DO EPIREC
QUIT
+21 DO GATHER
End DoDot:1
+22 IF APCLPREP=2
DO WRITEF^APCLD61
QUIT
+23 IF APCLPREP=3!(APCLPREP=4)
DO CUML^APCLD615
+24 QUIT
ACTONREG(P,R) ;
+1 IF '$DATA(^ACM(41,"AC",P,R))
QUIT 0
+2 SET X=^ACM(41,"AC",P,R)
+3 IF $PIECE($GET(^ACM(41,X,"DT")),U,1)'="A"
QUIT 0
+4 QUIT 1
