XMA32 ;ISC-SF/GMB-Purge Messages by Date ;04/17/2002  07:20
 ;;8.0;MailMan;;Jun 28, 2002
 ; Was (WASH ISC)/CAP
 ;
 ; Entry points used by MailMan options (not covered by DBIA):
 ; ENTER   XMPURGE-BY-DATE - Purge messages by local create date.
ENTER ;
 N XMABORT,XMPARM
 I $D(ZTQUEUED) S ZTREQ="@"
 S XMABORT=0
 D INIT(.XMPARM,.XMABORT) Q:XMABORT
 D SETUP(.XMPARM,.XMABORT) Q:XMABORT
 D PROCESS(.XMPARM)
 Q
INIT(XMPARM,XMABORT) ;
 N XMKEY,XMTEXT
 F XMKEY="XMMGR","XMSTAR" D  Q:XMABORT
 . Q:$D(^XUSEC(XMKEY,DUZ))
 . S XMABORT=1
 . ;You must hold the |1| key to run this option.
 . W !
 . D BLD^DIALOG(36400,XMKEY,"","XMTEXT","F")
 . D MSG^DIALOG("WE","","","","XMTEXT")
 Q:XMABORT
 N XMREC
 S XMREC=$G(^XMB(1,1,.18))
 S XMPARM("PDAYS")=$S($P(XMREC,U,1):$P(XMREC,U,1),1:730)
 I $D(ZTQUEUED),XMPARM("PDAYS")<365 S XMPARM("PDAYS")=730
 S XMPARM("GRACE")=+$P(XMREC,U,2)
 D AUDTPURG
 Q:$D(ZTQUEUED)
 W !
 D BLD^DIALOG(36401,"","","XMTEXT","F")
 D MSG^DIALOG("WM","","","","XMTEXT")
 ;This process REMOVES MESSAGES PERMANENTLY from the system.
 ;             ***** BE VERY CAREFUL *****
 I $D(^XMB(1,1,.1,0)) D LAST(.XMPARM)
 Q
LAST(XMPARM) ; Find the audit record for the last date purge
 N XMLIEN,XMREC,XMDIFF,XMTEXT,XMVAR
 S XMLIEN=":"
 F  S XMLIEN=$O(^XMB(1,1,.1,XMLIEN),-1) Q:'XMLIEN  Q:$P(^(XMLIEN,0),U,6)
 Q:'XMLIEN
 S XMREC=^XMB(1,1,.1,XMLIEN,0)
 D BLD^DIALOG($S($P(XMREC,U,6)["TEST":36402.1,1:36402),$$FMTE^XLFDT($P(XMREC,U),5),"","XMTEXT","F")
 ;This process was last run on |1| (in TEST mode).
 S XMDIFF=$$FMDIFF^XLFDT($P(XMREC,U,1),$P(XMREC,U,7),1) ; difference in days
 S XMVAR(1)=$$FMTE^XLFDT($P(XMREC,U,7),5),XMVAR(2)=XMDIFF
 W !
 D BLD^DIALOG(36403,.XMVAR,"","XMTEXT","FS")
 D MSG^DIALOG("WM","","","","XMTEXT")
 ;The PURGE DATE used was |1|.
 ;(Messages more than |2| days old were purged.)
 W !
 Q
AUDTPURG ; Kill off the earliest purge entries, so that only a certain # remain.
 N XMREC,XMCNT,DA,DIK,XMMAX
 S XMMAX=20
 S XMREC=$G(^XMB(1,1,.1,0))
 S XMCNT=$P(XMREC,U,4)
 Q:XMCNT'>XMMAX
 S DA=0
 F  S DA=$O(^XMB(1,1,.1,0)) Q:DA'>0  D  Q:XMCNT'>XMMAX
 . S XMCNT=XMCNT-1
 . S DA(1)=1,DIK="^XMB(1,1,.1,"
 . D ^DIK
 Q
SETUP(XMPARM,XMABORT) ;
 D PDATE(.XMPARM,.XMABORT)    Q:XMABORT  ; Purge date
 D TESTMODE(.XMPARM,.XMABORT) Q:XMABORT  ; Test mode?
 D GRACE(.XMPARM,.XMABORT)    Q:XMABORT  ; Grace days
 Q
PDATE(XMPARM,XMABORT) ;
 N DIR,X,Y,XMOK,XMOLDEST,XMCUTOFF,XMOLDP1,XMDIFF,XMVAR
 ; Find the oldest date.  Kill any bogus xrefs.
 F  S XMOLDEST=$O(^XMB(3.9,"C","")) Q:XMOLDEST?7N  K ^XMB(3.9,"C",XMOLDEST)
 S XMOLDP1=$$FMADD^XLFDT(XMOLDEST,1)
 I $D(ZTQUEUED) D  Q
 . S XMCUTOFF=$$FMADD^XLFDT(DT,XMPARM("GRACE")-XMPARM("PDAYS"))
 . I XMOLDP1>XMCUTOFF S XMABORT=1 Q  ; Abort if no messages that old.
 . S XMPARM("PDATE")=XMCUTOFF
 S XMCUTOFF=$$FMADD^XLFDT(DT,-XMPARM("PDAYS"))
 I XMOLDP1>XMCUTOFF S XMCUTOFF=XMOLDP1
 S XMOK=0
 F  D  Q:XMOK!XMABORT
 . S DIR(0)="D^"_XMOLDP1_":DT:E"
 . D BLD^DIALOG(36404,$$FMTE^XLFDT(XMOLDEST,5),"","DIR(""A"")")
 . ;The oldest message on the system is from |1|.
 . ;Purge all messages originating before
 . S DIR("B")=$$FMTE^XLFDT(XMCUTOFF,5)
 . D BLD^DIALOG(36405,"","","DIR(""?"")")
 . ;All messages whose 'local create date' is prior to the
 . ;'purge date' you enter will be deleted from the system,
 . ;except those which are in one of SHARED,MAIL's baskets,
 . ;OR in POSTMASTER's server baskets or remote transmit queues.
 . S DIR("??")="^N %DT S %DT=0 D HELP^%DTC"
 . D ^DIR I $D(DIRUT) S XMABORT=1 Q
 . S XMPARM("PDATE")=Y
 . I DT-Y>10000 S XMOK=1 Q
 . D ZIS^XM
 . ;The date you entered is less than 1 year ago.
 . 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:"")
 . K DIR
 . S DIR(0)="Y"
 . S DIR("A")=$$EZBLD^DIALOG(36407) ; Are you sure about this date
 . S DIR("B")=$$EZBLD^DIALOG(39053) ; No
 . D ^DIR I $D(DIRUT) S XMABORT=1 Q
 . S XMOK=Y
 . K DIR
 Q:XMABORT
 S XMDIFF=$$FMDIFF^XLFDT(DT,XMPARM("PDATE"),1)
 I XMDIFF=XMPARM("PDAYS")!(XMDIFF<365)!(XMDIFF>9999) Q
 W !
 K DIR,X,Y
 S XMVAR(1)=XMDIFF,XMVAR(2)=XMPARM("PDAYS")
 S DIR(0)="Y"
 ;You have chosen to purge messages older than |1| days old,
 ;which is different from the current default of |2|.
 ;Do you want |1| to be the new default
 D BLD^DIALOG(36408,.XMVAR,"","DIR(""A"")")
 S DIR("B")=$$EZBLD^DIALOG(39053) ; No
 D BLD^DIALOG(36409,.XMVAR,"","DIR(""?"")")
 ;Answer YES if you want field 10.03, DATE PURGE CUTOFF DAYS,
 ;in file 4.3, MAILMAN SITE PARAMETERS, to be set to |1|.
 ;Answer NO if you want that field to remain |2|.
 ;You can also edit this field using option XMKSP."
 D ^DIR I $D(DIRUT) S XMABORT=1 Q
 I Y S $P(^XMB(1,1,.18),U,1)=XMDIFF
 S XMPARM("PDAYS")=XMDIFF
 Q
TESTMODE(XMPARM,XMABORT) ;
 I $D(ZTQUEUED) D  Q
 . S XMPARM("TEST")=0
 . S XMPARM("TYPE")=1
 W !
 N DIR,X,Y
 S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(36410) ; TEST mode
 S DIR("B")=$$EZBLD^DIALOG(39054) ; YES
 D BLD^DIALOG(36411,"","","DIR(""?"")")
 ;Test mode will not kill off messages.
 ;Test mode gives you a list of what would happen in 'real' mode.
 ;If you do not run in test mode, messages will be KILLED!
 ;Enter YES to run in 'test' mode; NO, 'real' mode.
 D ^DIR I $D(DIRUT) S XMABORT=1 Q
 S XMPARM("TEST")=Y
 S XMPARM("TYPE")=$S(XMPARM("TEST"):2,1:1)
 Q
GRACE(XMPARM,XMABORT) ;
 Q:$D(ZTQUEUED)
 N XMTEXT
 W !
 I XMPARM("TEST") D  Q
 . S XMPARM("GRACE")=0
 . D BLD^DIALOG(36412,"","","XMTEXT","F")
 . D MSG^DIALOG("WM","","","","XMTEXT")
 . ;Since we are running in test mode, no warning bulletin will be sent.
 D BLD^DIALOG(36412.1,"","","XMTEXT","F")
 D MSG^DIALOG("WM","","","","XMTEXT")
 ;If you queue this purge to run 3 or more days from now, I will send
 ;a bulletin, XM DATE PURGE WARNING, to all users to warn them of the
 ;coming date purge and tell them how to identify all of the messages
 ;in their mailbox, which may be affected.
 Q
PROCESS(XMPARM) ;
 N ZTSAVE,ZTRTN,ZTDESC,ZTSK,XMHNOW
 S ZTSAVE("XMPARM*")=""
 S ZTDESC=$$EZBLD^DIALOG(36413) ;MailMan: MESSAGE PURGE by DATE
 S ZTRTN="ENT^XMA32A"
 I '$D(ZTQUEUED) D  Q:'$D(ZTSK)
 . S XMHNOW=$H
 . D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,,1)
 E  D
 . S ZTDTH=$$HADD^XLFDT(ZTDTH,XMPARM("GRACE"))
 . D ^%ZTLOAD
 I '$D(ZTQUEUED),$$HDIFF^XLFDT(ZTSK("D"),XMHNOW,1)<3 D  Q
 . N XMTEXT
 . W !
 . D BLD^DIALOG(36414,"","","XMTEXT","F")
 . D MSG^DIALOG("WM","","","","XMTEXT")
 . ;Since you scheduled the date purge less than 3 days from now,
 . ;no warning bulletin has been sent.
 N XMP,XMINSTR
 S XMINSTR("VAPOR")=$$HTFM^XLFDT($$HADD^XLFDT(ZTSK("D"),,-1)) ; Vaporize 1 hr before purge
 S XMINSTR("FROM")=.5
 S XMP(1)=$$HTE^XLFDT(ZTSK("D"),5)
 S XMP(2)=$$FMTE^XLFDT($$FMADD^XLFDT(XMPARM("PDATE"),-1),5)
 S XMP(3)=$E("==========",1,$L(XMP(2)))
 D TASKBULL^XMXAPI(DUZ,"XM DATE PURGE WARNING",.XMP,,"*",.XMINSTR)
 Q:$D(ZTQUEUED)
 W !
 W $$EZBLD^DIALOG(36415) ;The warning bulletin has been sent.
 Q
 
--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMA32   7030     printed  Sep 23, 2025@19:46:54                                                                                                                                                                                                       Page 2
XMA32     ;ISC-SF/GMB-Purge Messages by Date ;04/17/2002  07:20
 +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       ; ENTER   XMPURGE-BY-DATE - Purge messages by local create date.
ENTER     ;
 +1        NEW XMABORT,XMPARM
 +2        IF $DATA(ZTQUEUED)
               SET ZTREQ="@"
 +3        SET XMABORT=0
 +4        DO INIT(.XMPARM,.XMABORT)
           if XMABORT
               QUIT 
 +5        DO SETUP(.XMPARM,.XMABORT)
           if XMABORT
               QUIT 
 +6        DO PROCESS(.XMPARM)
 +7        QUIT 
INIT(XMPARM,XMABORT) ;
 +1        NEW XMKEY,XMTEXT
 +2        FOR XMKEY="XMMGR","XMSTAR"
               Begin DoDot:1
 +3                if $DATA(^XUSEC(XMKEY,DUZ))
                       QUIT 
 +4                SET XMABORT=1
 +5       ;You must hold the |1| key to run this option.
 +6                WRITE !
 +7                DO BLD^DIALOG(36400,XMKEY,"","XMTEXT","F")
 +8                DO MSG^DIALOG("WE","","","","XMTEXT")
               End DoDot:1
               if XMABORT
                   QUIT 
 +9        if XMABORT
               QUIT 
 +10       NEW XMREC
 +11       SET XMREC=$GET(^XMB(1,1,.18))
 +12       SET XMPARM("PDAYS")=$SELECT($PIECE(XMREC,U,1):$PIECE(XMREC,U,1),1:730)
 +13       IF $DATA(ZTQUEUED)
               IF XMPARM("PDAYS")<365
                   SET XMPARM("PDAYS")=730
 +14       SET XMPARM("GRACE")=+$PIECE(XMREC,U,2)
 +15       DO AUDTPURG
 +16       if $DATA(ZTQUEUED)
               QUIT 
 +17       WRITE !
 +18       DO BLD^DIALOG(36401,"","","XMTEXT","F")
 +19       DO MSG^DIALOG("WM","","","","XMTEXT")
 +20      ;This process REMOVES MESSAGES PERMANENTLY from the system.
 +21      ;             ***** BE VERY CAREFUL *****
 +22       IF $DATA(^XMB(1,1,.1,0))
               DO LAST(.XMPARM)
 +23       QUIT 
LAST(XMPARM) ; Find the audit record for the last date purge
 +1        NEW XMLIEN,XMREC,XMDIFF,XMTEXT,XMVAR
 +2        SET XMLIEN=":"
 +3        FOR 
               SET XMLIEN=$ORDER(^XMB(1,1,.1,XMLIEN),-1)
               if 'XMLIEN
                   QUIT 
               if $PIECE(^(XMLIEN,0),U,6)
                   QUIT 
 +4        if 'XMLIEN
               QUIT 
 +5        SET XMREC=^XMB(1,1,.1,XMLIEN,0)
 +6        DO BLD^DIALOG($SELECT($PIECE(XMREC,U,6)["TEST":36402.1,1:36402),$$FMTE^XLFDT($PIECE(XMREC,U),5),"","XMTEXT","F")
 +7       ;This process was last run on |1| (in TEST mode).
 +8       ; difference in days
           SET XMDIFF=$$FMDIFF^XLFDT($PIECE(XMREC,U,1),$PIECE(XMREC,U,7),1)
 +9        SET XMVAR(1)=$$FMTE^XLFDT($PIECE(XMREC,U,7),5)
           SET XMVAR(2)=XMDIFF
 +10       WRITE !
 +11       DO BLD^DIALOG(36403,.XMVAR,"","XMTEXT","FS")
 +12       DO MSG^DIALOG("WM","","","","XMTEXT")
 +13      ;The PURGE DATE used was |1|.
 +14      ;(Messages more than |2| days old were purged.)
 +15       WRITE !
 +16       QUIT 
AUDTPURG  ; Kill off the earliest purge entries, so that only a certain # remain.
 +1        NEW XMREC,XMCNT,DA,DIK,XMMAX
 +2        SET XMMAX=20
 +3        SET XMREC=$GET(^XMB(1,1,.1,0))
 +4        SET XMCNT=$PIECE(XMREC,U,4)
 +5        if XMCNT'>XMMAX
               QUIT 
 +6        SET DA=0
 +7        FOR 
               SET DA=$ORDER(^XMB(1,1,.1,0))
               if DA'>0
                   QUIT 
               Begin DoDot:1
 +8                SET XMCNT=XMCNT-1
 +9                SET DA(1)=1
                   SET DIK="^XMB(1,1,.1,"
 +10               DO ^DIK
               End DoDot:1
               if XMCNT'>XMMAX
                   QUIT 
 +11       QUIT 
SETUP(XMPARM,XMABORT) ;
 +1       ; Purge date
           DO PDATE(.XMPARM,.XMABORT)
           if XMABORT
               QUIT 
 +2       ; Test mode?
           DO TESTMODE(.XMPARM,.XMABORT)
           if XMABORT
               QUIT 
 +3       ; Grace days
           DO GRACE(.XMPARM,.XMABORT)
           if XMABORT
               QUIT 
 +4        QUIT 
PDATE(XMPARM,XMABORT) ;
 +1        NEW DIR,X,Y,XMOK,XMOLDEST,XMCUTOFF,XMOLDP1,XMDIFF,XMVAR
 +2       ; Find the oldest date.  Kill any bogus xrefs.
 +3        FOR 
               SET XMOLDEST=$ORDER(^XMB(3.9,"C",""))
               if XMOLDEST?7N
                   QUIT 
               KILL ^XMB(3.9,"C",XMOLDEST)
 +4        SET XMOLDP1=$$FMADD^XLFDT(XMOLDEST,1)
 +5        IF $DATA(ZTQUEUED)
               Begin DoDot:1
 +6                SET XMCUTOFF=$$FMADD^XLFDT(DT,XMPARM("GRACE")-XMPARM("PDAYS"))
 +7       ; Abort if no messages that old.
                   IF XMOLDP1>XMCUTOFF
                       SET XMABORT=1
                       QUIT 
 +8                SET XMPARM("PDATE")=XMCUTOFF
               End DoDot:1
               QUIT 
 +9        SET XMCUTOFF=$$FMADD^XLFDT(DT,-XMPARM("PDAYS"))
 +10       IF XMOLDP1>XMCUTOFF
               SET XMCUTOFF=XMOLDP1
 +11       SET XMOK=0
 +12       FOR 
               Begin DoDot:1
 +13               SET DIR(0)="D^"_XMOLDP1_":DT:E"
 +14               DO BLD^DIALOG(36404,$$FMTE^XLFDT(XMOLDEST,5),"","DIR(""A"")")
 +15      ;The oldest message on the system is from |1|.
 +16      ;Purge all messages originating before
 +17               SET DIR("B")=$$FMTE^XLFDT(XMCUTOFF,5)
 +18               DO BLD^DIALOG(36405,"","","DIR(""?"")")
 +19      ;All messages whose 'local create date' is prior to the
 +20      ;'purge date' you enter will be deleted from the system,
 +21      ;except those which are in one of SHARED,MAIL's baskets,
 +22      ;OR in POSTMASTER's server baskets or remote transmit queues.
 +23               SET DIR("??")="^N %DT S %DT=0 D HELP^%DTC"
 +24               DO ^DIR
                   IF $DATA(DIRUT)
                       SET XMABORT=1
                       QUIT 
 +25               SET XMPARM("PDATE")=Y
 +26               IF DT-Y>10000
                       SET XMOK=1
                       QUIT 
 +27               DO ZIS^XM
 +28      ;The date you entered is less than 1 year ago.
 +29               WRITE !!,$SELECT($DATA(IORVON):IORVON,1:""),$SELECT($DATA(IOBON):IOBON,1:""),$$EZBLD^DIALOG(36406),$SELECT($DATA(IOBOFF):IOBOFF,1:""),$CHAR(7),$SELECT($DATA(IORVOFF):IORVOFF,1:"")
 +30               KILL DIR
 +31               SET DIR(0)="Y"
 +32      ; Are you sure about this date
                   SET DIR("A")=$$EZBLD^DIALOG(36407)
 +33      ; No
                   SET DIR("B")=$$EZBLD^DIALOG(39053)
 +34               DO ^DIR
                   IF $DATA(DIRUT)
                       SET XMABORT=1
                       QUIT 
 +35               SET XMOK=Y
 +36               KILL DIR
               End DoDot:1
               if XMOK!XMABORT
                   QUIT 
 +37       if XMABORT
               QUIT 
 +38       SET XMDIFF=$$FMDIFF^XLFDT(DT,XMPARM("PDATE"),1)
 +39       IF XMDIFF=XMPARM("PDAYS")!(XMDIFF<365)!(XMDIFF>9999)
               QUIT 
 +40       WRITE !
 +41       KILL DIR,X,Y
 +42       SET XMVAR(1)=XMDIFF
           SET XMVAR(2)=XMPARM("PDAYS")
 +43       SET DIR(0)="Y"
 +44      ;You have chosen to purge messages older than |1| days old,
 +45      ;which is different from the current default of |2|.
 +46      ;Do you want |1| to be the new default
 +47       DO BLD^DIALOG(36408,.XMVAR,"","DIR(""A"")")
 +48      ; No
           SET DIR("B")=$$EZBLD^DIALOG(39053)
 +49       DO BLD^DIALOG(36409,.XMVAR,"","DIR(""?"")")
 +50      ;Answer YES if you want field 10.03, DATE PURGE CUTOFF DAYS,
 +51      ;in file 4.3, MAILMAN SITE PARAMETERS, to be set to |1|.
 +52      ;Answer NO if you want that field to remain |2|.
 +53      ;You can also edit this field using option XMKSP."
 +54       DO ^DIR
           IF $DATA(DIRUT)
               SET XMABORT=1
               QUIT 
 +55       IF Y
               SET $PIECE(^XMB(1,1,.18),U,1)=XMDIFF
 +56       SET XMPARM("PDAYS")=XMDIFF
 +57       QUIT 
TESTMODE(XMPARM,XMABORT) ;
 +1        IF $DATA(ZTQUEUED)
               Begin DoDot:1
 +2                SET XMPARM("TEST")=0
 +3                SET XMPARM("TYPE")=1
               End DoDot:1
               QUIT 
 +4        WRITE !
 +5        NEW DIR,X,Y
 +6       ; TEST mode
           SET DIR(0)="Y"
           SET DIR("A")=$$EZBLD^DIALOG(36410)
 +7       ; YES
           SET DIR("B")=$$EZBLD^DIALOG(39054)
 +8        DO BLD^DIALOG(36411,"","","DIR(""?"")")
 +9       ;Test mode will not kill off messages.
 +10      ;Test mode gives you a list of what would happen in 'real' mode.
 +11      ;If you do not run in test mode, messages will be KILLED!
 +12      ;Enter YES to run in 'test' mode; NO, 'real' mode.
 +13       DO ^DIR
           IF $DATA(DIRUT)
               SET XMABORT=1
               QUIT 
 +14       SET XMPARM("TEST")=Y
 +15       SET XMPARM("TYPE")=$SELECT(XMPARM("TEST"):2,1:1)
 +16       QUIT 
GRACE(XMPARM,XMABORT) ;
 +1        if $DATA(ZTQUEUED)
               QUIT 
 +2        NEW XMTEXT
 +3        WRITE !
 +4        IF XMPARM("TEST")
               Begin DoDot:1
 +5                SET XMPARM("GRACE")=0
 +6                DO BLD^DIALOG(36412,"","","XMTEXT","F")
 +7                DO MSG^DIALOG("WM","","","","XMTEXT")
 +8       ;Since we are running in test mode, no warning bulletin will be sent.
               End DoDot:1
               QUIT 
 +9        DO BLD^DIALOG(36412.1,"","","XMTEXT","F")
 +10       DO MSG^DIALOG("WM","","","","XMTEXT")
 +11      ;If you queue this purge to run 3 or more days from now, I will send
 +12      ;a bulletin, XM DATE PURGE WARNING, to all users to warn them of the
 +13      ;coming date purge and tell them how to identify all of the messages
 +14      ;in their mailbox, which may be affected.
 +15       QUIT 
PROCESS(XMPARM) ;
 +1        NEW ZTSAVE,ZTRTN,ZTDESC,ZTSK,XMHNOW
 +2        SET ZTSAVE("XMPARM*")=""
 +3       ;MailMan: MESSAGE PURGE by DATE
           SET ZTDESC=$$EZBLD^DIALOG(36413)
 +4        SET ZTRTN="ENT^XMA32A"
 +5        IF '$DATA(ZTQUEUED)
               Begin DoDot:1
 +6                SET XMHNOW=$HOROLOG
 +7                DO EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,,1)
               End DoDot:1
               if '$DATA(ZTSK)
                   QUIT 
 +8       IF '$TEST
               Begin DoDot:1
 +9                SET ZTDTH=$$HADD^XLFDT(ZTDTH,XMPARM("GRACE"))
 +10               DO ^%ZTLOAD
               End DoDot:1
 +11       IF '$DATA(ZTQUEUED)
               IF $$HDIFF^XLFDT(ZTSK("D"),XMHNOW,1)<3
                   Begin DoDot:1
 +12                   NEW XMTEXT
 +13                   WRITE !
 +14                   DO BLD^DIALOG(36414,"","","XMTEXT","F")
 +15                   DO MSG^DIALOG("WM","","","","XMTEXT")
 +16      ;Since you scheduled the date purge less than 3 days from now,
 +17      ;no warning bulletin has been sent.
                   End DoDot:1
                   QUIT 
 +18       NEW XMP,XMINSTR
 +19      ; Vaporize 1 hr before purge
           SET XMINSTR("VAPOR")=$$HTFM^XLFDT($$HADD^XLFDT(ZTSK("D"),,-1))
 +20       SET XMINSTR("FROM")=.5
 +21       SET XMP(1)=$$HTE^XLFDT(ZTSK("D"),5)
 +22       SET XMP(2)=$$FMTE^XLFDT($$FMADD^XLFDT(XMPARM("PDATE"),-1),5)
 +23       SET XMP(3)=$EXTRACT("==========",1,$LENGTH(XMP(2)))
 +24       DO TASKBULL^XMXAPI(DUZ,"XM DATE PURGE WARNING",.XMP,,"*",.XMINSTR)
 +25       if $DATA(ZTQUEUED)
               QUIT 
 +26       WRITE !
 +27      ;The warning bulletin has been sent.
           WRITE $$EZBLD^DIALOG(36415)
 +28       QUIT