APCLDR2 ; IHS/CMI/LAB - patients w/o dm on problem list ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;
START ;
D INFORM
D EXIT
D GETINFO
I $D(APCLQUIT) D EXIT Q
Q
INFORM ;
W:$D(IOF) @IOF
W !,$$CTR($$LOC)
W !,$$CTR($$USR)
W !!,"This report will list patients who are on the Diabetes Register who do not",!,"have a date of diagnosis recorded in either the Register or on the problem list.",!!
Q
;
GETINFO ;
S (APCLTR,APCLREG,APCLSTAT,APCLND)=""
D R
S APCLTR="R" I $D(APCLQUIT) D EXIT Q
D ZIS
Q
R ;
S APCLREG=""
S DIC="^ACM(41.1,",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Register: " D ^DIC
I Y=-1 W !,"No register selected." S APCLQUIT="" Q
S APCLREG=+Y
;get status
S APCLSTAT=""
S DIR(0)="Y",DIR("A")="Do you want to select register patients with a particular status",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G R
I Y=0 S APCLSTAT="" Q
;which status
S DIR(0)="9002241,1",DIR("A")="Which status",DIR("B")="A" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G R
S APCLSTAT=Y
Q
ZIS ;call to XBDBQUE
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G R
S XBRP="PRINT^APCLDR2",XBRC="PROC^APCLDR2",XBRX="EXIT^APCLDR2",XBNS="APCL"
D ^XBDBQUE
D EXIT
Q
EXIT ;clean up and exit
D EN^XBVK("APCL")
D ^XBFMK
D KILL^AUPNPAT
Q
PROC ;EP - called from XBDBQUE
S APCLJOB=$J,APCLBTH=$H
K ^XTMP("APCLDR2",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLDR2","DM NOT ON PROBLEM LIST")
I APCLTR="R" D REGPROC Q
Q
LASTDMDX(P) ;
I '$G(P) Q ""
NEW X,E,APCL,Y
S Y="APCL("
S X=P_"^LAST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y)
I $D(APCL(1)) Q $P(APCL(1),U)
Q ""
;
NUMDXS(P) ;
I '$G(P) Q ""
NEW X,E,APCL,Y
S Y="APCL("
S X=P_"^ALL DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y)
S (X,Y)=0
F S X=$O(APCL(X)) Q:X'=+X S Y=Y+1
Q Y
;
REGPROC ;
;$o through register, check status, if no DM on problem list
;set xtmp
;gather up patients from register in ^XTMP
S X=0 F S X=$O(^ACM(41,"B",APCLREG,X)) Q:X'=+X D
.I APCLSTAT]"",$P($G(^ACM(41,X,"DT")),U,1)=APCLSTAT S DFN=$P(^ACM(41,X,0),U,2) D CHKSET Q
.I APCLSTAT="" S DFN=$P(^ACM(41,X,0),U,2) D CHKSET Q
.Q
Q
CHKSET ;
Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
I $$DODX^APCLD206(DFN,APCLREG,"E")]"" Q
Q:$$DOD^AUPNPAT(DFN)]""
Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)]"" ;IHS/CMI/GRL
Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)="" ;IHS/CMI/GRL
S APCLPLDX=$$DMPROB(DFN)
S ^XTMP("APCLDR2",APCLJOB,APCLBTH,"PATIENTS",$P(^DPT(DFN,0),U),DFN)=$$LASTDMDX(DFN)_U_$$NUMDXS(DFN)_U_APCLPLDX
Q
DMPROB(P) ;is DM on problem list 1=yes 0=no
I '$G(P) Q 0
I '$D(^AUPNPROB("AC",P)) Q 0
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q ""
NEW G,D,Y,I S D="",(Y,G)=0 F S Y=$O(^AUPNPROB("AC",P,Y)) Q:Y'=+Y!(G) D
.S I=$P(^AUPNPROB(Y,0),U)
.I $$ICD^ATXAPI(I,T,9) S G=1
.Q
Q G
PRINT ;EP - called from xbdbque
S APCL80D="-------------------------------------------------------------------------------"
S APCLPG=0,APCLIOSL=$S($G(APCLGUI):55,1:IOSL)
D HEAD
I '$D(^XTMP("APCLDR2",APCLJOB,APCLBTH)) W !!,"NO PATIENTS TO REPORT" G DONE
S APCLNAME="" K APCLQ
F S APCLNAME=$O(^XTMP("APCLDR2",APCLJOB,APCLBTH,"PATIENTS",APCLNAME)) Q:APCLNAME=""!($D(APCLQ)) D
.S DFN="" F S DFN=$O(^XTMP("APCLDR2",APCLJOB,APCLBTH,"PATIENTS",APCLNAME,DFN)) Q:DFN=""!($D(APCLQ)) S APCLX=^XTMP("APCLDR2",APCLJOB,APCLBTH,"PATIENTS",APCLNAME,DFN) D
..I $Y>(APCLIOSL-4) D HEAD Q:$D(APCLQ)
..W !,$E(APCLNAME,1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$DOB^AUPNPAT(DFN,"E"),?43,$P(^DPT(DFN,0),U,2),?47,$$FMTE^XLFDT($P(APCLX,U)),?63,$P(APCLX,U,2),?73,$S($P(APCLX,U,3):"YES",1:"NO")
DONE ;
I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report. HIT RETURN" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
W:$D(IOF) @IOF
K ^XTMP("APCLDR2",APCLJOB,APCLBTH),APCLJOB,APCLBTH
Q
HEAD I 'APCLPG G HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQ="" Q
HEAD1 ;
W:$D(IOF) @IOF S APCLPG=APCLPG+1
I $G(APCLGUI),APCLPG'=1 W !,"ZZZZZZZ"
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!
W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
W $$CTR("DIABETES REGISTER PATIENTS WITH NO RECORDED DATE OF ONSET OF DIABETES",80),!
I APCLTR="R" W $$CTR("Patients on the "_$P(^ACM(41.1,APCLREG,0),U)_" Register",80),!
I APCLTR="D" W $$CTR("Patients w/at least "_APCLND_" diabetes diagnoses",80),!
PIH W !,"PATIENT NAME",?22,"HRN",?29,"DOB",?47,"LAST DM DX",?63,"#DM DXS",?71,"DM ON PL",!,APCL80D
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
BDMGO(APCLTR,APCLREG,APCLSTAT) ;EP - GUI DMS Entry Point
;cmi/anch/maw added 10/19/2004
S APCLGUI=1
D PROC
D GUIR^XBLM("PRINT^APCLDR2","^TMP($J,""APCLDR2"",")
D EXIT
Q
;
TEST ;
D BDMG("R",1,"A")
Q
BDMG(APCLTR,APCLREG,APCLSTAT) ;EP - GUI DMS Entry Point
S APCLTR="R",APCLGUI=1
NEW APCLNOW,APCLOPT,APCLIEN
S APCLOPT="DM Register Pts w/no recorded DM Date of Onset"
D NOW^%DTC
S APCLNOW=$G(%)
K DD,DO,DIC
S X=DUZ_APCLNOW
S DIC("DR")=".02////"_DUZ_";.03////"_APCLNOW_";.06///"_$G(APCLOPT)_";.07////R"
S DIC="^APCLGUIR(",DIC(0)="L",DIADD=1,DLAYGO=9001004.4
D FILE^DICN
K DIADD,DLAYGO,DIC,DA
I Y=-1 S APCLIEN=-1 Q
S APCLIEN=+Y
S BDMGIEN=APCLIEN ;cmi/maw added
D ^XBFMK
K ZTSAVE S ZTSAVE("*")=""
;D GUIEP for interactive testing
S ZTIO="",ZTDTH=$$NOW^XLFDT,ZTRTN="GUIEP^APCLDR2",ZTDESC="GUI DM PTS NO DX PL" D ^%ZTLOAD
D EXIT
Q
GUIEP ;EP
D PROC
K ^TMP($J,"APCLDR2")
S IOM=80
D GUIR^XBLM("PRINT^APCLDR2","^TMP($J,""APCLDR2"",")
S X=0,C=0 F S X=$O(^TMP($J,"APCLDR2",X)) Q:X'=+X D
.S APCLDATA=^TMP($J,"APCLDR2",X)
.I APCLDATA="ZZZZZZZ" S APCLDATA=$C(12)
.S ^APCLGUIR(APCLIEN,11,X,0)=APCLDATA,C=C+1
S ^APCLGUIR(APCLIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
S DA=APCLIEN,DIK="^APCLGUIR(" D IX1^DIK
D ENDLOG
K ^TMP($J,"APCLDR2")
D EXIT
S ZTREQ="@"
Q
;
ENDLOG ;-- write the end of the log
D NOW^%DTC
S APCLNOW=$G(%)
S DIE="^APCLGUIR(",DA=APCLIEN,DR=".04////"_APCLNOW_";.07////C"
D ^DIE
K DIE,DR,DA
Q
APCLDR2 ; IHS/CMI/LAB - patients w/o dm on problem list ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
START ;
+1 DO INFORM
+2 DO EXIT
+3 DO GETINFO
+4 IF $DATA(APCLQUIT)
DO EXIT
QUIT
+5 QUIT
INFORM ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC)
+3 WRITE !,$$CTR($$USR)
+4 WRITE !!,"This report will list patients who are on the Diabetes Register who do not",!,"have a date of diagnosis recorded in either the Register or on the problem list.",!!
+5 QUIT
+6 ;
GETINFO ;
+1 SET (APCLTR,APCLREG,APCLSTAT,APCLND)=""
+2 DO R
+3 SET APCLTR="R"
IF $DATA(APCLQUIT)
DO EXIT
QUIT
+4 DO ZIS
+5 QUIT
R ;
+1 SET APCLREG=""
+2 SET DIC="^ACM(41.1,"
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the Name of the Register: "
DO ^DIC
+3 IF Y=-1
WRITE !,"No register selected."
SET APCLQUIT=""
QUIT
+4 SET APCLREG=+Y
+5 ;get status
+6 SET APCLSTAT=""
+7 SET DIR(0)="Y"
SET DIR("A")="Do you want to select register patients with a particular status"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
GOTO R
+9 IF Y=0
SET APCLSTAT=""
QUIT
+10 ;which status
+11 SET DIR(0)="9002241,1"
SET DIR("A")="Which status"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
GOTO R
+13 SET APCLSTAT=Y
+14 QUIT
ZIS ;call to XBDBQUE
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO R
+3 SET XBRP="PRINT^APCLDR2"
SET XBRC="PROC^APCLDR2"
SET XBRX="EXIT^APCLDR2"
SET XBNS="APCL"
+4 DO ^XBDBQUE
+5 DO EXIT
+6 QUIT
EXIT ;clean up and exit
+1 DO EN^XBVK("APCL")
+2 DO ^XBFMK
+3 DO KILL^AUPNPAT
+4 QUIT
PROC ;EP - called from XBDBQUE
+1 SET APCLJOB=$JOB
SET APCLBTH=$HOROLOG
+2 KILL ^XTMP("APCLDR2",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLDR2","DM NOT ON PROBLEM LIST")
+4 IF APCLTR="R"
DO REGPROC
QUIT
+5 QUIT
LASTDMDX(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW X,E,APCL,Y
+3 SET Y="APCL("
+4 SET X=P_"^LAST DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(APCL(1))
QUIT $PIECE(APCL(1),U)
+6 QUIT ""
+7 ;
NUMDXS(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW X,E,APCL,Y
+3 SET Y="APCL("
+4 SET X=P_"^ALL DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,Y)
+5 SET (X,Y)=0
+6 FOR
SET X=$ORDER(APCL(X))
IF X'=+X
QUIT
SET Y=Y+1
+7 QUIT Y
+8 ;
REGPROC ;
+1 ;$o through register, check status, if no DM on problem list
+2 ;set xtmp
+3 ;gather up patients from register in ^XTMP
+4 SET X=0
FOR
SET X=$ORDER(^ACM(41,"B",APCLREG,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 IF APCLSTAT]""
IF $PIECE($GET(^ACM(41,X,"DT")),U,1)=APCLSTAT
SET DFN=$PIECE(^ACM(41,X,0),U,2)
DO CHKSET
QUIT
+6 IF APCLSTAT=""
SET DFN=$PIECE(^ACM(41,X,0),U,2)
DO CHKSET
QUIT
+7 QUIT
End DoDot:1
+8 QUIT
CHKSET ;
+1 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+2 IF $$DODX^APCLD206(DFN,APCLREG,"E")]""
QUIT
+3 IF $$DOD^AUPNPAT(DFN)]""
QUIT
+4 ;IHS/CMI/GRL
IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)]""
QUIT
+5 ;IHS/CMI/GRL
IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)=""
QUIT
+6 SET APCLPLDX=$$DMPROB(DFN)
+7 SET ^XTMP("APCLDR2",APCLJOB,APCLBTH,"PATIENTS",$PIECE(^DPT(DFN,0),U),DFN)=$$LASTDMDX(DFN)_U_$$NUMDXS(DFN)_U_APCLPLDX
+8 QUIT
DMPROB(P) ;is DM on problem list 1=yes 0=no
+1 IF '$GET(P)
QUIT 0
+2 IF '$DATA(^AUPNPROB("AC",P))
QUIT 0
+3 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+4 IF 'T
QUIT ""
+5 NEW G,D,Y,I
SET D=""
SET (Y,G)=0
FOR
SET Y=$ORDER(^AUPNPROB("AC",P,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:1
+6 SET I=$PIECE(^AUPNPROB(Y,0),U)
+7 IF $$ICD^ATXAPI(I,T,9)
SET G=1
+8 QUIT
End DoDot:1
+9 QUIT G
PRINT ;EP - called from xbdbque
+1 SET APCL80D="-------------------------------------------------------------------------------"
+2 SET APCLPG=0
SET APCLIOSL=$SELECT($GET(APCLGUI):55,1:IOSL)
+3 DO HEAD
+4 IF '$DATA(^XTMP("APCLDR2",APCLJOB,APCLBTH))
WRITE !!,"NO PATIENTS TO REPORT"
GOTO DONE
+5 SET APCLNAME=""
KILL APCLQ
+6 FOR
SET APCLNAME=$ORDER(^XTMP("APCLDR2",APCLJOB,APCLBTH,"PATIENTS",APCLNAME))
IF APCLNAME=""!($DATA(APCLQ))
QUIT
Begin DoDot:1
+7 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("APCLDR2",APCLJOB,APCLBTH,"PATIENTS",APCLNAME,DFN))
IF DFN=""!($DATA(APCLQ))
QUIT
SET APCLX=^XTMP("APCLDR2",APCLJOB,APCLBTH,"PATIENTS",APCLNAME,DFN)
Begin DoDot:2
+8 IF $Y>(APCLIOSL-4)
DO HEAD
IF $DATA(APCLQ)
QUIT
+9 WRITE !,$EXTRACT(APCLNAME,1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$DOB^AUPNPAT(DFN,"E"),?43,$PIECE(^DPT(DFN,0),U,2),?47,$$FMTE^XLFDT($PIECE(APCLX,U)),?63,$PIECE(APCLX,U,2),?73,$SELECT($PIECE(APCLX,U,3):"YES",1:"NO")
End DoDot:2
End DoDot:1
DONE ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of report. HIT RETURN"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(IOF)
WRITE @IOF
+3 KILL ^XTMP("APCLDR2",APCLJOB,APCLBTH),APCLJOB,APCLBTH
+4 QUIT
HEAD IF 'APCLPG
GOTO HEAD1
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQ=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 IF $GET(APCLGUI)
IF APCLPG'=1
WRITE !,"ZZZZZZZ"
+3 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+4 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!
+5 WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!
+6 WRITE $$CTR("DIABETES REGISTER PATIENTS WITH NO RECORDED DATE OF ONSET OF DIABETES",80),!
+7 IF APCLTR="R"
WRITE $$CTR("Patients on the "_$PIECE(^ACM(41.1,APCLREG,0),U)_" Register",80),!
+8 IF APCLTR="D"
WRITE $$CTR("Patients w/at least "_APCLND_" diabetes diagnoses",80),!
PIH WRITE !,"PATIENT NAME",?22,"HRN",?29,"DOB",?47,"LAST DM DX",?63,"#DM DXS",?71,"DM ON PL",!,APCL80D
+1 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
BDMGO(APCLTR,APCLREG,APCLSTAT) ;EP - GUI DMS Entry Point
+1 ;cmi/anch/maw added 10/19/2004
+2 SET APCLGUI=1
+3 DO PROC
+4 DO GUIR^XBLM("PRINT^APCLDR2","^TMP($J,""APCLDR2"",")
+5 DO EXIT
+6 QUIT
+7 ;
TEST ;
+1 DO BDMG("R",1,"A")
+2 QUIT
BDMG(APCLTR,APCLREG,APCLSTAT) ;EP - GUI DMS Entry Point
+1 SET APCLTR="R"
SET APCLGUI=1
+2 NEW APCLNOW,APCLOPT,APCLIEN
+3 SET APCLOPT="DM Register Pts w/no recorded DM Date of Onset"
+4 DO NOW^%DTC
+5 SET APCLNOW=$GET(%)
+6 KILL DD,DO,DIC
+7 SET X=DUZ_APCLNOW
+8 SET DIC("DR")=".02////"_DUZ_";.03////"_APCLNOW_";.06///"_$GET(APCLOPT)_";.07////R"
+9 SET DIC="^APCLGUIR("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9001004.4
+10 DO FILE^DICN
+11 KILL DIADD,DLAYGO,DIC,DA
+12 IF Y=-1
SET APCLIEN=-1
QUIT
+13 SET APCLIEN=+Y
+14 ;cmi/maw added
SET BDMGIEN=APCLIEN
+15 DO ^XBFMK
+16 KILL ZTSAVE
SET ZTSAVE("*")=""
+17 ;D GUIEP for interactive testing
+18 SET ZTIO=""
SET ZTDTH=$$NOW^XLFDT
SET ZTRTN="GUIEP^APCLDR2"
SET ZTDESC="GUI DM PTS NO DX PL"
DO ^%ZTLOAD
+19 DO EXIT
+20 QUIT
GUIEP ;EP
+1 DO PROC
+2 KILL ^TMP($JOB,"APCLDR2")
+3 SET IOM=80
+4 DO GUIR^XBLM("PRINT^APCLDR2","^TMP($J,""APCLDR2"",")
+5 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"APCLDR2",X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET APCLDATA=^TMP($JOB,"APCLDR2",X)
+7 IF APCLDATA="ZZZZZZZ"
SET APCLDATA=$CHAR(12)
+8 SET ^APCLGUIR(APCLIEN,11,X,0)=APCLDATA
SET C=C+1
End DoDot:1
+9 SET ^APCLGUIR(APCLIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+10 SET DA=APCLIEN
SET DIK="^APCLGUIR("
DO IX1^DIK
+11 DO ENDLOG
+12 KILL ^TMP($JOB,"APCLDR2")
+13 DO EXIT
+14 SET ZTREQ="@"
+15 QUIT
+16 ;
ENDLOG ;-- write the end of the log
+1 DO NOW^%DTC
+2 SET APCLNOW=$GET(%)
+3 SET DIE="^APCLGUIR("
SET DA=APCLIEN
SET DR=".04////"_APCLNOW_";.07////C"
+4 DO ^DIE
+5 KILL DIE,DR,DA
+6 QUIT
