PSXPURG ;BIR/WPB-Purges Files at Host and Remote Facilities ;12 Dec 2001
;;2.0;CMOP;**28,41**;11 Apr 97
EN ;
Q:'$G(PSXSYST)
PURG ;Purge CMOP System file purge multiple of all but last ten days entries
; now called by PSXBLD
S LAST=$$FMADD^XLFDT(DT,-10,0,0,0)
S PSXPURG=0 F PSXCNT=1:1 S PSXPURG=$O(^PSX(550,+PSXSYST,"P",PSXPURG)) Q:'PSXPURG I $P($P(^PSX(550,+PSXSYST,"P",PSXPURG,0),"^"),".")<LAST S DA=PSXPURG,DA(1)=+PSXSYST,DIK="^PSX(550,"_DA(1)_",""P""," D K DA
. N I F I=1:1:4 L +^PSX(550,DA(1),"P",DA):600 Q:$T I I=4 S PSXFILE="CMOP SYSTEM" D RALRT^PSXUTL
. D ^DIK
. L -^PSX(550,DA(1),"P",DA)
K PSXCNT,PSXPURG,DA,DIK
D NOW^%DTC S BTM=%,QUECNT=0
Q
LOGACK ; called from acknowledgement process
S:'$D(^PSX(550,+PSXSYST,"P",0)) ^PSX(550,+PSXSYST,"P",0)="^550.08DA^^"
L +^PSX(550,+PSXSYST):600
LOG S DA=+PSXSYST,DIE="^PSX(550,",DR="6////"_PSXBAT D ^DIE
L -^PSX(550,+PSXSYST) K DIE,DA,DR,DO,DD
D NOW^%DTC S BTM=%,QUECNT=EMSG-BMSG+1
S DA(1)=+PSXSYST,X=BTM,DIC(0)="Z",DIC="^PSX(550,"_+PSXSYST_",""P"","
S DIC("DR")="1////"_QUECNT_";3////"_BMSG_";4////"_EMSG
D FILE^DICN G:$P($G(Y),U,3)'=1 LOG
K DIC,DA,QUECNT,BMSG,EMSG,PSXSYST,REC,BTM,XXX,Y,X,DTOUT,DUOUT
S XMSER=PSXSER,XMZ=PSXXMZ D REMSBMSG^XMA1C
Q
REPT S DIC(0)="AEQMZ",DIC("A")="Enter CMOP System: ",DIC=550 D ^DIC K DIC G:Y<0!($D(DTOUT))!($D(DUOUT)) EX S SYS=+Y,SYSTEM=$P($G(Y),U,2)
F XX=0:0 S XX=$O(^PSX(550,SYS,"P",XX)) Q:XX'>0 S LAST=XX
W @IOF,!!
W ?24,"Purge Status of CMOP Rx Queue"
I '$D(LAST) W !!,SYSTEM_" does not have any purge data to report." G EX
S DTTM=$$FMTE^XLFDT($P($G(^PSX(550,SYS,"P",LAST,0)),U,1),1)
W !!,"Date/Time of Last Purge: ",$P($G(DTTM),":",1,2)
W !,"Starting Message Number: ",$P($G(^PSX(550,SYS,"P",LAST,0)),U,4)
W !,"Ending Message Number : ",$P($G(^PSX(550,SYS,"P",LAST,0)),U,5)
W !,"Total Orders Purged : ",$P($G(^PSX(550,SYS,"P",LAST,0)),U,2)
EX K SYS,SYSTEM,DTTM,LAST,XX,Y,X,DIC,DTOUT,DUOUT
Q
EXIT K XX,LAST,DTTM,NN,P514,PSXBAT,PSXPURG,PSXER,PSXXMZ,RX1,SYS,SYSTEM,XMSER,XMZ,XX1,YY,Z,ZZ,XXX,NN,MM,%,PSXSER
Q
QUE W !!
I $D(^PSX(554,"AD")) 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)) EXIT1 G:Y=1 UNSCH
S %DT="AEXR",%DT("B")="NOW",%DT("A")="Enter the date and time to start purge: " D ^%DT K %DT G:Y<0!($D(DTOUT)) EXIT1 S (PSXDATE,STDATE)=Y
S ZTDTH=PSXDATE,ZTDESC="CMOP Background Purge for CMOP Database file",ZTIO="",ZTRTN="ENHOST^PSXPURG",ZTSAVE("DUZ")="" 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)="Z",DA(1)=1,X=3,DIC="^PSX(554,"_DA(1)_",1,",DIC("DR")="1////"_PSXDATE_";2////"_ZTSK_";3////S;4////"_DUZ D FILE^DICN K DIC,DIC(0),DIC("DR"),Y,X
K STDATE,Y,TIME,X,N,PSXDATE,ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE("DUZ")
Q
ENHOST ;Called by Taskman to purge and close the files at the host site, job tasked every 24 hours
S PSXZTSK=ZTSK,ZTREQ="@"
D NEXT
Q:'$D(^PSX(552.1,"APRG"))
F I=0:0 S I=$O(^PSX(552.1,"APRG",I)) Q:'I D
.Q:'$D(^PSX(552.1,I)) Q:"346"'[+$P($G(^PSX(552.1,I,0)),"^",2)
.S BAT=$P($G(^PSX(552.1,I,0)),"^"),BEG=$P($G(^PSX(552.1,I,1)),"^",1),END=$P($G(^PSX(552.1,I,1)),"^",2)
.Q:$D(^PSX(552.2,"AQ",BAT))!($G(BEG)'>0)!($G(END)'>0)
.K ^PSX(552.1,I,"S")
.S DIK="^PSX(552.2,"
.F J=BEG:1:END S MSG=BAT_"-"_J,REC=$O(^PSX(552.2,"B",MSG,"")) Q:$G(REC)="" D
..Q:($G(^PSX(552.2,REC,0))="")!("2/3/5/99"'[+$P($G(^PSX(552.2,REC,0)),"^",2))
..S DA=REC D ^DIK K REC,MSG,DA
.I $D(^PSX(552.1,I,0)) S DIE=552.1,DA=I,DR="19////2" L +^PSX(552.1,DA):600 D ^DIE L -^PSX(552.1,DA)
.K BEG,END,BAT,MSG,J,DIE,DA,DR
K I,DIK,DIE,DA,DR,PSXZTSK
D ^PSXPURG1
Q
NEXT S FREQ="24H",ZTSK=PSXZTSK,ZTRTN="ENHOST^PSXPURG",ZTIO="",ZTDESC="CMOP Background Purge for CMOP Database file",ZTDTH=FREQ D REQ^%ZTLOAD
D NOW^%DTC
S RE=$O(^PSX(554,"AD","")) S:$G(RE)>0 $P(^PSX(554,1,1,RE,0),"^",9)=%
EXIT1 K ZTDESC,ZTRTN,ZTSK,ZTIO,ZTDTH,FREQ,ZTSAVE("DUZ"),ZTREQ,PSXZTSK,DTOUT,DIRUT,DIROUT,DUOUT,DIR,%,RE
Q
UNSCH ;kills the background purge of the database file (552.1)
N ZTSK
S REC=$O(^PSX(554,"AD",""))
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 L +^PSX(554,DA(1),1,DA):600 D ^DIE L -^PSX(554,DA(1),1,DA) K DA,DIE,DR
K Y,ZTSK,REC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXPURG 4661 printed Sep 23, 2025@19:20:41 Page 2
PSXPURG ;BIR/WPB-Purges Files at Host and Remote Facilities ;12 Dec 2001
+1 ;;2.0;CMOP;**28,41**;11 Apr 97
EN ;
+1 if '$GET(PSXSYST)
QUIT
PURG ;Purge CMOP System file purge multiple of all but last ten days entries
+1 ; now called by PSXBLD
+2 SET LAST=$$FMADD^XLFDT(DT,-10,0,0,0)
+3 SET PSXPURG=0
FOR PSXCNT=1:1
SET PSXPURG=$ORDER(^PSX(550,+PSXSYST,"P",PSXPURG))
if 'PSXPURG
QUIT
IF $PIECE($PIECE(^PSX(550,+PSXSYST,"P",PSXPURG,0),"^"),".")<LAST
SET DA=PSXPURG
SET DA(1)=+PSXSYST
SET DIK="^PSX(550,"_DA(1)_",""P"","
Begin DoDot:1
+4 NEW I
FOR I=1:1:4
LOCK +^PSX(550,DA(1),"P",DA):600
if $TEST
QUIT
IF I=4
SET PSXFILE="CMOP SYSTEM"
DO RALRT^PSXUTL
+5 DO ^DIK
+6 LOCK -^PSX(550,DA(1),"P",DA)
End DoDot:1
KILL DA
+7 KILL PSXCNT,PSXPURG,DA,DIK
+8 DO NOW^%DTC
SET BTM=%
SET QUECNT=0
+9 QUIT
LOGACK ; called from acknowledgement process
+1 if '$DATA(^PSX(550,+PSXSYST,"P",0))
SET ^PSX(550,+PSXSYST,"P",0)="^550.08DA^^"
+2 LOCK +^PSX(550,+PSXSYST):600
LOG SET DA=+PSXSYST
SET DIE="^PSX(550,"
SET DR="6////"_PSXBAT
DO ^DIE
+1 LOCK -^PSX(550,+PSXSYST)
KILL DIE,DA,DR,DO,DD
+2 DO NOW^%DTC
SET BTM=%
SET QUECNT=EMSG-BMSG+1
+3 SET DA(1)=+PSXSYST
SET X=BTM
SET DIC(0)="Z"
SET DIC="^PSX(550,"_+PSXSYST_",""P"","
+4 SET DIC("DR")="1////"_QUECNT_";3////"_BMSG_";4////"_EMSG
+5 DO FILE^DICN
if $PIECE($GET(Y),U,3)'=1
GOTO LOG
+6 KILL DIC,DA,QUECNT,BMSG,EMSG,PSXSYST,REC,BTM,XXX,Y,X,DTOUT,DUOUT
+7 SET XMSER=PSXSER
SET XMZ=PSXXMZ
DO REMSBMSG^XMA1C
+8 QUIT
REPT SET DIC(0)="AEQMZ"
SET DIC("A")="Enter CMOP System: "
SET DIC=550
DO ^DIC
KILL DIC
if Y<0!($DATA(DTOUT))!($DATA(DUOUT))
GOTO EX
SET SYS=+Y
SET SYSTEM=$PIECE($GET(Y),U,2)
+1 FOR XX=0:0
SET XX=$ORDER(^PSX(550,SYS,"P",XX))
if XX'>0
QUIT
SET LAST=XX
+2 WRITE @IOF,!!
+3 WRITE ?24,"Purge Status of CMOP Rx Queue"
+4 IF '$DATA(LAST)
WRITE !!,SYSTEM_" does not have any purge data to report."
GOTO EX
+5 SET DTTM=$$FMTE^XLFDT($PIECE($GET(^PSX(550,SYS,"P",LAST,0)),U,1),1)
+6 WRITE !!,"Date/Time of Last Purge: ",$PIECE($GET(DTTM),":",1,2)
+7 WRITE !,"Starting Message Number: ",$PIECE($GET(^PSX(550,SYS,"P",LAST,0)),U,4)
+8 WRITE !,"Ending Message Number : ",$PIECE($GET(^PSX(550,SYS,"P",LAST,0)),U,5)
+9 WRITE !,"Total Orders Purged : ",$PIECE($GET(^PSX(550,SYS,"P",LAST,0)),U,2)
EX KILL SYS,SYSTEM,DTTM,LAST,XX,Y,X,DIC,DTOUT,DUOUT
+1 QUIT
EXIT KILL XX,LAST,DTTM,NN,P514,PSXBAT,PSXPURG,PSXER,PSXXMZ,RX1,SYS,SYSTEM,XMSER,XMZ,XX1,YY,Z,ZZ,XXX,NN,MM,%,PSXSER
+1 QUIT
QUE WRITE !!
+1 IF $DATA(^PSX(554,"AD"))
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 EXIT1
if Y=1
GOTO UNSCH
End DoDot:1
QUIT
+3 SET %DT="AEXR"
SET %DT("B")="NOW"
SET %DT("A")="Enter the date and time to start purge: "
DO ^%DT
KILL %DT
if Y<0!($DATA(DTOUT))
GOTO EXIT1
SET (PSXDATE,STDATE)=Y
+4 SET ZTDTH=PSXDATE
SET ZTDESC="CMOP Background Purge for CMOP Database file"
SET ZTIO=""
SET ZTRTN="ENHOST^PSXPURG"
SET ZTSAVE("DUZ")=""
DO ^%ZTLOAD
+5 IF $GET(ZTSK)>0
WRITE !,"Job Queued."
Begin DoDot:1
+6 KILL DD,DO
+7 if '$DATA(^PSX(554,1,1,0))
SET ^PSX(554,1,1,0)="^554.01SA^^"
+8 SET DIC(0)="Z"
SET DA(1)=1
SET X=3
SET DIC="^PSX(554,"_DA(1)_",1,"
SET DIC("DR")="1////"_PSXDATE_";2////"_ZTSK_";3////S;4////"_DUZ
DO FILE^DICN
KILL DIC,DIC(0),DIC("DR"),Y,X
End DoDot:1
+9 KILL STDATE,Y,TIME,X,N,PSXDATE,ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE("DUZ")
+10 QUIT
ENHOST ;Called by Taskman to purge and close the files at the host site, job tasked every 24 hours
+1 SET PSXZTSK=ZTSK
SET ZTREQ="@"
+2 DO NEXT
+3 if '$DATA(^PSX(552.1,"APRG"))
QUIT
+4 FOR I=0:0
SET I=$ORDER(^PSX(552.1,"APRG",I))
if 'I
QUIT
Begin DoDot:1
+5 if '$DATA(^PSX(552.1,I))
QUIT
if "346"'[+$PIECE($GET(^PSX(552.1,I,0)),"^",2)
QUIT
+6 SET BAT=$PIECE($GET(^PSX(552.1,I,0)),"^")
SET BEG=$PIECE($GET(^PSX(552.1,I,1)),"^",1)
SET END=$PIECE($GET(^PSX(552.1,I,1)),"^",2)
+7 if $DATA(^PSX(552.2,"AQ",BAT))!($GET(BEG)'>0)!($GET(END)'>0)
QUIT
+8 KILL ^PSX(552.1,I,"S")
+9 SET DIK="^PSX(552.2,"
+10 FOR J=BEG:1:END
SET MSG=BAT_"-"_J
SET REC=$ORDER(^PSX(552.2,"B",MSG,""))
if $GET(REC)=""
QUIT
Begin DoDot:2
+11 if ($GET(^PSX(552.2,REC,0))="")!("2/3/5/99"'[+$PIECE($GET(^PSX(552.2,REC,0)),"^",2))
QUIT
+12 SET DA=REC
DO ^DIK
KILL REC,MSG,DA
End DoDot:2
+13 IF $DATA(^PSX(552.1,I,0))
SET DIE=552.1
SET DA=I
SET DR="19////2"
LOCK +^PSX(552.1,DA):600
DO ^DIE
LOCK -^PSX(552.1,DA)
+14 KILL BEG,END,BAT,MSG,J,DIE,DA,DR
End DoDot:1
+15 KILL I,DIK,DIE,DA,DR,PSXZTSK
+16 DO ^PSXPURG1
+17 QUIT
NEXT SET FREQ="24H"
SET ZTSK=PSXZTSK
SET ZTRTN="ENHOST^PSXPURG"
SET ZTIO=""
SET ZTDESC="CMOP Background Purge for CMOP Database file"
SET ZTDTH=FREQ
DO REQ^%ZTLOAD
+1 DO NOW^%DTC
+2 SET RE=$ORDER(^PSX(554,"AD",""))
if $GET(RE)>0
SET $PIECE(^PSX(554,1,1,RE,0),"^",9)=%
EXIT1 KILL ZTDESC,ZTRTN,ZTSK,ZTIO,ZTDTH,FREQ,ZTSAVE("DUZ"),ZTREQ,PSXZTSK,DTOUT,DIRUT,DIROUT,DUOUT,DIR,%,RE
+1 QUIT
UNSCH ;kills the background purge of the database file (552.1)
+1 NEW ZTSK
+2 SET REC=$ORDER(^PSX(554,"AD",""))
+3 SET ZTSK=$PIECE(^PSX(554,1,1,REC,0),"^",3)
+4 IF $GET(ZTSK)'>0
WRITE !,"This job doesn't exist.",!
QUIT
+5 DO STAT^%ZTLOAD
+6 IF ZTSK(1)=2
WRITE !,"This task is currently running, wait until the task has finished before stopping the job.",!
QUIT
+7 IF ZTSK(1)'=2
DO KILL^%ZTLOAD
+8 IF ZTSK(0)=1
WRITE !,"Job stopped.",!
Begin DoDot:1
+9 DO NOW^%DTC
+10 SET DA=REC
SET DA(1)=1
SET DIE="^PSX(554,"_DA(1)_",1,"
SET DR="2////@;3////S;5////"_%_";6////"_DUZ
LOCK +^PSX(554,DA(1),1,DA):600
DO ^DIE
LOCK -^PSX(554,DA(1),1,DA)
KILL DA,DIE,DR
End DoDot:1
+11 KILL Y,ZTSK,REC
+12 QUIT
