source: WorldVistAEHR/trunk/r/CMOP-PSX/PSXPURG.m@ 1739

Last change on this file since 1739 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.5 KB
Line 
1PSXPURG ;BIR/WPB-Purges Files at Host and Remote Facilities ;12 Dec 2001
2 ;;2.0;CMOP;**28,41**;11 Apr 97
3EN ;
4 Q:'$G(PSXSYST)
5PURG ;Purge CMOP System file purge multiple of all but last ten days entries
6 ; now called by PSXBLD
7 S LAST=$$FMADD^XLFDT(DT,-10,0,0,0)
8 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
9 . 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
10 . D ^DIK
11 . L -^PSX(550,DA(1),"P",DA)
12 K PSXCNT,PSXPURG,DA,DIK
13 D NOW^%DTC S BTM=%,QUECNT=0
14 Q
15LOGACK ; called from acknowledgement process
16 S:'$D(^PSX(550,+PSXSYST,"P",0)) ^PSX(550,+PSXSYST,"P",0)="^550.08DA^^"
17 L +^PSX(550,+PSXSYST):600
18LOG S DA=+PSXSYST,DIE="^PSX(550,",DR="6////"_PSXBAT D ^DIE
19 L -^PSX(550,+PSXSYST) K DIE,DA,DR,DO,DD
20 D NOW^%DTC S BTM=%,QUECNT=EMSG-BMSG+1
21 S DA(1)=+PSXSYST,X=BTM,DIC(0)="Z",DIC="^PSX(550,"_+PSXSYST_",""P"","
22 S DIC("DR")="1////"_QUECNT_";3////"_BMSG_";4////"_EMSG
23 D FILE^DICN G:$P($G(Y),U,3)'=1 LOG
24 K DIC,DA,QUECNT,BMSG,EMSG,PSXSYST,REC,BTM,XXX,Y,X,DTOUT,DUOUT
25 S XMSER=PSXSER,XMZ=PSXXMZ D REMSBMSG^XMA1C
26 Q
27REPT 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)
28 F XX=0:0 S XX=$O(^PSX(550,SYS,"P",XX)) Q:XX'>0 S LAST=XX
29 W @IOF,!!
30 W ?24,"Purge Status of CMOP Rx Queue"
31 I '$D(LAST) W !!,SYSTEM_" does not have any purge data to report." G EX
32 S DTTM=$$FMTE^XLFDT($P($G(^PSX(550,SYS,"P",LAST,0)),U,1),1)
33 W !!,"Date/Time of Last Purge: ",$P($G(DTTM),":",1,2)
34 W !,"Starting Message Number: ",$P($G(^PSX(550,SYS,"P",LAST,0)),U,4)
35 W !,"Ending Message Number : ",$P($G(^PSX(550,SYS,"P",LAST,0)),U,5)
36 W !,"Total Orders Purged : ",$P($G(^PSX(550,SYS,"P",LAST,0)),U,2)
37EX K SYS,SYSTEM,DTTM,LAST,XX,Y,X,DIC,DTOUT,DUOUT
38 Q
39EXIT K XX,LAST,DTTM,NN,P514,PSXBAT,PSXPURG,PSXER,PSXXMZ,RX1,SYS,SYSTEM,XMSER,XMZ,XX1,YY,Z,ZZ,XXX,NN,MM,%,PSXSER
40 Q
41QUE W !!
42 I $D(^PSX(554,"AD")) D Q
43 .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
44 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
45 S ZTDTH=PSXDATE,ZTDESC="CMOP Background Purge for CMOP Database file",ZTIO="",ZTRTN="ENHOST^PSXPURG",ZTSAVE("DUZ")="" D ^%ZTLOAD
46 I $G(ZTSK)>0 W !,"Job Queued." D
47 .K DD,DO
48 .S:'$D(^PSX(554,1,1,0)) ^PSX(554,1,1,0)="^554.01SA^^"
49 .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
50 K STDATE,Y,TIME,X,N,PSXDATE,ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE("DUZ")
51 Q
52ENHOST ;Called by Taskman to purge and close the files at the host site, job tasked every 24 hours
53 S PSXZTSK=ZTSK,ZTREQ="@"
54 D NEXT
55 Q:'$D(^PSX(552.1,"APRG"))
56 F I=0:0 S I=$O(^PSX(552.1,"APRG",I)) Q:'I D
57 .Q:'$D(^PSX(552.1,I)) Q:"346"'[+$P($G(^PSX(552.1,I,0)),"^",2)
58 .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)
59 .Q:$D(^PSX(552.2,"AQ",BAT))!($G(BEG)'>0)!($G(END)'>0)
60 .K ^PSX(552.1,I,"S")
61 .S DIK="^PSX(552.2,"
62 .F J=BEG:1:END S MSG=BAT_"-"_J,REC=$O(^PSX(552.2,"B",MSG,"")) Q:$G(REC)="" D
63 ..Q:($G(^PSX(552.2,REC,0))="")!("2/3/5/99"'[+$P($G(^PSX(552.2,REC,0)),"^",2))
64 ..S DA=REC D ^DIK K REC,MSG,DA
65 .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)
66 .K BEG,END,BAT,MSG,J,DIE,DA,DR
67 K I,DIK,DIE,DA,DR,PSXZTSK
68 D ^PSXPURG1
69 Q
70NEXT S FREQ="24H",ZTSK=PSXZTSK,ZTRTN="ENHOST^PSXPURG",ZTIO="",ZTDESC="CMOP Background Purge for CMOP Database file",ZTDTH=FREQ D REQ^%ZTLOAD
71 D NOW^%DTC
72 S RE=$O(^PSX(554,"AD","")) S:$G(RE)>0 $P(^PSX(554,1,1,RE,0),"^",9)=%
73EXIT1 K ZTDESC,ZTRTN,ZTSK,ZTIO,ZTDTH,FREQ,ZTSAVE("DUZ"),ZTREQ,PSXZTSK,DTOUT,DIRUT,DIROUT,DUOUT,DIR,%,RE
74 Q
75UNSCH ;kills the background purge of the database file (552.1)
76 N ZTSK
77 S REC=$O(^PSX(554,"AD",""))
78 S ZTSK=$P(^PSX(554,1,1,REC,0),"^",3)
79 I $G(ZTSK)'>0 W !,"This job doesn't exist.",! Q
80 D STAT^%ZTLOAD
81 I ZTSK(1)=2 W !,"This task is currently running, wait until the task has finished before stopping the job.",! Q
82 I ZTSK(1)'=2 D KILL^%ZTLOAD
83 I ZTSK(0)=1 W !,"Job stopped.",! D
84 .D NOW^%DTC
85 .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
86 K Y,ZTSK,REC
87 Q
Note: See TracBrowser for help on using the repository browser.