XMA3 ;ISC-SF/GMB-XMCLEAN, XMAUTOPURGE ;04/18/2002 07:09
;;8.0;MailMan;;Jun 28, 2002
; Was (WASH ISC)/CAP
;
; Entry points used by MailMan options (not covered by DBIA):
; CLEAN Option: XMCLEAN - Clean out waste baskets and
; Postmaster's ARRIVING basket
; EN Option: XMAUTOPURGE - Purge Unreferenced Messages
; SCAN Option: XMPURGE - Purge Unreferenced Messages, then STAT
; STAT Option: XMSTAT - Message Statistics
Q
EN ;
N XMPARM
D PURGEIT(.XMPARM)
S:$D(ZTQUEUED) ZTREQ="@"
Q
STAT ;
D AUDIT^XMA30 ; Show purge audit records
D USERSTAT^XMA30 ; Show user mailbox info
Q
SCAN ; PURGE MESSAGES
I $D(ZTQUEUED) G EN
N DIR,XMPARM,XMTEXT
D AUDIT^XMA30 ; Show purge audit records
S DIR(0)="E" D ^DIR Q:$D(DIRUT) K DIR
D BLD^DIALOG(36425,"","","XMTEXT","F")
;I will purge messages which are not in anybody's Mailbox.
;This will be done by comparing the message numbers in the MESSAGE file
;(3.9) against the 'M' cross reference of the MAILBOX file (3.7).
;Because this is a real-time dynamic cross reference, it is
;RECOMMENDED that you run the INTEGRITY CHECKER with some
;frequency, to CORRECT problems, if any.
I '$P($G(^XMB(1,1,.12)),U) D
. D BLD^DIALOG(36426,"","","XMTEXT","SF")
. ;A Mailbox INTEGRITY CHECK will run before the PURGE.
E D
. D BLD^DIALOG(36427,"","","XMTEXT","SF")
. ;A Mailbox INTEGRITY CHECK will NOT run before the PURGE,
. ;because your site parameters indicate you do not want it to.
. ;You may want to do a BACK-UP just before this runs, and revert
. ;to it if many problems are discovered.
W !
D MSG^DIALOG("WM","","","","XMTEXT")
W !
D GETPARMS(.XMPARM)
D BLD^DIALOG(36428,"","","DIR(""A"")") ;Do you really want to purge all unreferenced messages
S DIR("B")=$$EZBLD^DIALOG(39053) ; NO
S DIR(0)="Y"
D ^DIR Q:'Y
D WAIT^DICD
D PURGEIT(.XMPARM)
K DIR S DIR(0)="E" D ^DIR Q:$D(DIRUT) K DIR
D STAT
Q
PURGEIT(XMPARM) ;
N XMKILL,XMIEN,XMCNT,XMCRE8,XMABORT
D INIT(.XMIEN,.XMPARM,.XMKILL,.XMABORT) Q:XMABORT
D MPURGE(.XMCRE8,.XMPARM,.XMKILL,.XMCNT,.XMABORT)
D FINISH(XMIEN,XMCRE8,.XMKILL,.XMCNT,XMABORT)
Q
INIT(XMIEN,XMPARM,XMKILL,XMABORT) ;
S XMABORT=0
D:'$D(XMPARM) GETPARMS(.XMPARM)
I '$P($G(^XMB(1,1,.12)),U) D MAILBOX^XMUT4(.XMABORT) Q:XMABORT ; Integrity check
S (XMKILL("MSG"),XMKILL("RESP"))=0
S XMKILL("START")=$P(^XMB(3.9,0),U,4)
D AUDTPURG^XMA32 ; purge audit records
D DONTPURG^XMA30 ; Note all messages which shouldn't be purged
D INITAUDT^XMA32A(.XMIEN,.XMPARM)
Q
GETPARMS(XMPARM) ;
N XMSBUF,XMBUFREC
S (XMPARM("TYPE"),XMPARM("START"))=0
; Set up a date buffer, beyond which we won't purge
S XMBUFREC=$G(^XMB(1,1,.14))
S XMPARM("END")=$$PDATE(+$P(XMBUFREC,U,1),2) ; purge thru this date
S XMPARM("PDATE")=$$PDATE(+$P(XMBUFREC,U,2),7) ; don't purge local messages sent on or after this date to remote sites.
; If today is Saturday, start purge at beginning.
; If not Saturday, check MailMan Site Parameter file for field 4.304 ...
I $$DOW^XLFDT(DT,1)'=6 D
. S XMSBUF=+$P($G(^XMB(1,1,"NOTOPURGE")),U)
. I XMSBUF=0,($G(^XMB("NETNAME"))="DOMAIN.EXT"!$G(^XMB("NETNAME"))="DOMAIN.EXT") S XMSBUF=45
. Q:XMSBUF=0
. S XMPARM("START")=$$PDATE(XMSBUF,45)
Q:$D(ZTQUEUED)
N XMTEXT,XMVAR
S XMVAR(1)=$$FMTE^XLFDT($S(XMPARM("START")=0:$O(^XMB(3.9,"C",0)),1:XMPARM("START")),5)
S XMVAR(2)=$$FMTE^XLFDT(XMPARM("END"),5)
S XMVAR(3)=$$FMTE^XLFDT(XMPARM("PDATE"),5)
D BLD^DIALOG(36429,.XMVAR,"","XMTEXT","F")
D MSG^DIALOG("WM","","","","XMTEXT")
;Any unreferenced message will be purged if its local create date
;is from |1| to |2| inclusive.
;However, locally generated messages sent to remote sites will not be purged
;if they were sent on or after |3|.
;The following messages are considered 'referenced' and will not be purged:
;- Messages in users' baskets
;- Messages in transit (arriving or being sent)
;- Server messages
;- Messages being edited (includes aborted edits)
;- Later'd messages
Q
PDATE(XMDAYS,XMDEFALT) ; Subtract so many days from today and return that date.
S:+XMDAYS=0 XMDAYS=XMDEFALT ; use default if days is null
Q $$FMADD^XLFDT(DT,-XMDAYS)
FINISH(XMIEN,XMCRE8,XMKILL,XMCNT,XMABORT) ;
K ^TMP("XM",$J)
S XMKILL("TOTAL")=XMKILL("MSG")+XMKILL("RESP")
;I $G(ZTSTOP) W !!,"*** Stopping prematurely per user request ***"
I '$D(ZTQUEUED) D
. N XMVAR,XMTEXT
. S XMVAR(1)=$J(XMCNT,$L(XMKILL("START")))
. S XMVAR(2)=$J(XMKILL("TOTAL"),$L(XMKILL("START")))
. S XMVAR(3)=$J(XMKILL("START")-XMKILL("TOTAL"),$L(XMKILL("START")))
. W !
. D BLD^DIALOG(36430,.XMVAR,"","XMTEXT","F")
. D MSG^DIALOG("WM","","","","XMTEXT")
. ;|1| messages processed, |2| messages purged, |3| messages in file 3.9
D CHKAUDT^XMA32A(XMIEN,XMCRE8,.XMKILL)
Q
MPURGE(XMCRE8,XMPARM,XMKILL,XMCNT,XMABORT) ;
N XMZREC,XMZ
S XMZ="",XMCNT=0
S XMCRE8=$S(XMPARM("START")=0:0,1:$O(^XMB(3.9,"C",XMPARM("START")),-1))
F S XMCRE8=$O(^XMB(3.9,"C",XMCRE8)) Q:'XMCRE8 Q:XMCRE8>XMPARM("END") D
. F S XMZ=$O(^XMB(3.9,"C",XMCRE8,XMZ)) Q:'XMZ D
. . S XMCNT=XMCNT+1 I XMCNT#5000=0 D Q:XMABORT
. . . I '$D(ZTQUEUED) W:$X>40 ! W XMCNT,"." Q
. . . I $$S^%ZTLOAD S (XMABORT,ZTSTOP)=1 ; User asked the task to stop
. . I '$D(^XMB(3.9,XMZ)) K ^XMB(3.9,"C",XMCRE8,XMZ) Q
. . Q:$D(^XMB(3.7,"M",XMZ)) ; Msg is in someone's basket
. . Q:$D(^TMP("XM",$J,"NOP",XMZ)) ; Msg is one of "do not purge"
. . S XMZREC=$G(^XMB(3.9,XMZ,0))
. . Q:$P(XMZREC,U,8) ; Msg is a response
. . 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
. . D PURGE(XMZ,.XMKILL)
Q
PURGE(XMZ,XMKILL) ; Purge message and responses
N XMZR,XMIEN
S XMIEN=0
F S XMIEN=$O(^XMB(3.9,XMZ,3,XMIEN)) Q:XMIEN'>0 D
. S XMZR=$P($G(^XMB(3.9,XMZ,3,XMIEN,0)),U) Q:'XMZR
. D KILLRESP(XMZR,.XMKILL)
D KILLMSG(XMZ,.XMKILL)
Q
KILLRESP(XMZ,XMKILL) ; Kill response
Q:'$D(^XMB(3.9,XMZ)) ; Response does not exist
Q:$D(^XMB(3.7,"M",XMZ)) ; Someone has response in mailbox
D KILLMSG^XMXUTIL(XMZ)
S XMKILL("RESP")=XMKILL("RESP")+1
Q
KILLMSG(XMZ,XMKILL) ; Kill message
D KILLMSG^XMXUTIL(XMZ)
S XMKILL("MSG")=XMKILL("MSG")+1
Q
CLEAN ; Clean various files
D CSTAT ; Clean Message Statistics file
D CMBOX ; Clean WASTE baskets & Postmaster's ARRIVING basket
S:$D(ZTQUEUED) ZTREQ="@"
Q
CSTAT ; Clean Statistics file audits - delete records more than 2 years old
N XMINST,XMAUDT,XMCUTOFF,DA,DIK
S XMCUTOFF=DT\100-200 ; 2 years ago, in yyymm format
S XMINST=0
F S XMINST=$O(^XMBS(4.2999,XMINST)) Q:XMINST'>0 D
. S DA(1)=XMINST,DIK="^XMBS(4.2999,"_DA(1)_",100,"
. S XMAUDT=0
. F S XMAUDT=$O(^XMBS(4.2999,XMINST,100,XMAUDT)) Q:XMAUDT'>0!(XMAUDT>XMCUTOFF) D
. . S DA=XMAUDT D ^DIK
Q
CMBOX ; Clean the mailbox file
N XMDUZ,XMCNT,XMABORT
D CARRIVE
S (XMDUZ,XMCNT,XMABORT)=0
F S XMDUZ=$O(^XMB(3.7,XMDUZ)) Q:XMDUZ'>0 D Q:XMABORT
. D CWASTE(XMDUZ,.XMCNT,.XMABORT)
W:'$D(ZTQUEUED) !,$$EZBLD^DIALOG(36431) ; Waste & Arriving Baskets Cleaned!
Q
CWASTE(XMDUZ,XMCNT,XMABORT) ; Clean a user's WASTE basket
S XMCNT=XMCNT+1 I XMCNT#100=0 D Q:XMABORT
. I '$D(ZTQUEUED) W:$X>40 ! W XMCNT,"." Q
. I $$S^%ZTLOAD S (XMABORT,ZTSTOP)=1 ; User asked the task to stop
L +^XMB(3.7,XMDUZ,2,.5):5 E Q
N XMZ
S XMZ=0
F S XMZ=$O(^XMB(3.7,XMDUZ,2,.5,1,XMZ)) Q:XMZ'>0 K ^XMB(3.7,"M",XMZ,XMDUZ,.5)
K ^XMB(3.7,XMDUZ,2,.5)
S ^XMB(3.7,XMDUZ,2,.5,0)=$$EZBLD^DIALOG(37004) ; "WASTE"
S ^XMB(3.7,XMDUZ,2,.5,1,0)="^3.702P^0^0"
L -^XMB(3.7,XMDUZ,2,.5)
Q
CARRIVE ; Clean the postmaster's ARRIVING basket
N XMZ,XMCNT,XMZLAST,XMDATE,XMPARM
S XMPARM("END")=$$PDATE(+$P($G(^XMB(1,1,.14)),U,1),2)
L +^XMB(3.7,.5,2,.95):5 E Q
S (XMZ,XMCNT,XMZLAST)=0
F S XMZ=$O(^XMB(3.7,.5,2,.95,1,XMZ)) Q:XMZ'>0 D
. I '$D(^XMB(3.9,XMZ,0)) D Q
. . S DA=XMZ,DA(1)=.95,DA(2)=.5,DIK="^XMB(3.7,.5,2,.95,1," D ^DIK
. ; If it's still arriving, its date will be a FileMan date.
. ; After it's finished arriving, its date will be an internet (text) date.
. S XMDATE=$P($G(^XMB(3.9,XMZ,0)),U,3)
. I XMDATE?7N1".".N,XMDATE'>XMPARM("END") D Q ; been arriving for over 24 hours
. . S DA=XMZ,DA(1)=.95,DA(2)=.5,DIK="^XMB(3.7,.5,2,.95,1," D ^DIK
. S XMCNT=XMCNT+1,XMZLAST=XMZ
S ^XMB(3.7,.5,2,.95,0)="ARRIVING",^(1,0)="^3.702P^"_XMZLAST_U_XMCNT
L -^XMB(3.7,.5,2,.95)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMA3 8479 printed Apr 09, 2024@21:16:17 Page 2
XMA3 ;ISC-SF/GMB-XMCLEAN, XMAUTOPURGE ;04/18/2002 07:09
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 ; Was (WASH ISC)/CAP
+3 ;
+4 ; Entry points used by MailMan options (not covered by DBIA):
+5 ; CLEAN Option: XMCLEAN - Clean out waste baskets and
+6 ; Postmaster's ARRIVING basket
+7 ; EN Option: XMAUTOPURGE - Purge Unreferenced Messages
+8 ; SCAN Option: XMPURGE - Purge Unreferenced Messages, then STAT
+9 ; STAT Option: XMSTAT - Message Statistics
+10 QUIT
EN ;
+1 NEW XMPARM
+2 DO PURGEIT(.XMPARM)
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
STAT ;
+1 ; Show purge audit records
DO AUDIT^XMA30
+2 ; Show user mailbox info
DO USERSTAT^XMA30
+3 QUIT
SCAN ; PURGE MESSAGES
+1 IF $DATA(ZTQUEUED)
GOTO EN
+2 NEW DIR,XMPARM,XMTEXT
+3 ; Show purge audit records
DO AUDIT^XMA30
+4 SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
QUIT
KILL DIR
+5 DO BLD^DIALOG(36425,"","","XMTEXT","F")
+6 ;I will purge messages which are not in anybody's Mailbox.
+7 ;This will be done by comparing the message numbers in the MESSAGE file
+8 ;(3.9) against the 'M' cross reference of the MAILBOX file (3.7).
+9 ;Because this is a real-time dynamic cross reference, it is
+10 ;RECOMMENDED that you run the INTEGRITY CHECKER with some
+11 ;frequency, to CORRECT problems, if any.
+12 IF '$PIECE($GET(^XMB(1,1,.12)),U)
Begin DoDot:1
+13 DO BLD^DIALOG(36426,"","","XMTEXT","SF")
+14 ;A Mailbox INTEGRITY CHECK will run before the PURGE.
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 DO BLD^DIALOG(36427,"","","XMTEXT","SF")
+17 ;A Mailbox INTEGRITY CHECK will NOT run before the PURGE,
+18 ;because your site parameters indicate you do not want it to.
+19 ;You may want to do a BACK-UP just before this runs, and revert
+20 ;to it if many problems are discovered.
End DoDot:1
+21 WRITE !
+22 DO MSG^DIALOG("WM","","","","XMTEXT")
+23 WRITE !
+24 DO GETPARMS(.XMPARM)
+25 ;Do you really want to purge all unreferenced messages
DO BLD^DIALOG(36428,"","","DIR(""A"")")
+26 ; NO
SET DIR("B")=$$EZBLD^DIALOG(39053)
+27 SET DIR(0)="Y"
+28 DO ^DIR
if 'Y
QUIT
+29 DO WAIT^DICD
+30 DO PURGEIT(.XMPARM)
+31 KILL DIR
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
QUIT
KILL DIR
+32 DO STAT
+33 QUIT
PURGEIT(XMPARM) ;
+1 NEW XMKILL,XMIEN,XMCNT,XMCRE8,XMABORT
+2 DO INIT(.XMIEN,.XMPARM,.XMKILL,.XMABORT)
if XMABORT
QUIT
+3 DO MPURGE(.XMCRE8,.XMPARM,.XMKILL,.XMCNT,.XMABORT)
+4 DO FINISH(XMIEN,XMCRE8,.XMKILL,.XMCNT,XMABORT)
+5 QUIT
INIT(XMIEN,XMPARM,XMKILL,XMABORT) ;
+1 SET XMABORT=0
+2 if '$DATA(XMPARM)
DO GETPARMS(.XMPARM)
+3 ; Integrity check
IF '$PIECE($GET(^XMB(1,1,.12)),U)
DO MAILBOX^XMUT4(.XMABORT)
if XMABORT
QUIT
+4 SET (XMKILL("MSG"),XMKILL("RESP"))=0
+5 SET XMKILL("START")=$PIECE(^XMB(3.9,0),U,4)
+6 ; purge audit records
DO AUDTPURG^XMA32
+7 ; Note all messages which shouldn't be purged
DO DONTPURG^XMA30
+8 DO INITAUDT^XMA32A(.XMIEN,.XMPARM)
+9 QUIT
GETPARMS(XMPARM) ;
+1 NEW XMSBUF,XMBUFREC
+2 SET (XMPARM("TYPE"),XMPARM("START"))=0
+3 ; Set up a date buffer, beyond which we won't purge
+4 SET XMBUFREC=$GET(^XMB(1,1,.14))
+5 ; purge thru this date
SET XMPARM("END")=$$PDATE(+$PIECE(XMBUFREC,U,1),2)
+6 ; don't purge local messages sent on or after this date to remote sites.
SET XMPARM("PDATE")=$$PDATE(+$PIECE(XMBUFREC,U,2),7)
+7 ; If today is Saturday, start purge at beginning.
+8 ; If not Saturday, check MailMan Site Parameter file for field 4.304 ...
+9 IF $$DOW^XLFDT(DT,1)'=6
Begin DoDot:1
+10 SET XMSBUF=+$PIECE($GET(^XMB(1,1,"NOTOPURGE")),U)
+11 IF XMSBUF=0
IF ($GET(^XMB("NETNAME"))="DOMAIN.EXT"!$GET(^XMB("NETNAME"))="DOMAIN.EXT")
SET XMSBUF=45
+12 if XMSBUF=0
QUIT
+13 SET XMPARM("START")=$$PDATE(XMSBUF,45)
End DoDot:1
+14 if $DATA(ZTQUEUED)
QUIT
+15 NEW XMTEXT,XMVAR
+16 SET XMVAR(1)=$$FMTE^XLFDT($SELECT(XMPARM("START")=0:$ORDER(^XMB(3.9,"C",0)),1:XMPARM("START")),5)
+17 SET XMVAR(2)=$$FMTE^XLFDT(XMPARM("END"),5)
+18 SET XMVAR(3)=$$FMTE^XLFDT(XMPARM("PDATE"),5)
+19 DO BLD^DIALOG(36429,.XMVAR,"","XMTEXT","F")
+20 DO MSG^DIALOG("WM","","","","XMTEXT")
+21 ;Any unreferenced message will be purged if its local create date
+22 ;is from |1| to |2| inclusive.
+23 ;However, locally generated messages sent to remote sites will not be purged
+24 ;if they were sent on or after |3|.
+25 ;The following messages are considered 'referenced' and will not be purged:
+26 ;- Messages in users' baskets
+27 ;- Messages in transit (arriving or being sent)
+28 ;- Server messages
+29 ;- Messages being edited (includes aborted edits)
+30 ;- Later'd messages
+31 QUIT
PDATE(XMDAYS,XMDEFALT) ; Subtract so many days from today and return that date.
+1 ; use default if days is null
if +XMDAYS=0
SET XMDAYS=XMDEFALT
+2 QUIT $$FMADD^XLFDT(DT,-XMDAYS)
FINISH(XMIEN,XMCRE8,XMKILL,XMCNT,XMABORT) ;
+1 KILL ^TMP("XM",$JOB)
+2 SET XMKILL("TOTAL")=XMKILL("MSG")+XMKILL("RESP")
+3 ;I $G(ZTSTOP) W !!,"*** Stopping prematurely per user request ***"
+4 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+5 NEW XMVAR,XMTEXT
+6 SET XMVAR(1)=$JUSTIFY(XMCNT,$LENGTH(XMKILL("START")))
+7 SET XMVAR(2)=$JUSTIFY(XMKILL("TOTAL"),$LENGTH(XMKILL("START")))
+8 SET XMVAR(3)=$JUSTIFY(XMKILL("START")-XMKILL("TOTAL"),$LENGTH(XMKILL("START")))
+9 WRITE !
+10 DO BLD^DIALOG(36430,.XMVAR,"","XMTEXT","F")
+11 DO MSG^DIALOG("WM","","","","XMTEXT")
+12 ;|1| messages processed, |2| messages purged, |3| messages in file 3.9
End DoDot:1
+13 DO CHKAUDT^XMA32A(XMIEN,XMCRE8,.XMKILL)
+14 QUIT
MPURGE(XMCRE8,XMPARM,XMKILL,XMCNT,XMABORT) ;
+1 NEW XMZREC,XMZ
+2 SET XMZ=""
SET XMCNT=0
+3 SET XMCRE8=$SELECT(XMPARM("START")=0:0,1:$ORDER(^XMB(3.9,"C",XMPARM("START")),-1))
+4 FOR
SET XMCRE8=$ORDER(^XMB(3.9,"C",XMCRE8))
if 'XMCRE8
QUIT
if XMCRE8>XMPARM("END")
QUIT
Begin DoDot:1
+5 FOR
SET XMZ=$ORDER(^XMB(3.9,"C",XMCRE8,XMZ))
if 'XMZ
QUIT
Begin DoDot:2
+6 SET XMCNT=XMCNT+1
IF XMCNT#5000=0
Begin DoDot:3
+7 IF '$DATA(ZTQUEUED)
if $X>40
WRITE !
WRITE XMCNT,"."
QUIT
+8 ; User asked the task to stop
IF $$S^%ZTLOAD
SET (XMABORT,ZTSTOP)=1
End DoDot:3
if XMABORT
QUIT
+9 IF '$DATA(^XMB(3.9,XMZ))
KILL ^XMB(3.9,"C",XMCRE8,XMZ)
QUIT
+10 ; Msg is in someone's basket
if $DATA(^XMB(3.7,"M",XMZ))
QUIT
+11 ; Msg is one of "do not purge"
if $DATA(^TMP("XM",$JOB,"NOP",XMZ))
QUIT
+12 SET XMZREC=$GET(^XMB(3.9,XMZ,0))
+13 ; Msg is a response
if $PIECE(XMZREC,U,8)
QUIT
+14 ; local msg recently sent to remote site
IF $PIECE($PIECE(XMZREC,U,3),".")?7N
IF XMCRE8'<XMPARM("PDATE")
IF $ORDER(^XMB(3.9,XMZ,1,"C",":"))'=""
QUIT
+15 DO PURGE(XMZ,.XMKILL)
End DoDot:2
End DoDot:1
+16 QUIT
PURGE(XMZ,XMKILL) ; Purge message and responses
+1 NEW XMZR,XMIEN
+2 SET XMIEN=0
+3 FOR
SET XMIEN=$ORDER(^XMB(3.9,XMZ,3,XMIEN))
if XMIEN'>0
QUIT
Begin DoDot:1
+4 SET XMZR=$PIECE($GET(^XMB(3.9,XMZ,3,XMIEN,0)),U)
if 'XMZR
QUIT
+5 DO KILLRESP(XMZR,.XMKILL)
End DoDot:1
+6 DO KILLMSG(XMZ,.XMKILL)
+7 QUIT
KILLRESP(XMZ,XMKILL) ; Kill response
+1 ; Response does not exist
if '$DATA(^XMB(3.9,XMZ))
QUIT
+2 ; Someone has response in mailbox
if $DATA(^XMB(3.7,"M",XMZ))
QUIT
+3 DO KILLMSG^XMXUTIL(XMZ)
+4 SET XMKILL("RESP")=XMKILL("RESP")+1
+5 QUIT
KILLMSG(XMZ,XMKILL) ; Kill message
+1 DO KILLMSG^XMXUTIL(XMZ)
+2 SET XMKILL("MSG")=XMKILL("MSG")+1
+3 QUIT
CLEAN ; Clean various files
+1 ; Clean Message Statistics file
DO CSTAT
+2 ; Clean WASTE baskets & Postmaster's ARRIVING basket
DO CMBOX
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
CSTAT ; Clean Statistics file audits - delete records more than 2 years old
+1 NEW XMINST,XMAUDT,XMCUTOFF,DA,DIK
+2 ; 2 years ago, in yyymm format
SET XMCUTOFF=DT\100-200
+3 SET XMINST=0
+4 FOR
SET XMINST=$ORDER(^XMBS(4.2999,XMINST))
if XMINST'>0
QUIT
Begin DoDot:1
+5 SET DA(1)=XMINST
SET DIK="^XMBS(4.2999,"_DA(1)_",100,"
+6 SET XMAUDT=0
+7 FOR
SET XMAUDT=$ORDER(^XMBS(4.2999,XMINST,100,XMAUDT))
if XMAUDT'>0!(XMAUDT>XMCUTOFF)
QUIT
Begin DoDot:2
+8 SET DA=XMAUDT
DO ^DIK
End DoDot:2
End DoDot:1
+9 QUIT
CMBOX ; Clean the mailbox file
+1 NEW XMDUZ,XMCNT,XMABORT
+2 DO CARRIVE
+3 SET (XMDUZ,XMCNT,XMABORT)=0
+4 FOR
SET XMDUZ=$ORDER(^XMB(3.7,XMDUZ))
if XMDUZ'>0
QUIT
Begin DoDot:1
+5 DO CWASTE(XMDUZ,.XMCNT,.XMABORT)
End DoDot:1
if XMABORT
QUIT
+6 ; Waste & Arriving Baskets Cleaned!
if '$DATA(ZTQUEUED)
WRITE !,$$EZBLD^DIALOG(36431)
+7 QUIT
CWASTE(XMDUZ,XMCNT,XMABORT) ; Clean a user's WASTE basket
+1 SET XMCNT=XMCNT+1
IF XMCNT#100=0
Begin DoDot:1
+2 IF '$DATA(ZTQUEUED)
if $X>40
WRITE !
WRITE XMCNT,"."
QUIT
+3 ; User asked the task to stop
IF $$S^%ZTLOAD
SET (XMABORT,ZTSTOP)=1
End DoDot:1
if XMABORT
QUIT
+4 LOCK +^XMB(3.7,XMDUZ,2,.5):5
IF '$TEST
QUIT
+5 NEW XMZ
+6 SET XMZ=0
+7 FOR
SET XMZ=$ORDER(^XMB(3.7,XMDUZ,2,.5,1,XMZ))
if XMZ'>0
QUIT
KILL ^XMB(3.7,"M",XMZ,XMDUZ,.5)
+8 KILL ^XMB(3.7,XMDUZ,2,.5)
+9 ; "WASTE"
SET ^XMB(3.7,XMDUZ,2,.5,0)=$$EZBLD^DIALOG(37004)
+10 SET ^XMB(3.7,XMDUZ,2,.5,1,0)="^3.702P^0^0"
+11 LOCK -^XMB(3.7,XMDUZ,2,.5)
+12 QUIT
CARRIVE ; Clean the postmaster's ARRIVING basket
+1 NEW XMZ,XMCNT,XMZLAST,XMDATE,XMPARM
+2 SET XMPARM("END")=$$PDATE(+$PIECE($GET(^XMB(1,1,.14)),U,1),2)
+3 LOCK +^XMB(3.7,.5,2,.95):5
IF '$TEST
QUIT
+4 SET (XMZ,XMCNT,XMZLAST)=0
+5 FOR
SET XMZ=$ORDER(^XMB(3.7,.5,2,.95,1,XMZ))
if XMZ'>0
QUIT
Begin DoDot:1
+6 IF '$DATA(^XMB(3.9,XMZ,0))
Begin DoDot:2
+7 SET DA=XMZ
SET DA(1)=.95
SET DA(2)=.5
SET DIK="^XMB(3.7,.5,2,.95,1,"
DO ^DIK
End DoDot:2
QUIT
+8 ; If it's still arriving, its date will be a FileMan date.
+9 ; After it's finished arriving, its date will be an internet (text) date.
+10 SET XMDATE=$PIECE($GET(^XMB(3.9,XMZ,0)),U,3)
+11 ; been arriving for over 24 hours
IF XMDATE?7N1".".N
IF XMDATE'>XMPARM("END")
Begin DoDot:2
+12 SET DA=XMZ
SET DA(1)=.95
SET DA(2)=.5
SET DIK="^XMB(3.7,.5,2,.95,1,"
DO ^DIK
End DoDot:2
QUIT
+13 SET XMCNT=XMCNT+1
SET XMZLAST=XMZ
End DoDot:1
+14 SET ^XMB(3.7,.5,2,.95,0)="ARRIVING"
SET ^(1,0)="^3.702P^"_XMZLAST_U_XMCNT
+15 LOCK -^XMB(3.7,.5,2,.95)
+16 QUIT
