- 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 Feb 18, 2025@23:11:05 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