source: WorldVistAEHR/trunk/r/MAILMAN-XM/XMA32.m@ 1651

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

initial load of WorldVistAEHR

File size: 6.7 KB
Line 
1XMA32 ;ISC-SF/GMB-Purge Messages by Date ;04/17/2002 07:20
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 ; ENTER XMPURGE-BY-DATE - Purge messages by local create date.
7ENTER ;
8 N XMABORT,XMPARM
9 I $D(ZTQUEUED) S ZTREQ="@"
10 S XMABORT=0
11 D INIT(.XMPARM,.XMABORT) Q:XMABORT
12 D SETUP(.XMPARM,.XMABORT) Q:XMABORT
13 D PROCESS(.XMPARM)
14 Q
15INIT(XMPARM,XMABORT) ;
16 N XMKEY,XMTEXT
17 F XMKEY="XMMGR","XMSTAR" D Q:XMABORT
18 . Q:$D(^XUSEC(XMKEY,DUZ))
19 . S XMABORT=1
20 . ;You must hold the |1| key to run this option.
21 . W !
22 . D BLD^DIALOG(36400,XMKEY,"","XMTEXT","F")
23 . D MSG^DIALOG("WE","","","","XMTEXT")
24 Q:XMABORT
25 N XMREC
26 S XMREC=$G(^XMB(1,1,.18))
27 S XMPARM("PDAYS")=$S($P(XMREC,U,1):$P(XMREC,U,1),1:730)
28 I $D(ZTQUEUED),XMPARM("PDAYS")<365 S XMPARM("PDAYS")=730
29 S XMPARM("GRACE")=+$P(XMREC,U,2)
30 D AUDTPURG
31 Q:$D(ZTQUEUED)
32 W !
33 D BLD^DIALOG(36401,"","","XMTEXT","F")
34 D MSG^DIALOG("WM","","","","XMTEXT")
35 ;This process REMOVES MESSAGES PERMANENTLY from the system.
36 ; ***** BE VERY CAREFUL *****
37 I $D(^XMB(1,1,.1,0)) D LAST(.XMPARM)
38 Q
39LAST(XMPARM) ; Find the audit record for the last date purge
40 N XMLIEN,XMREC,XMDIFF,XMTEXT,XMVAR
41 S XMLIEN=":"
42 F S XMLIEN=$O(^XMB(1,1,.1,XMLIEN),-1) Q:'XMLIEN Q:$P(^(XMLIEN,0),U,6)
43 Q:'XMLIEN
44 S XMREC=^XMB(1,1,.1,XMLIEN,0)
45 D BLD^DIALOG($S($P(XMREC,U,6)["TEST":36402.1,1:36402),$$FMTE^XLFDT($P(XMREC,U),5),"","XMTEXT","F")
46 ;This process was last run on |1| (in TEST mode).
47 S XMDIFF=$$FMDIFF^XLFDT($P(XMREC,U,1),$P(XMREC,U,7),1) ; difference in days
48 S XMVAR(1)=$$FMTE^XLFDT($P(XMREC,U,7),5),XMVAR(2)=XMDIFF
49 W !
50 D BLD^DIALOG(36403,.XMVAR,"","XMTEXT","FS")
51 D MSG^DIALOG("WM","","","","XMTEXT")
52 ;The PURGE DATE used was |1|.
53 ;(Messages more than |2| days old were purged.)
54 W !
55 Q
56AUDTPURG ; Kill off the earliest purge entries, so that only a certain # remain.
57 N XMREC,XMCNT,DA,DIK,XMMAX
58 S XMMAX=20
59 S XMREC=$G(^XMB(1,1,.1,0))
60 S XMCNT=$P(XMREC,U,4)
61 Q:XMCNT'>XMMAX
62 S DA=0
63 F S DA=$O(^XMB(1,1,.1,0)) Q:DA'>0 D Q:XMCNT'>XMMAX
64 . S XMCNT=XMCNT-1
65 . S DA(1)=1,DIK="^XMB(1,1,.1,"
66 . D ^DIK
67 Q
68SETUP(XMPARM,XMABORT) ;
69 D PDATE(.XMPARM,.XMABORT) Q:XMABORT ; Purge date
70 D TESTMODE(.XMPARM,.XMABORT) Q:XMABORT ; Test mode?
71 D GRACE(.XMPARM,.XMABORT) Q:XMABORT ; Grace days
72 Q
73PDATE(XMPARM,XMABORT) ;
74 N DIR,X,Y,XMOK,XMOLDEST,XMCUTOFF,XMOLDP1,XMDIFF,XMVAR
75 ; Find the oldest date. Kill any bogus xrefs.
76 F S XMOLDEST=$O(^XMB(3.9,"C","")) Q:XMOLDEST?7N K ^XMB(3.9,"C",XMOLDEST)
77 S XMOLDP1=$$FMADD^XLFDT(XMOLDEST,1)
78 I $D(ZTQUEUED) D Q
79 . S XMCUTOFF=$$FMADD^XLFDT(DT,XMPARM("GRACE")-XMPARM("PDAYS"))
80 . I XMOLDP1>XMCUTOFF S XMABORT=1 Q ; Abort if no messages that old.
81 . S XMPARM("PDATE")=XMCUTOFF
82 S XMCUTOFF=$$FMADD^XLFDT(DT,-XMPARM("PDAYS"))
83 I XMOLDP1>XMCUTOFF S XMCUTOFF=XMOLDP1
84 S XMOK=0
85 F D Q:XMOK!XMABORT
86 . S DIR(0)="D^"_XMOLDP1_":DT:E"
87 . D BLD^DIALOG(36404,$$FMTE^XLFDT(XMOLDEST,5),"","DIR(""A"")")
88 . ;The oldest message on the system is from |1|.
89 . ;Purge all messages originating before
90 . S DIR("B")=$$FMTE^XLFDT(XMCUTOFF,5)
91 . D BLD^DIALOG(36405,"","","DIR(""?"")")
92 . ;All messages whose 'local create date' is prior to the
93 . ;'purge date' you enter will be deleted from the system,
94 . ;except those which are in one of SHARED,MAIL's baskets,
95 . ;OR in POSTMASTER's server baskets or remote transmit queues.
96 . S DIR("??")="^N %DT S %DT=0 D HELP^%DTC"
97 . D ^DIR I $D(DIRUT) S XMABORT=1 Q
98 . S XMPARM("PDATE")=Y
99 . I DT-Y>10000 S XMOK=1 Q
100 . D ZIS^XM
101 . ;The date you entered is less than 1 year ago.
102 . W !!,$S($D(IORVON):IORVON,1:""),$S($D(IOBON):IOBON,1:""),$$EZBLD^DIALOG(36406),$S($D(IOBOFF):IOBOFF,1:""),$C(7),$S($D(IORVOFF):IORVOFF,1:"")
103 . K DIR
104 . S DIR(0)="Y"
105 . S DIR("A")=$$EZBLD^DIALOG(36407) ; Are you sure about this date
106 . S DIR("B")=$$EZBLD^DIALOG(39053) ; No
107 . D ^DIR I $D(DIRUT) S XMABORT=1 Q
108 . S XMOK=Y
109 . K DIR
110 Q:XMABORT
111 S XMDIFF=$$FMDIFF^XLFDT(DT,XMPARM("PDATE"),1)
112 I XMDIFF=XMPARM("PDAYS")!(XMDIFF<365)!(XMDIFF>9999) Q
113 W !
114 K DIR,X,Y
115 S XMVAR(1)=XMDIFF,XMVAR(2)=XMPARM("PDAYS")
116 S DIR(0)="Y"
117 ;You have chosen to purge messages older than |1| days old,
118 ;which is different from the current default of |2|.
119 ;Do you want |1| to be the new default
120 D BLD^DIALOG(36408,.XMVAR,"","DIR(""A"")")
121 S DIR("B")=$$EZBLD^DIALOG(39053) ; No
122 D BLD^DIALOG(36409,.XMVAR,"","DIR(""?"")")
123 ;Answer YES if you want field 10.03, DATE PURGE CUTOFF DAYS,
124 ;in file 4.3, MAILMAN SITE PARAMETERS, to be set to |1|.
125 ;Answer NO if you want that field to remain |2|.
126 ;You can also edit this field using option XMKSP."
127 D ^DIR I $D(DIRUT) S XMABORT=1 Q
128 I Y S $P(^XMB(1,1,.18),U,1)=XMDIFF
129 S XMPARM("PDAYS")=XMDIFF
130 Q
131TESTMODE(XMPARM,XMABORT) ;
132 I $D(ZTQUEUED) D Q
133 . S XMPARM("TEST")=0
134 . S XMPARM("TYPE")=1
135 W !
136 N DIR,X,Y
137 S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(36410) ; TEST mode
138 S DIR("B")=$$EZBLD^DIALOG(39054) ; YES
139 D BLD^DIALOG(36411,"","","DIR(""?"")")
140 ;Test mode will not kill off messages.
141 ;Test mode gives you a list of what would happen in 'real' mode.
142 ;If you do not run in test mode, messages will be KILLED!
143 ;Enter YES to run in 'test' mode; NO, 'real' mode.
144 D ^DIR I $D(DIRUT) S XMABORT=1 Q
145 S XMPARM("TEST")=Y
146 S XMPARM("TYPE")=$S(XMPARM("TEST"):2,1:1)
147 Q
148GRACE(XMPARM,XMABORT) ;
149 Q:$D(ZTQUEUED)
150 N XMTEXT
151 W !
152 I XMPARM("TEST") D Q
153 . S XMPARM("GRACE")=0
154 . D BLD^DIALOG(36412,"","","XMTEXT","F")
155 . D MSG^DIALOG("WM","","","","XMTEXT")
156 . ;Since we are running in test mode, no warning bulletin will be sent.
157 D BLD^DIALOG(36412.1,"","","XMTEXT","F")
158 D MSG^DIALOG("WM","","","","XMTEXT")
159 ;If you queue this purge to run 3 or more days from now, I will send
160 ;a bulletin, XM DATE PURGE WARNING, to all users to warn them of the
161 ;coming date purge and tell them how to identify all of the messages
162 ;in their mailbox, which may be affected.
163 Q
164PROCESS(XMPARM) ;
165 N ZTSAVE,ZTRTN,ZTDESC,ZTSK,XMHNOW
166 S ZTSAVE("XMPARM*")=""
167 S ZTDESC=$$EZBLD^DIALOG(36413) ;MailMan: MESSAGE PURGE by DATE
168 S ZTRTN="ENT^XMA32A"
169 I '$D(ZTQUEUED) D Q:'$D(ZTSK)
170 . S XMHNOW=$H
171 . D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,,1)
172 E D
173 . S ZTDTH=$$HADD^XLFDT(ZTDTH,XMPARM("GRACE"))
174 . D ^%ZTLOAD
175 I '$D(ZTQUEUED),$$HDIFF^XLFDT(ZTSK("D"),XMHNOW,1)<3 D Q
176 . N XMTEXT
177 . W !
178 . D BLD^DIALOG(36414,"","","XMTEXT","F")
179 . D MSG^DIALOG("WM","","","","XMTEXT")
180 . ;Since you scheduled the date purge less than 3 days from now,
181 . ;no warning bulletin has been sent.
182 N XMP,XMINSTR
183 S XMINSTR("VAPOR")=$$HTFM^XLFDT($$HADD^XLFDT(ZTSK("D"),,-1)) ; Vaporize 1 hr before purge
184 S XMINSTR("FROM")=.5
185 S XMP(1)=$$HTE^XLFDT(ZTSK("D"),5)
186 S XMP(2)=$$FMTE^XLFDT($$FMADD^XLFDT(XMPARM("PDATE"),-1),5)
187 S XMP(3)=$E("==========",1,$L(XMP(2)))
188 D TASKBULL^XMXAPI(DUZ,"XM DATE PURGE WARNING",.XMP,,"*",.XMINSTR)
189 Q:$D(ZTQUEUED)
190 W !
191 W $$EZBLD^DIALOG(36415) ;The warning bulletin has been sent.
192 Q
Note: See TracBrowser for help on using the repository browser.