Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSXPURG

PSXPURG.m

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