source: FOIAVistA/tag/r/MAILMAN-XM/XMA32A.m@ 1104

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