PSXBKG ;BIR/WPB-Routine to schedule background jobs [ 05/01/97 12:56 PM ]
;;2.0;CMOP;**1**;11 Apr 97
DREL W !!
I $D(^PSX(554,"AS")) D Q
.S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="This job is already scheduled.",DIR("A")="Do you want to unschedule this job" D ^DIR K DIR G:(Y<1)!($D(DIRUT)) EXIT G:Y=1 UNSCH
S %DT="AEXR",%DT("A")="Enter starting date/time: ",%DT("B")="TODAY@2330" D ^%DT G:Y<0!($D(DTOUT)) EXIT S PSXDATE=Y K %DT,%DT("A"),%DT("B"),Y,X
K Y,X,DTOUT,DUOUT,DIRUT,DIROUT,DIR,DIR("A"),DIR("?"),DIR(0)
S DIR(0)="N",DIR("B")="10",DIR("A")="Enter number of days of data to keep",DIR("?")="This is the number of days of data to keep on file." D ^DIR K DIR S KEEP=Y G:$D(DIRUT)!($D(DUOUT))!($D(DTOUT))!($D(DIROUT)) EXIT
K Y,X,DTOUT,DUOUT,DIRUT,DIROUT,DIR,DIR("A"),DIR("?"),DIR(0)
S ZTIO="",ZTDTH=PSXDATE,ZTDESC="CMOP Background Purge for Release Data",ZTRTN="RDPRG^PSXBKG" D ^%ZTLOAD
I $G(ZTSK)>0 W !,"Job Queued.",! D
.K DD,DO
.S:'$D(^PSX(554,1,1,0)) ^PSX(554,1,1,0)="^554.01SA^^"
.S DIC(0)="LZ",DA(1)=1,DIC="^PSX(554,"_DA(1)_",1,",X=4,DIC("DR")="1////"_PSXDATE_";2////"_ZTSK_";3////S;4////"_DUZ_";7////"_KEEP D FILE^DICN K DIC,DIC(0),DIC("DR"),Y,X
S ZTREQ="@"
EXIT K Y,%DT("A"),%DT("B"),N,PSXDATE,STDATE,TIME,DIR,DIRUT,DIROUT,DTOUT,DUOUT,KEEP,REC,ZTIO,ZTDESC,ZTDTH,ZTRTN
Q
UNSCH N ZTSK
S REC=$O(^PSX(554,"AS",""))
S ZTSK=$P(^PSX(554,1,1,REC,0),"^",3)
I $G(ZTSK)'>0 W !,"This job doesn't exist.",! Q
D STAT^%ZTLOAD
I ZTSK(1)=2 W !,"This task is currently running, wait until the task has finished before stopping the job.",! Q
I ZTSK(1)'=2 D KILL^%ZTLOAD
I ZTSK(0)=1 W !,"Job stopped.",! D
.D NOW^%DTC
.S DA=REC,DA(1)=1,DIE="^PSX(554,"_DA(1)_",1,",DR="2////@;3////S;5////"_%_";6////"_DUZ D ^DIE K DA,DIE,DR
K Y,ZTSK
G EXIT
;Called by Taskman to schedule background purge of Release Data
RDPRG Q:'$D(^PSX(554,"AS"))
S RC=$O(^PSX(554,"AS",""))
D NOW^%DTC
S ZTSK=$P(^PSX(554,1,1,RC,0),"^",3),TIME="24H",ZTIO="",ZTDESC="CMOP Background Purge for Release Data",ZTRTN="RDPRG^PSXBKG",ZTDTH=TIME D REQ^%ZTLOAD
Q:$P(^PSX(554,1,1,RC,0),"^",4)="R"
S $P(^PSX(554,1,1,RC,0),"^",4)="R",$P(^PSX(554,1,1,RC,0),"^",9)=% K %
S RC=$O(^PSX(554,"AS","")),KEEP=$P(^PSX(554,1,1,RC,0),"^",8) S:$G(KEEP)'>0 KEEP=14
D NOW^%DTC S END=$$FMADD^XLFDT(%,-KEEP,0,0,0) K %
S MDT=0 F S MDT=$O(^PSX(554,1,3,"B",MDT)) Q:MDT'>0 S REC=0 F S REC=$O(^PSX(554,1,3,"B",MDT,REC)) Q:REC'>0 D
.Q:$P(^PSX(554,1,3,REC,0),"^",7)=""
.Q:$P(^PSX(554,1,3,REC,0),"^")>$G(END)
.S DA(1)=1,DA=REC,DIK="^PSX(554,"_DA(1)_",3," D ^DIK K DA,DIK
S $P(^PSX(554,1,1,RC,0),"^",4)="S"
K RC,END,MDT,REC,KEEP,PSXTSK,ZTRTN,ZTDESC,ZTIO,ZTDTH
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXBKG 2668 printed Nov 22, 2024@16:53:38 Page 2
PSXBKG ;BIR/WPB-Routine to schedule background jobs [ 05/01/97 12:56 PM ]
+1 ;;2.0;CMOP;**1**;11 Apr 97
DREL WRITE !!
+1 IF $DATA(^PSX(554,"AS"))
Begin DoDot:1
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A",1)="This job is already scheduled."
SET DIR("A")="Do you want to unschedule this job"
DO ^DIR
KILL DIR
if (Y<1)!($DATA(DIRUT))
GOTO EXIT
if Y=1
GOTO UNSCH
End DoDot:1
QUIT
+3 SET %DT="AEXR"
SET %DT("A")="Enter starting date/time: "
SET %DT("B")="TODAY@2330"
DO ^%DT
if Y<0!($DATA(DTOUT))
GOTO EXIT
SET PSXDATE=Y
KILL %DT,%DT("A"),%DT("B"),Y,X
+4 KILL Y,X,DTOUT,DUOUT,DIRUT,DIROUT,DIR,DIR("A"),DIR("?"),DIR(0)
+5 SET DIR(0)="N"
SET DIR("B")="10"
SET DIR("A")="Enter number of days of data to keep"
SET DIR("?")="This is the number of days of data to keep on file."
DO ^DIR
KILL DIR
SET KEEP=Y
if $DATA(DIRUT)!($DATA(DUOUT))!($DATA(DTOUT))!($DATA(DIROUT))
GOTO EXIT
+6 KILL Y,X,DTOUT,DUOUT,DIRUT,DIROUT,DIR,DIR("A"),DIR("?"),DIR(0)
+7 SET ZTIO=""
SET ZTDTH=PSXDATE
SET ZTDESC="CMOP Background Purge for Release Data"
SET ZTRTN="RDPRG^PSXBKG"
DO ^%ZTLOAD
+8 IF $GET(ZTSK)>0
WRITE !,"Job Queued.",!
Begin DoDot:1
+9 KILL DD,DO
+10 if '$DATA(^PSX(554,1,1,0))
SET ^PSX(554,1,1,0)="^554.01SA^^"
+11 SET DIC(0)="LZ"
SET DA(1)=1
SET DIC="^PSX(554,"_DA(1)_",1,"
SET X=4
SET DIC("DR")="1////"_PSXDATE_";2////"_ZTSK_";3////S;4////"_DUZ_";7////"_KEEP
DO FILE^DICN
KILL DIC,DIC(0),DIC("DR"),Y,X
End DoDot:1
+12 SET ZTREQ="@"
EXIT KILL Y,%DT("A"),%DT("B"),N,PSXDATE,STDATE,TIME,DIR,DIRUT,DIROUT,DTOUT,DUOUT,KEEP,REC,ZTIO,ZTDESC,ZTDTH,ZTRTN
+1 QUIT
UNSCH NEW ZTSK
+1 SET REC=$ORDER(^PSX(554,"AS",""))
+2 SET ZTSK=$PIECE(^PSX(554,1,1,REC,0),"^",3)
+3 IF $GET(ZTSK)'>0
WRITE !,"This job doesn't exist.",!
QUIT
+4 DO STAT^%ZTLOAD
+5 IF ZTSK(1)=2
WRITE !,"This task is currently running, wait until the task has finished before stopping the job.",!
QUIT
+6 IF ZTSK(1)'=2
DO KILL^%ZTLOAD
+7 IF ZTSK(0)=1
WRITE !,"Job stopped.",!
Begin DoDot:1
+8 DO NOW^%DTC
+9 SET DA=REC
SET DA(1)=1
SET DIE="^PSX(554,"_DA(1)_",1,"
SET DR="2////@;3////S;5////"_%_";6////"_DUZ
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+10 KILL Y,ZTSK
+11 GOTO EXIT
+12 ;Called by Taskman to schedule background purge of Release Data
RDPRG if '$DATA(^PSX(554,"AS"))
QUIT
+1 SET RC=$ORDER(^PSX(554,"AS",""))
+2 DO NOW^%DTC
+3 SET ZTSK=$PIECE(^PSX(554,1,1,RC,0),"^",3)
SET TIME="24H"
SET ZTIO=""
SET ZTDESC="CMOP Background Purge for Release Data"
SET ZTRTN="RDPRG^PSXBKG"
SET ZTDTH=TIME
DO REQ^%ZTLOAD
+4 if $PIECE(^PSX(554,1,1,RC,0),"^",4)="R"
QUIT
+5 SET $PIECE(^PSX(554,1,1,RC,0),"^",4)="R"
SET $PIECE(^PSX(554,1,1,RC,0),"^",9)=%
KILL %
+6 SET RC=$ORDER(^PSX(554,"AS",""))
SET KEEP=$PIECE(^PSX(554,1,1,RC,0),"^",8)
if $GET(KEEP)'>0
SET KEEP=14
+7 DO NOW^%DTC
SET END=$$FMADD^XLFDT(%,-KEEP,0,0,0)
KILL %
+8 SET MDT=0
FOR
SET MDT=$ORDER(^PSX(554,1,3,"B",MDT))
if MDT'>0
QUIT
SET REC=0
FOR
SET REC=$ORDER(^PSX(554,1,3,"B",MDT,REC))
if REC'>0
QUIT
Begin DoDot:1
+9 if $PIECE(^PSX(554,1,3,REC,0),"^",7)=""
QUIT
+10 if $PIECE(^PSX(554,1,3,REC,0),"^")>$GET(END)
QUIT
+11 SET DA(1)=1
SET DA=REC
SET DIK="^PSX(554,"_DA(1)_",3,"
DO ^DIK
KILL DA,DIK
End DoDot:1
+12 SET $PIECE(^PSX(554,1,1,RC,0),"^",4)="S"
+13 KILL RC,END,MDT,REC,KEEP,PSXTSK,ZTRTN,ZTDESC,ZTIO,ZTDTH
+14 QUIT
