source: WorldVistAEHR/trunk/r/MAILMAN-XM/XMA3.m@ 701

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

initial load of WorldVistAEHR

File size: 8.1 KB
Line 
1XMA3 ;ISC-SF/GMB-XMCLEAN, XMAUTOPURGE ;04/18/2002 07:09
2 ;;8.0;MailMan;;Jun 28, 2002
3 ; Was (WASH ISC)/CAP
4 ;
5 ; Entry points used by MailMan options (not covered by DBIA):
6 ; CLEAN Option: XMCLEAN - Clean out waste baskets and
7 ; Postmaster's ARRIVING basket
8 ; EN Option: XMAUTOPURGE - Purge Unreferenced Messages
9 ; SCAN Option: XMPURGE - Purge Unreferenced Messages, then STAT
10 ; STAT Option: XMSTAT - Message Statistics
11 Q
12EN ;
13 N XMPARM
14 D PURGEIT(.XMPARM)
15 S:$D(ZTQUEUED) ZTREQ="@"
16 Q
17STAT ;
18 D AUDIT^XMA30 ; Show purge audit records
19 D USERSTAT^XMA30 ; Show user mailbox info
20 Q
21SCAN ; PURGE MESSAGES
22 I $D(ZTQUEUED) G EN
23 N DIR,XMPARM,XMTEXT
24 D AUDIT^XMA30 ; Show purge audit records
25 S DIR(0)="E" D ^DIR Q:$D(DIRUT) K DIR
26 D BLD^DIALOG(36425,"","","XMTEXT","F")
27 ;I will purge messages which are not in anybody's Mailbox.
28 ;This will be done by comparing the message numbers in the MESSAGE file
29 ;(3.9) against the 'M' cross reference of the MAILBOX file (3.7).
30 ;Because this is a real-time dynamic cross reference, it is
31 ;RECOMMENDED that you run the INTEGRITY CHECKER with some
32 ;frequency, to CORRECT problems, if any.
33 I '$P($G(^XMB(1,1,.12)),U) D
34 . D BLD^DIALOG(36426,"","","XMTEXT","SF")
35 . ;A Mailbox INTEGRITY CHECK will run before the PURGE.
36 E D
37 . D BLD^DIALOG(36427,"","","XMTEXT","SF")
38 . ;A Mailbox INTEGRITY CHECK will NOT run before the PURGE,
39 . ;because your site parameters indicate you do not want it to.
40 . ;You may want to do a BACK-UP just before this runs, and revert
41 . ;to it if many problems are discovered.
42 W !
43 D MSG^DIALOG("WM","","","","XMTEXT")
44 W !
45 D GETPARMS(.XMPARM)
46 D BLD^DIALOG(36428,"","","DIR(""A"")") ;Do you really want to purge all unreferenced messages
47 S DIR("B")=$$EZBLD^DIALOG(39053) ; NO
48 S DIR(0)="Y"
49 D ^DIR Q:'Y
50 D WAIT^DICD
51 D PURGEIT(.XMPARM)
52 K DIR S DIR(0)="E" D ^DIR Q:$D(DIRUT) K DIR
53 D STAT
54 Q
55PURGEIT(XMPARM) ;
56 N XMKILL,XMIEN,XMCNT,XMCRE8,XMABORT
57 D INIT(.XMIEN,.XMPARM,.XMKILL,.XMABORT) Q:XMABORT
58 D MPURGE(.XMCRE8,.XMPARM,.XMKILL,.XMCNT,.XMABORT)
59 D FINISH(XMIEN,XMCRE8,.XMKILL,.XMCNT,XMABORT)
60 Q
61INIT(XMIEN,XMPARM,XMKILL,XMABORT) ;
62 S XMABORT=0
63 D:'$D(XMPARM) GETPARMS(.XMPARM)
64 I '$P($G(^XMB(1,1,.12)),U) D MAILBOX^XMUT4(.XMABORT) Q:XMABORT ; Integrity check
65 S (XMKILL("MSG"),XMKILL("RESP"))=0
66 S XMKILL("START")=$P(^XMB(3.9,0),U,4)
67 D AUDTPURG^XMA32 ; purge audit records
68 D DONTPURG^XMA30 ; Note all messages which shouldn't be purged
69 D INITAUDT^XMA32A(.XMIEN,.XMPARM)
70 Q
71GETPARMS(XMPARM) ;
72 N XMSBUF,XMBUFREC
73 S (XMPARM("TYPE"),XMPARM("START"))=0
74 ; Set up a date buffer, beyond which we won't purge
75 S XMBUFREC=$G(^XMB(1,1,.14))
76 S XMPARM("END")=$$PDATE(+$P(XMBUFREC,U,1),2) ; purge thru this date
77 S XMPARM("PDATE")=$$PDATE(+$P(XMBUFREC,U,2),7) ; don't purge local messages sent on or after this date to remote sites.
78 ; If today is Saturday, start purge at beginning.
79 ; If not Saturday, check MailMan Site Parameter file for field 4.304 ...
80 I $$DOW^XLFDT(DT,1)'=6 D
81 . S XMSBUF=+$P($G(^XMB(1,1,"NOTOPURGE")),U)
82 . I XMSBUF=0,($G(^XMB("NETNAME"))="FORUM.VA.GOV"!$G(^XMB("NETNAME"))="FORUM.MED.VA.GOV") S XMSBUF=45
83 . Q:XMSBUF=0
84 . S XMPARM("START")=$$PDATE(XMSBUF,45)
85 Q:$D(ZTQUEUED)
86 N XMTEXT,XMVAR
87 S XMVAR(1)=$$FMTE^XLFDT($S(XMPARM("START")=0:$O(^XMB(3.9,"C",0)),1:XMPARM("START")),5)
88 S XMVAR(2)=$$FMTE^XLFDT(XMPARM("END"),5)
89 S XMVAR(3)=$$FMTE^XLFDT(XMPARM("PDATE"),5)
90 D BLD^DIALOG(36429,.XMVAR,"","XMTEXT","F")
91 D MSG^DIALOG("WM","","","","XMTEXT")
92 ;Any unreferenced message will be purged if its local create date
93 ;is from |1| to |2| inclusive.
94 ;However, locally generated messages sent to remote sites will not be purged
95 ;if they were sent on or after |3|.
96 ;The following messages are considered 'referenced' and will not be purged:
97 ;- Messages in users' baskets
98 ;- Messages in transit (arriving or being sent)
99 ;- Server messages
100 ;- Messages being edited (includes aborted edits)
101 ;- Later'd messages
102 Q
103PDATE(XMDAYS,XMDEFALT) ; Subtract so many days from today and return that date.
104 S:+XMDAYS=0 XMDAYS=XMDEFALT ; use default if days is null
105 Q $$FMADD^XLFDT(DT,-XMDAYS)
106FINISH(XMIEN,XMCRE8,XMKILL,XMCNT,XMABORT) ;
107 K ^TMP("XM",$J)
108 S XMKILL("TOTAL")=XMKILL("MSG")+XMKILL("RESP")
109 ;I $G(ZTSTOP) W !!,"*** Stopping prematurely per user request ***"
110 I '$D(ZTQUEUED) D
111 . N XMVAR,XMTEXT
112 . S XMVAR(1)=$J(XMCNT,$L(XMKILL("START")))
113 . S XMVAR(2)=$J(XMKILL("TOTAL"),$L(XMKILL("START")))
114 . S XMVAR(3)=$J(XMKILL("START")-XMKILL("TOTAL"),$L(XMKILL("START")))
115 . W !
116 . D BLD^DIALOG(36430,.XMVAR,"","XMTEXT","F")
117 . D MSG^DIALOG("WM","","","","XMTEXT")
118 . ;|1| messages processed, |2| messages purged, |3| messages in file 3.9
119 D CHKAUDT^XMA32A(XMIEN,XMCRE8,.XMKILL)
120 Q
121MPURGE(XMCRE8,XMPARM,XMKILL,XMCNT,XMABORT) ;
122 N XMZREC,XMZ
123 S XMZ="",XMCNT=0
124 S XMCRE8=$S(XMPARM("START")=0:0,1:$O(^XMB(3.9,"C",XMPARM("START")),-1))
125 F S XMCRE8=$O(^XMB(3.9,"C",XMCRE8)) Q:'XMCRE8 Q:XMCRE8>XMPARM("END") D
126 . F S XMZ=$O(^XMB(3.9,"C",XMCRE8,XMZ)) Q:'XMZ D
127 . . S XMCNT=XMCNT+1 I XMCNT#5000=0 D Q:XMABORT
128 . . . I '$D(ZTQUEUED) W:$X>40 ! W XMCNT,"." Q
129 . . . I $$S^%ZTLOAD S (XMABORT,ZTSTOP)=1 ; User asked the task to stop
130 . . I '$D(^XMB(3.9,XMZ)) K ^XMB(3.9,"C",XMCRE8,XMZ) Q
131 . . Q:$D(^XMB(3.7,"M",XMZ)) ; Msg is in someone's basket
132 . . Q:$D(^TMP("XM",$J,"NOP",XMZ)) ; Msg is one of "do not purge"
133 . . S XMZREC=$G(^XMB(3.9,XMZ,0))
134 . . Q:$P(XMZREC,U,8) ; Msg is a response
135 . . I $P($P(XMZREC,U,3),".")?7N,XMCRE8'<XMPARM("PDATE"),$O(^XMB(3.9,XMZ,1,"C",":"))'="" Q ; local msg recently sent to remote site
136 . . D PURGE(XMZ,.XMKILL)
137 Q
138PURGE(XMZ,XMKILL) ; Purge message and responses
139 N XMZR,XMIEN
140 S XMIEN=0
141 F S XMIEN=$O(^XMB(3.9,XMZ,3,XMIEN)) Q:XMIEN'>0 D
142 . S XMZR=$P($G(^XMB(3.9,XMZ,3,XMIEN,0)),U) Q:'XMZR
143 . D KILLRESP(XMZR,.XMKILL)
144 D KILLMSG(XMZ,.XMKILL)
145 Q
146KILLRESP(XMZ,XMKILL) ; Kill response
147 Q:'$D(^XMB(3.9,XMZ)) ; Response does not exist
148 Q:$D(^XMB(3.7,"M",XMZ)) ; Someone has response in mailbox
149 D KILLMSG^XMXUTIL(XMZ)
150 S XMKILL("RESP")=XMKILL("RESP")+1
151 Q
152KILLMSG(XMZ,XMKILL) ; Kill message
153 D KILLMSG^XMXUTIL(XMZ)
154 S XMKILL("MSG")=XMKILL("MSG")+1
155 Q
156CLEAN ; Clean various files
157 D CSTAT ; Clean Message Statistics file
158 D CMBOX ; Clean WASTE baskets & Postmaster's ARRIVING basket
159 S:$D(ZTQUEUED) ZTREQ="@"
160 Q
161CSTAT ; Clean Statistics file audits - delete records more than 2 years old
162 N XMINST,XMAUDT,XMCUTOFF,DA,DIK
163 S XMCUTOFF=DT\100-200 ; 2 years ago, in yyymm format
164 S XMINST=0
165 F S XMINST=$O(^XMBS(4.2999,XMINST)) Q:XMINST'>0 D
166 . S DA(1)=XMINST,DIK="^XMBS(4.2999,"_DA(1)_",100,"
167 . S XMAUDT=0
168 . F S XMAUDT=$O(^XMBS(4.2999,XMINST,100,XMAUDT)) Q:XMAUDT'>0!(XMAUDT>XMCUTOFF) D
169 . . S DA=XMAUDT D ^DIK
170 Q
171CMBOX ; Clean the mailbox file
172 N XMDUZ,XMCNT,XMABORT
173 D CARRIVE
174 S (XMDUZ,XMCNT,XMABORT)=0
175 F S XMDUZ=$O(^XMB(3.7,XMDUZ)) Q:XMDUZ'>0 D Q:XMABORT
176 . D CWASTE(XMDUZ,.XMCNT,.XMABORT)
177 W:'$D(ZTQUEUED) !,$$EZBLD^DIALOG(36431) ; Waste & Arriving Baskets Cleaned!
178 Q
179CWASTE(XMDUZ,XMCNT,XMABORT) ; Clean a user's WASTE basket
180 S XMCNT=XMCNT+1 I XMCNT#100=0 D Q:XMABORT
181 . I '$D(ZTQUEUED) W:$X>40 ! W XMCNT,"." Q
182 . I $$S^%ZTLOAD S (XMABORT,ZTSTOP)=1 ; User asked the task to stop
183 L +^XMB(3.7,XMDUZ,2,.5):5 E Q
184 N XMZ
185 S XMZ=0
186 F S XMZ=$O(^XMB(3.7,XMDUZ,2,.5,1,XMZ)) Q:XMZ'>0 K ^XMB(3.7,"M",XMZ,XMDUZ,.5)
187 K ^XMB(3.7,XMDUZ,2,.5)
188 S ^XMB(3.7,XMDUZ,2,.5,0)=$$EZBLD^DIALOG(37004) ; "WASTE"
189 S ^XMB(3.7,XMDUZ,2,.5,1,0)="^3.702P^0^0"
190 L -^XMB(3.7,XMDUZ,2,.5)
191 Q
192CARRIVE ; Clean the postmaster's ARRIVING basket
193 N XMZ,XMCNT,XMZLAST,XMDATE,XMPARM
194 S XMPARM("END")=$$PDATE(+$P($G(^XMB(1,1,.14)),U,1),2)
195 L +^XMB(3.7,.5,2,.95):5 E Q
196 S (XMZ,XMCNT,XMZLAST)=0
197 F S XMZ=$O(^XMB(3.7,.5,2,.95,1,XMZ)) Q:XMZ'>0 D
198 . I '$D(^XMB(3.9,XMZ,0)) D Q
199 . . S DA=XMZ,DA(1)=.95,DA(2)=.5,DIK="^XMB(3.7,.5,2,.95,1," D ^DIK
200 . ; If it's still arriving, its date will be a FileMan date.
201 . ; After it's finished arriving, its date will be an internet (text) date.
202 . S XMDATE=$P($G(^XMB(3.9,XMZ,0)),U,3)
203 . I XMDATE?7N1".".N,XMDATE'>XMPARM("END") D Q ; been arriving for over 24 hours
204 . . S DA=XMZ,DA(1)=.95,DA(2)=.5,DIK="^XMB(3.7,.5,2,.95,1," D ^DIK
205 . S XMCNT=XMCNT+1,XMZLAST=XMZ
206 S ^XMB(3.7,.5,2,.95,0)="ARRIVING",^(1,0)="^3.702P^"_XMZLAST_U_XMCNT
207 L -^XMB(3.7,.5,2,.95)
208 Q
Note: See TracBrowser for help on using the repository browser.