XMA32A ;ISC-SF/GMB-Purge Messages by Date (cont.) ;12/04/2002 13:42
;;8.0;MailMan;**10**;Jun 28, 2002
; Was (WASH ISC)/CAP
;
; XMPARM("PDATE") Purge all messages older than this date
; XMCNT Total messages processed
; XMKILL("START") Messages in ^XMB(3.9 before purge started
; XMKILL("MSG") Messages purged
; XMKILL("RESP") Responses killed
; XMDUZ Pointer to mailbox
; XMZ Current message being processed
ENT ;
N XMCRE8,XMIEN,XMCNT,XMKILL,XMHDR,XMABORT
D INIT(.XMIEN,.XMPARM,.XMKILL,.XMHDR,.XMABORT)
D PROCESS(XMIEN,.XMCRE8,.XMPARM,.XMKILL,.XMCNT,.XMHDR,.XMABORT)
D FINISH(XMIEN,XMCRE8,.XMPARM,.XMKILL,XMCNT,.XMHDR,.XMABORT)
Q
INIT(XMIEN,XMPARM,XMKILL,XMHDR,XMABORT) ;
I IO'=IO(0) U IO
S (XMHDR("PAGE"),XMKILL("MSG"),XMKILL("RESP"),XMABORT)=0
S XMKILL("START")=$P(^XMB(3.9,0),U,4)
D INITAUDT(.XMIEN,.XMPARM,.XMHDR)
S XMHDR("PDATE")=$$FMTE^XLFDT(XMPARM("PDATE"),5)
S XMHDR("NOW")=$$FMTE^XLFDT(XMHDR("NOW"),5)
Q:IO=""
W:$E(IOST,1,2)="C-" @IOF D PRTHDR(.XMPARM,.XMHDR)
Q
INITAUDT(XMIEN,XMPARM,XMHDR) ;
N XMFDA
S XMHDR("NOW")=$$NOW^XLFDT
S XMFDA(4.302,"+1,1,",.01)=XMHDR("NOW")
S:$D(XMPARM("START")) XMFDA(4.302,"+1,1,",3)=XMPARM("START")
S:$D(XMPARM("END")) XMFDA(4.302,"+1,1,",4)=XMPARM("END")
S XMFDA(4.302,"+1,1,",5)=$S(XMPARM("TYPE")=2:"1TEST",1:XMPARM("TYPE"))
S XMFDA(4.302,"+1,1,",6)=XMPARM("PDATE")
D UPDATE^DIE("","XMFDA","XMIEN")
S XMIEN=XMIEN(1)
Q
PROCESS(XMIEN,XMCRE8,XMPARM,XMKILL,XMCNT,XMHDR,XMABORT) ;
N XMZ,XMZREC
S (XMCRE8,XMZ)="",XMCNT=0
F S XMCRE8=$O(^XMB(3.9,"C",XMCRE8)) Q:'XMCRE8 Q:XMCRE8'<XMPARM("PDATE") D Q:XMABORT
. F S XMZ=$O(^XMB(3.9,"C",XMCRE8,XMZ)) Q:'XMZ D Q:XMABORT
. . S XMCNT=XMCNT+1 I XMCNT#5000=0 D CHK(XMIEN,XMCRE8,.XMPARM,.XMKILL,XMCNT,.XMHDR,.XMABORT)
. . I '$D(^XMB(3.9,XMZ)) K ^XMB(3.9,"C",XMCRE8,XMZ) Q
. . S XMZREC=$G(^XMB(3.9,XMZ,0))
. . Q:$P(XMZREC,U,8) ; Don't kill responses (they'll be purged when their original msg is)
. . I "^^^^^^^^"[XMZREC D KILL(XMZ,.XMKILL,.XMABORT,.XMPARM,.XMHDR) Q
. . Q:$D(^XMB(3.7,"M",XMZ,.6)) ; Do nothing if owned by SHARED,MAIL
. . Q:$O(^XMB(3.7,"M",XMZ,.5,999)) ; Do nothing if in Transmit queues or Server basket.
. . D KILL(XMZ,.XMKILL,.XMABORT,.XMPARM,.XMHDR)
. . ; Old msg; old response without original msg;
. . ; Old msg which thinks it's also a response;
. . ; Old response which thinks it's also the original msg.
Q
KILL(XMZ,XMKILL,XMABORT,XMPARM,XMHDR) ;
I $G(XMPARM("TEST")) D Q:XMABORT
. D HDR(2,.XMPARM,.XMHDR,.XMABORT) Q:XMABORT
. W !,XMZ,?20,$$EZBLD^DIALOG(36416),$$FMTE^XLFDT(XMCRE8,5) ; " <<< Purge! Date = "
D KBASKETS(XMZ,.XMKILL,.XMPARM,.XMHDR,.XMABORT) Q:XMABORT
D KMSG(XMZ,.XMKILL,.XMPARM,.XMHDR,.XMABORT) Q:XMABORT
D KLATER(XMZ,.XMPARM)
Q
KBASKETS(XMZ,XMKILL,XMPARM,XMHDR,XMABORT) ;
N XMDUZ,XMK
S XMDUZ="",XMKILL("MSG")=XMKILL("MSG")+1
F S XMDUZ=$O(^XMB(3.7,"M",XMZ,XMDUZ)) Q:XMDUZ=""!XMABORT D
. S XMK=$O(^XMB(3.7,"M",XMZ,XMDUZ,0))
. Q:'XMK
. Q:'$D(^XMB(3.7,XMDUZ,2,XMK,1,XMZ))
. I $G(XMPARM("TEST")) D Q
. . D HDR(2,.XMPARM,.XMHDR,.XMABORT) Q:XMABORT
. . W !?25,$$EZBLD^DIALOG(36417),?50,$J(XMDUZ,12),?79 ; Message deleted for DUZ:
. D ZAPIT^XMXMSGS2(XMDUZ,XMK,XMZ) ; Delete from user's basket
Q
KMSG(XMZ,XMKILL,XMPARM,XMHDR,XMABORT) ;
N XMZR,XMIEN,X
S XMIEN=0
F S XMIEN=$O(^XMB(3.9,XMZ,3,XMIEN)) Q:XMIEN'>0!XMABORT D
. S XMZR=$P($G(^XMB(3.9,XMZ,3,XMIEN,0)),U)
. S XMKILL("RESP")=XMKILL("RESP")+1
. I $G(XMPARM("TEST")) D Q
. . D HDR(2,.XMPARM,.XMHDR,.XMABORT) Q:XMABORT
. . W !?25,$$EZBLD^DIALOG(36418),?50,$J(XMZR,20),?79 ; Response deleted:
. D KILLMSG^XMXUTIL(XMZR) ; Kill response
D:'$G(XMPARM("TEST")) KILLMSG^XMXUTIL(XMZ) ; Kill original message
Q
KLATER(XMZ,XMPARM) ;
Q:$G(XMPARM("TEST"))
N DIK,DA,XMDUZ
S DIK="^XMB(3.73,"
S (XMDUZ,DA)=""
F S XMDUZ=$O(^XMB(3.73,"AC",XMZ,XMDUZ)) Q:'XMDUZ D
. F S DA=$O(^XMB(3.73,"AC",XMZ,XMDUZ,DA)) Q:'DA D ^DIK
Q
HDR(XMLINES,XMPARM,XMHDR,XMABORT) ;
Q:$Y+XMLINES<IOSL
I $E(IOST,1,2)="C-" D PAGE^XMXUTIL(.XMABORT) Q:XMABORT
W @IOF D PRTHDR(.XMPARM,.XMHDR)
Q
PRTHDR(XMPARM,XMHDR) ;
S XMHDR("PAGE")=XMHDR("PAGE")+1
W $$EZBLD^DIALOG(36419),XMHDR("PDATE") ; Message purge, local create date <
W ?70,$$EZBLD^DIALOG(34542,XMHDR("PAGE")) ; Page |1|
W !,$$EZBLD^DIALOG(36420),XMHDR("NOW") ; Started:
W:XMPARM("TEST") ?60,$$EZBLD^DIALOG(36421) ; *TEST RUN*
W !
Q
FINISH(XMIEN,XMCRE8,XMPARM,XMKILL,XMCNT,XMHDR,XMABORT) ;
I $D(ZTQUEUED) S ZTREQ="@"
I XMABORT,IO'="" W @IOF D PRTHDR(.XMPARM,.XMHDR)
D CHK(XMIEN,XMCRE8,.XMPARM,.XMKILL,XMCNT,.XMHDR,.XMABORT)
Q:IO=""!'XMCNT
D HDR(5+(2*$G(ZTSTOP)),.XMPARM,.XMHDR,.XMABORT)
I $G(ZTSTOP) W !,$$EZBLD^DIALOG(36422) ; *** Stopping prematurely per user request ***
N XMVAR,XMTEXT
S XMVAR(1)=$$FMTE^XLFDT($$NOW^XLFDT,5),XMVAR(2)=XMCNT
S XMVAR(3)=XMKILL("MSG"),XMVAR(4)=XMKILL("RESP")
W !
D BLD^DIALOG(36423,.XMVAR,"","XMTEXT","F")
D MSG^DIALOG("WM","","","","XMTEXT")
;Message purge finished on |1|.
;|2| messages processed.
;|3| original messages and |4| responses purged.
Q
CHK(XMIEN,XMCRE8,XMPARM,XMKILL,XMCNT,XMHDR,XMABORT) ;
D CHKAUDT(XMIEN,XMCRE8,.XMKILL)
I $D(ZTQUEUED),$$S^%ZTLOAD S (XMABORT,ZTSTOP)=1 Q ; User has asked the task to stop
Q:$E(IOST,1,2)'="C-"
I $X+$L(XMCNT)+1>IOM D
. D HDR(2,.XMPARM,.XMHDR,.XMABORT)
. W !
E W " "
W XMCNT
Q
CHKAUDT(XMIEN,XMCRE8,XMKILL) ;
N XMFDA
S XMFDA(4.302,XMIEN_",1,",1)=XMKILL("START")-XMKILL("MSG")-XMKILL("RESP")
S XMFDA(4.302,XMIEN_",1,",2)=XMKILL("MSG")+XMKILL("RESP")
S XMFDA(4.302,XMIEN_",1,",7)=$$NOW^XLFDT
S XMFDA(4.302,XMIEN_",1,",8)=XMCRE8
D FILE^DIE("","XMFDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMA32A 5729 printed Apr 09, 2024@21:12:51 Page 2
XMA32A ;ISC-SF/GMB-Purge Messages by Date (cont.) ;12/04/2002 13:42
+1 ;;8.0;MailMan;**10**;Jun 28, 2002
+2 ; Was (WASH ISC)/CAP
+3 ;
+4 ; XMPARM("PDATE") Purge all messages older than this date
+5 ; XMCNT Total messages processed
+6 ; XMKILL("START") Messages in ^XMB(3.9 before purge started
+7 ; XMKILL("MSG") Messages purged
+8 ; XMKILL("RESP") Responses killed
+9 ; XMDUZ Pointer to mailbox
+10 ; XMZ Current message being processed
ENT ;
+1 NEW XMCRE8,XMIEN,XMCNT,XMKILL,XMHDR,XMABORT
+2 DO INIT(.XMIEN,.XMPARM,.XMKILL,.XMHDR,.XMABORT)
+3 DO PROCESS(XMIEN,.XMCRE8,.XMPARM,.XMKILL,.XMCNT,.XMHDR,.XMABORT)
+4 DO FINISH(XMIEN,XMCRE8,.XMPARM,.XMKILL,XMCNT,.XMHDR,.XMABORT)
+5 QUIT
INIT(XMIEN,XMPARM,XMKILL,XMHDR,XMABORT) ;
+1 IF IO'=IO(0)
USE IO
+2 SET (XMHDR("PAGE"),XMKILL("MSG"),XMKILL("RESP"),XMABORT)=0
+3 SET XMKILL("START")=$PIECE(^XMB(3.9,0),U,4)
+4 DO INITAUDT(.XMIEN,.XMPARM,.XMHDR)
+5 SET XMHDR("PDATE")=$$FMTE^XLFDT(XMPARM("PDATE"),5)
+6 SET XMHDR("NOW")=$$FMTE^XLFDT(XMHDR("NOW"),5)
+7 if IO=""
QUIT
+8 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
DO PRTHDR(.XMPARM,.XMHDR)
+9 QUIT
INITAUDT(XMIEN,XMPARM,XMHDR) ;
+1 NEW XMFDA
+2 SET XMHDR("NOW")=$$NOW^XLFDT
+3 SET XMFDA(4.302,"+1,1,",.01)=XMHDR("NOW")
+4 if $DATA(XMPARM("START"))
SET XMFDA(4.302,"+1,1,",3)=XMPARM("START")
+5 if $DATA(XMPARM("END"))
SET XMFDA(4.302,"+1,1,",4)=XMPARM("END")
+6 SET XMFDA(4.302,"+1,1,",5)=$SELECT(XMPARM("TYPE")=2:"1TEST",1:XMPARM("TYPE"))
+7 SET XMFDA(4.302,"+1,1,",6)=XMPARM("PDATE")
+8 DO UPDATE^DIE("","XMFDA","XMIEN")
+9 SET XMIEN=XMIEN(1)
+10 QUIT
PROCESS(XMIEN,XMCRE8,XMPARM,XMKILL,XMCNT,XMHDR,XMABORT) ;
+1 NEW XMZ,XMZREC
+2 SET (XMCRE8,XMZ)=""
SET XMCNT=0
+3 FOR
SET XMCRE8=$ORDER(^XMB(3.9,"C",XMCRE8))
if 'XMCRE8
QUIT
if XMCRE8'<XMPARM("PDATE")
QUIT
Begin DoDot:1
+4 FOR
SET XMZ=$ORDER(^XMB(3.9,"C",XMCRE8,XMZ))
if 'XMZ
QUIT
Begin DoDot:2
+5 SET XMCNT=XMCNT+1
IF XMCNT#5000=0
DO CHK(XMIEN,XMCRE8,.XMPARM,.XMKILL,XMCNT,.XMHDR,.XMABORT)
+6 IF '$DATA(^XMB(3.9,XMZ))
KILL ^XMB(3.9,"C",XMCRE8,XMZ)
QUIT
+7 SET XMZREC=$GET(^XMB(3.9,XMZ,0))
+8 ; Don't kill responses (they'll be purged when their original msg is)
if $PIECE(XMZREC,U,8)
QUIT
+9 IF "^^^^^^^^"[XMZREC
DO KILL(XMZ,.XMKILL,.XMABORT,.XMPARM,.XMHDR)
QUIT
+10 ; Do nothing if owned by SHARED,MAIL
if $DATA(^XMB(3.7,"M",XMZ,.6))
QUIT
+11 ; Do nothing if in Transmit queues or Server basket.
if $ORDER(^XMB(3.7,"M",XMZ,.5,999))
QUIT
+12 DO KILL(XMZ,.XMKILL,.XMABORT,.XMPARM,.XMHDR)
+13 ; Old msg; old response without original msg;
+14 ; Old msg which thinks it's also a response;
+15 ; Old response which thinks it's also the original msg.
End DoDot:2
if XMABORT
QUIT
End DoDot:1
if XMABORT
QUIT
+16 QUIT
KILL(XMZ,XMKILL,XMABORT,XMPARM,XMHDR) ;
+1 IF $GET(XMPARM("TEST"))
Begin DoDot:1
+2 DO HDR(2,.XMPARM,.XMHDR,.XMABORT)
if XMABORT
QUIT
+3 ; " <<< Purge! Date = "
WRITE !,XMZ,?20,$$EZBLD^DIALOG(36416),$$FMTE^XLFDT(XMCRE8,5)
End DoDot:1
if XMABORT
QUIT
+4 DO KBASKETS(XMZ,.XMKILL,.XMPARM,.XMHDR,.XMABORT)
if XMABORT
QUIT
+5 DO KMSG(XMZ,.XMKILL,.XMPARM,.XMHDR,.XMABORT)
if XMABORT
QUIT
+6 DO KLATER(XMZ,.XMPARM)
+7 QUIT
KBASKETS(XMZ,XMKILL,XMPARM,XMHDR,XMABORT) ;
+1 NEW XMDUZ,XMK
+2 SET XMDUZ=""
SET XMKILL("MSG")=XMKILL("MSG")+1
+3 FOR
SET XMDUZ=$ORDER(^XMB(3.7,"M",XMZ,XMDUZ))
if XMDUZ=""!XMABORT
QUIT
Begin DoDot:1
+4 SET XMK=$ORDER(^XMB(3.7,"M",XMZ,XMDUZ,0))
+5 if 'XMK
QUIT
+6 if '$DATA(^XMB(3.7,XMDUZ,2,XMK,1,XMZ))
QUIT
+7 IF $GET(XMPARM("TEST"))
Begin DoDot:2
+8 DO HDR(2,.XMPARM,.XMHDR,.XMABORT)
if XMABORT
QUIT
+9 ; Message deleted for DUZ:
WRITE !?25,$$EZBLD^DIALOG(36417),?50,$JUSTIFY(XMDUZ,12),?79
End DoDot:2
QUIT
+10 ; Delete from user's basket
DO ZAPIT^XMXMSGS2(XMDUZ,XMK,XMZ)
End DoDot:1
+11 QUIT
KMSG(XMZ,XMKILL,XMPARM,XMHDR,XMABORT) ;
+1 NEW XMZR,XMIEN,X
+2 SET XMIEN=0
+3 FOR
SET XMIEN=$ORDER(^XMB(3.9,XMZ,3,XMIEN))
if XMIEN'>0!XMABORT
QUIT
Begin DoDot:1
+4 SET XMZR=$PIECE($GET(^XMB(3.9,XMZ,3,XMIEN,0)),U)
+5 SET XMKILL("RESP")=XMKILL("RESP")+1
+6 IF $GET(XMPARM("TEST"))
Begin DoDot:2
+7 DO HDR(2,.XMPARM,.XMHDR,.XMABORT)
if XMABORT
QUIT
+8 ; Response deleted:
WRITE !?25,$$EZBLD^DIALOG(36418),?50,$JUSTIFY(XMZR,20),?79
End DoDot:2
QUIT
+9 ; Kill response
DO KILLMSG^XMXUTIL(XMZR)
End DoDot:1
+10 ; Kill original message
if '$GET(XMPARM("TEST"))
DO KILLMSG^XMXUTIL(XMZ)
+11 QUIT
KLATER(XMZ,XMPARM) ;
+1 if $GET(XMPARM("TEST"))
QUIT
+2 NEW DIK,DA,XMDUZ
+3 SET DIK="^XMB(3.73,"
+4 SET (XMDUZ,DA)=""
+5 FOR
SET XMDUZ=$ORDER(^XMB(3.73,"AC",XMZ,XMDUZ))
if 'XMDUZ
QUIT
Begin DoDot:1
+6 FOR
SET DA=$ORDER(^XMB(3.73,"AC",XMZ,XMDUZ,DA))
if 'DA
QUIT
DO ^DIK
End DoDot:1
+7 QUIT
HDR(XMLINES,XMPARM,XMHDR,XMABORT) ;
+1 if $Y+XMLINES<IOSL
QUIT
+2 IF $EXTRACT(IOST,1,2)="C-"
DO PAGE^XMXUTIL(.XMABORT)
if XMABORT
QUIT
+3 WRITE @IOF
DO PRTHDR(.XMPARM,.XMHDR)
+4 QUIT
PRTHDR(XMPARM,XMHDR) ;
+1 SET XMHDR("PAGE")=XMHDR("PAGE")+1
+2 ; Message purge, local create date <
WRITE $$EZBLD^DIALOG(36419),XMHDR("PDATE")
+3 ; Page |1|
WRITE ?70,$$EZBLD^DIALOG(34542,XMHDR("PAGE"))
+4 ; Started:
WRITE !,$$EZBLD^DIALOG(36420),XMHDR("NOW")
+5 ; *TEST RUN*
if XMPARM("TEST")
WRITE ?60,$$EZBLD^DIALOG(36421)
+6 WRITE !
+7 QUIT
FINISH(XMIEN,XMCRE8,XMPARM,XMKILL,XMCNT,XMHDR,XMABORT) ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF XMABORT
IF IO'=""
WRITE @IOF
DO PRTHDR(.XMPARM,.XMHDR)
+3 DO CHK(XMIEN,XMCRE8,.XMPARM,.XMKILL,XMCNT,.XMHDR,.XMABORT)
+4 if IO=""!'XMCNT
QUIT
+5 DO HDR(5+(2*$GET(ZTSTOP)),.XMPARM,.XMHDR,.XMABORT)
+6 ; *** Stopping prematurely per user request ***
IF $GET(ZTSTOP)
WRITE !,$$EZBLD^DIALOG(36422)
+7 NEW XMVAR,XMTEXT
+8 SET XMVAR(1)=$$FMTE^XLFDT($$NOW^XLFDT,5)
SET XMVAR(2)=XMCNT
+9 SET XMVAR(3)=XMKILL("MSG")
SET XMVAR(4)=XMKILL("RESP")
+10 WRITE !
+11 DO BLD^DIALOG(36423,.XMVAR,"","XMTEXT","F")
+12 DO MSG^DIALOG("WM","","","","XMTEXT")
+13 ;Message purge finished on |1|.
+14 ;|2| messages processed.
+15 ;|3| original messages and |4| responses purged.
+16 QUIT
CHK(XMIEN,XMCRE8,XMPARM,XMKILL,XMCNT,XMHDR,XMABORT) ;
+1 DO CHKAUDT(XMIEN,XMCRE8,.XMKILL)
+2 ; User has asked the task to stop
IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (XMABORT,ZTSTOP)=1
QUIT
+3 if $EXTRACT(IOST,1,2)'="C-"
QUIT
+4 IF $X+$LENGTH(XMCNT)+1>IOM
Begin DoDot:1
+5 DO HDR(2,.XMPARM,.XMHDR,.XMABORT)
+6 WRITE !
End DoDot:1
+7 IF '$TEST
WRITE " "
+8 WRITE XMCNT
+9 QUIT
CHKAUDT(XMIEN,XMCRE8,XMKILL) ;
+1 NEW XMFDA
+2 SET XMFDA(4.302,XMIEN_",1,",1)=XMKILL("START")-XMKILL("MSG")-XMKILL("RESP")
+3 SET XMFDA(4.302,XMIEN_",1,",2)=XMKILL("MSG")+XMKILL("RESP")
+4 SET XMFDA(4.302,XMIEN_",1,",7)=$$NOW^XLFDT
+5 SET XMFDA(4.302,XMIEN_",1,",8)=XMCRE8
+6 DO FILE^DIE("","XMFDA")
+7 QUIT
