XMTDT ;ISC-SF/GMB-Deliver later'd msgs & delete inactive msgs ;04/15/2003 12:48
;;8.0;MailMan;**18**;Jun 28, 2002
; Replaces ^XMADJ999,LATER^XMAD2 (ISC-WASH/CAP)
GO ;
N XMWAIT
I $D(ZTQUEUED) S ZTREQ="@"
L +^XMBPOST("POST_Tickler"):1 E Q
I $D(ZTQUEUED) S %=$$PSET^%ZTLOAD(ZTSK)
F Q:$P($G(^XMB(1,1,0)),U,16) D
. D LATERNEW
. D LATERFWD
. D PURGEOLD
. D FILTRFWD
. S XMWAIT=$$TSTAMP^XMXUTIL1 ; Why can't we just H 60?
. F D Q:$$TSTAMP^XMXUTIL1-XMWAIT>60
. . H XMHANG
L -^XMBPOST("POST_Tickler")
I $D(ZTQUEUED) D PCLEAR^%ZTLOAD(ZTSK)
Q
LATERNEW ; This routine takes care of 'new'ing messages which the user
; had previously 'later'ed for himself.
N XMNOW,XMLATER,DIK,XMDUZ,XMZ,DA,XMZREC,XMINACT
S XMNOW=$$NOW^XLFDT
S XMLATER=0
F S XMLATER=$O(^XMB(3.73,"AB",XMLATER)) Q:XMLATER'>0!(XMLATER>XMNOW) D
. S DIK="^XMB(3.73,"
. S XMDUZ=0
. F S XMDUZ=$O(^XMB(3.73,"AB",XMLATER,XMDUZ)) Q:'XMDUZ D
. . S XMINACT=$S($P($G(^VA(200,XMDUZ,0)),U,3)="":1,$P($G(^(.1)),U,2)="":1,$P($G(^(201)),U)="":1,1:0) ; user is inactive if no access code, or verify code, or primary menu
. . S XMZ=0
. . F S XMZ=$O(^XMB(3.73,"AB",XMLATER,XMDUZ,XMZ)) Q:'XMZ D
. . . S DA=$O(^XMB(3.73,"AB",XMLATER,XMDUZ,XMZ,0)) Q:'DA
. . . I '$D(^XMB(3.73,DA,0)) D Q ; *** This should not be necessary
. . . . K ^XMB(3.73,"AB",XMLATER,XMDUZ,XMZ,DA)
. . . . K ^XMB(3.73,"AC",XMZ,XMDUZ,DA)
. . . . K ^XMB(3.73,"C",XMDUZ,DA)
. . . D ^DIK
. . . Q:XMINACT
. . . S XMZREC=$G(^XMB(3.9,XMZ,0)) Q:XMZREC=""
. . . D RESURECT^XMXMSGS2(XMDUZ,XMZ)
. . . D DELIVER^XMTDL2(XMDUZ,XMZ,$P(XMZREC,U,1),$P(XMZREC,U,2),0,1)
Q
LATERFWD ; This routine takes care of forwarding messages which a user
; had previously scheduled for 'later' delivery to other users.
N XMDUZ,XMNOW,XMLATER,DIK,XMIEN,XMZ,DA,XMREC,XMV,XMINSTR,XMTO,XMPRIVAT
K XMERR,^TMP("XMERR",$J)
S XMPRIVAT=$$EZBLD^DIALOG(39135) ; " [Private Mail Group]"
S XMINSTR("FWD BY XMDUZ")=""
S XMNOW=$$NOW^XLFDT
S XMLATER=0
F S XMLATER=$O(^XMB(3.9,"AL",XMLATER)) Q:XMLATER'>0!(XMLATER>XMNOW) D
. S XMZ=0
. F S XMZ=$O(^XMB(3.9,"AL",XMLATER,XMZ)) Q:'XMZ D
. . S DA(1)=XMZ
. . S DIK="^XMB(3.9,"_DA(1)_",7,"
. . S XMIEN=0
. . F S XMIEN=$O(^XMB(3.9,"AL",XMLATER,XMZ,XMIEN)) Q:'XMIEN D
. . . S XMREC=$G(^XMB(3.9,XMZ,7,XMIEN,0))
. . . I XMREC="" K ^XMB(3.9,"AL",XMLATER,XMZ,XMIEN) Q
. . . S XMDUZ=$P(XMREC,U,3)
. . . S XMTO=$P(XMREC,U,1)
. . . I XMTO[XMPRIVAT S XMTO=$P(XMTO,XMPRIVAT,1) ; " [Private Mail Group]" (set in ^XMXADDRG)
. . . I $P(XMREC,U,2)'="" S XMTO=$P(XMREC,U,2)_":"_XMTO
. . . D INIT^XMXADDR
. . . D CHKADDR^XMXADDR(XMDUZ,XMTO) K:$D(XMERR) XMERR,^TMP("XMERR",$J)
. . . S XMINSTR("FWD BY")=$P(XMREC,U,4)
. . . D:$D(^TMP("XMY",$J)) FWD^XMKP(XMDUZ,XMZ,.XMINSTR)
. . . D CLEANUP^XMXADDR
. . . S DA=XMIEN
. . . D ^DIK
Q
PURGEOLD ; This routine deletes msgs marked for automatic deletion,
; whether marked by the user, or marked by the 'in basket purge'
; because they hadn't been accessed for a certain number of days.
; Replaces ^XMAI0 (ISC-WASH/CAP/RJ)
; XMDDATE Message delete date
N XMDDATE,XMDUZ,XMK,XMZ,XMNOW
S XMNOW=$$NOW^XLFDT
S (XMDDATE,XMDUZ,XMK,XMZ)=""
F S XMDDATE=$O(^XMB(3.7,"AC",XMDDATE)) Q:XMDDATE=""!(XMDDATE>XMNOW) D
. F S XMDUZ=$O(^XMB(3.7,"AC",XMDDATE,XMDUZ)) Q:XMDUZ="" D
. . F S XMK=$O(^XMB(3.7,"AC",XMDDATE,XMDUZ,XMK)) Q:XMK="" D
. . . F S XMZ=$O(^XMB(3.7,"AC",XMDDATE,XMDUZ,XMK,XMZ)) Q:XMZ="" D
. . . . I $D(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)) D ZAPIT^XMXMSGS2(XMDUZ,XMK,XMZ) Q
. . . . K ^XMB(3.7,"AC",XMDDATE,XMDUZ,XMK,XMZ)
Q
FILTRFWD ; This routine forwards messages for a user when a filter
; with 'forward to' recipients has activated during message delivery.
N XMDUZ,XMUPTR,XMZ,XMREC,XMV,XMINSTR,XMTO,XMPRIVAT,XMFIEN,XMFWDIEN
S XMPRIVAT=$$EZBLD^DIALOG(39135) ; " [Private Mail Group]"
S XMINSTR("FWD BY XMDUZ")="F"
S XMFIEN=0
F S XMFIEN=$O(^XMB(3.9,"AF",XMFIEN)) Q:'XMFIEN D
. S XMZ=0
. F S XMZ=$O(^XMB(3.9,"AF",XMFIEN,XMZ)) Q:'XMZ D
. . S XMUPTR=0
. . F S XMUPTR=$O(^XMB(3.9,"AF",XMFIEN,XMZ,XMUPTR)) Q:'XMUPTR D
. . . S XMREC=$G(^XMB(3.9,XMZ,1,XMUPTR,0))
. . . S XMDUZ=$P(XMREC,U,1)
. . . I XMREC=""!'XMDUZ!($P(XMREC,U,13)'=XMFIEN) K ^XMB(3.9,"AF",XMFIEN,XMZ,XMUPTR) Q
. . . S XMFWDIEN=0
. . . D INIT^XMXADDR
. . . F S XMFWDIEN=$O(^XMB(3.7,XMDUZ,15,XMFIEN,1,XMFWDIEN)) Q:'XMFWDIEN S XMREC=$G(^(XMFWDIEN,0)) D
. . . . S XMTO=$P(XMREC,U,1) Q:XMTO=""
. . . . N XMERROR,XMFULL,XMFWDADD
. . . . I XMTO[XMPRIVAT S XMTO=$P(XMTO,XMPRIVAT,1) ; " [Private Mail Group]" (set in ^XMXADDRG)
. . . . ;I $P(XMREC,U,2)'="" S XMTO=$P(XMREC,U,2)_":"_XMTO
. . . . D ADDRESS^XMXADDR(XMDUZ,XMTO,.XMFULL,.XMERROR) Q:'$D(XMERROR)
. . . . D DELFWDTO^XMTDF(XMDUZ,XMFIEN,XMFWDIEN,XMTO,$$GETERR^XMXADDR4)
. . . S XMINSTR("FWD BY")=$$NAME^XMXUTIL(XMDUZ)
. . . D:$D(^TMP("XMY",$J)) FWD^XMKP(XMDUZ,XMZ,.XMINSTR)
. . . D CLEANUP^XMXADDR
. . . N XMFDA
. . . S XMFDA(3.91,XMUPTR_","_XMZ_",",15)=0 ; filter forward completed
. . . D FILE^DIE("","XMFDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMTDT 5101 printed Apr 09, 2024@21:12:52 Page 2
XMTDT ;ISC-SF/GMB-Deliver later'd msgs & delete inactive msgs ;04/15/2003 12:48
+1 ;;8.0;MailMan;**18**;Jun 28, 2002
+2 ; Replaces ^XMADJ999,LATER^XMAD2 (ISC-WASH/CAP)
GO ;
+1 NEW XMWAIT
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 LOCK +^XMBPOST("POST_Tickler"):1
IF '$TEST
QUIT
+4 IF $DATA(ZTQUEUED)
SET %=$$PSET^%ZTLOAD(ZTSK)
+5 FOR
if $PIECE($GET(^XMB(1,1,0)),U,16)
QUIT
Begin DoDot:1
+6 DO LATERNEW
+7 DO LATERFWD
+8 DO PURGEOLD
+9 DO FILTRFWD
+10 ; Why can't we just H 60?
SET XMWAIT=$$TSTAMP^XMXUTIL1
+11 FOR
Begin DoDot:2
+12 HANG XMHANG
End DoDot:2
if $$TSTAMP^XMXUTIL1-XMWAIT>60
QUIT
End DoDot:1
+13 LOCK -^XMBPOST("POST_Tickler")
+14 IF $DATA(ZTQUEUED)
DO PCLEAR^%ZTLOAD(ZTSK)
+15 QUIT
LATERNEW ; This routine takes care of 'new'ing messages which the user
+1 ; had previously 'later'ed for himself.
+2 NEW XMNOW,XMLATER,DIK,XMDUZ,XMZ,DA,XMZREC,XMINACT
+3 SET XMNOW=$$NOW^XLFDT
+4 SET XMLATER=0
+5 FOR
SET XMLATER=$ORDER(^XMB(3.73,"AB",XMLATER))
if XMLATER'>0!(XMLATER>XMNOW)
QUIT
Begin DoDot:1
+6 SET DIK="^XMB(3.73,"
+7 SET XMDUZ=0
+8 FOR
SET XMDUZ=$ORDER(^XMB(3.73,"AB",XMLATER,XMDUZ))
if 'XMDUZ
QUIT
Begin DoDot:2
+9 ; user is inactive if no access code, or verify code, or primary menu
SET XMINACT=$SELECT($PIECE($GET(^VA(200,XMDUZ,0)),U,3)="":1,$PIECE($GET(^(.1)),U,2)="":1,$PIECE($GET(^(201)),U)="":1,1:0)
+10 SET XMZ=0
+11 FOR
SET XMZ=$ORDER(^XMB(3.73,"AB",XMLATER,XMDUZ,XMZ))
if 'XMZ
QUIT
Begin DoDot:3
+12 SET DA=$ORDER(^XMB(3.73,"AB",XMLATER,XMDUZ,XMZ,0))
if 'DA
QUIT
+13 ; *** This should not be necessary
IF '$DATA(^XMB(3.73,DA,0))
Begin DoDot:4
+14 KILL ^XMB(3.73,"AB",XMLATER,XMDUZ,XMZ,DA)
+15 KILL ^XMB(3.73,"AC",XMZ,XMDUZ,DA)
+16 KILL ^XMB(3.73,"C",XMDUZ,DA)
End DoDot:4
QUIT
+17 DO ^DIK
+18 if XMINACT
QUIT
+19 SET XMZREC=$GET(^XMB(3.9,XMZ,0))
if XMZREC=""
QUIT
+20 DO RESURECT^XMXMSGS2(XMDUZ,XMZ)
+21 DO DELIVER^XMTDL2(XMDUZ,XMZ,$PIECE(XMZREC,U,1),$PIECE(XMZREC,U,2),0,1)
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
LATERFWD ; This routine takes care of forwarding messages which a user
+1 ; had previously scheduled for 'later' delivery to other users.
+2 NEW XMDUZ,XMNOW,XMLATER,DIK,XMIEN,XMZ,DA,XMREC,XMV,XMINSTR,XMTO,XMPRIVAT
+3 KILL XMERR,^TMP("XMERR",$JOB)
+4 ; " [Private Mail Group]"
SET XMPRIVAT=$$EZBLD^DIALOG(39135)
+5 SET XMINSTR("FWD BY XMDUZ")=""
+6 SET XMNOW=$$NOW^XLFDT
+7 SET XMLATER=0
+8 FOR
SET XMLATER=$ORDER(^XMB(3.9,"AL",XMLATER))
if XMLATER'>0!(XMLATER>XMNOW)
QUIT
Begin DoDot:1
+9 SET XMZ=0
+10 FOR
SET XMZ=$ORDER(^XMB(3.9,"AL",XMLATER,XMZ))
if 'XMZ
QUIT
Begin DoDot:2
+11 SET DA(1)=XMZ
+12 SET DIK="^XMB(3.9,"_DA(1)_",7,"
+13 SET XMIEN=0
+14 FOR
SET XMIEN=$ORDER(^XMB(3.9,"AL",XMLATER,XMZ,XMIEN))
if 'XMIEN
QUIT
Begin DoDot:3
+15 SET XMREC=$GET(^XMB(3.9,XMZ,7,XMIEN,0))
+16 IF XMREC=""
KILL ^XMB(3.9,"AL",XMLATER,XMZ,XMIEN)
QUIT
+17 SET XMDUZ=$PIECE(XMREC,U,3)
+18 SET XMTO=$PIECE(XMREC,U,1)
+19 ; " [Private Mail Group]" (set in ^XMXADDRG)
IF XMTO[XMPRIVAT
SET XMTO=$PIECE(XMTO,XMPRIVAT,1)
+20 IF $PIECE(XMREC,U,2)'=""
SET XMTO=$PIECE(XMREC,U,2)_":"_XMTO
+21 DO INIT^XMXADDR
+22 DO CHKADDR^XMXADDR(XMDUZ,XMTO)
if $DATA(XMERR)
KILL XMERR,^TMP("XMERR",$JOB)
+23 SET XMINSTR("FWD BY")=$PIECE(XMREC,U,4)
+24 if $DATA(^TMP("XMY",$JOB))
DO FWD^XMKP(XMDUZ,XMZ,.XMINSTR)
+25 DO CLEANUP^XMXADDR
+26 SET DA=XMIEN
+27 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
PURGEOLD ; This routine deletes msgs marked for automatic deletion,
+1 ; whether marked by the user, or marked by the 'in basket purge'
+2 ; because they hadn't been accessed for a certain number of days.
+3 ; Replaces ^XMAI0 (ISC-WASH/CAP/RJ)
+4 ; XMDDATE Message delete date
+5 NEW XMDDATE,XMDUZ,XMK,XMZ,XMNOW
+6 SET XMNOW=$$NOW^XLFDT
+7 SET (XMDDATE,XMDUZ,XMK,XMZ)=""
+8 FOR
SET XMDDATE=$ORDER(^XMB(3.7,"AC",XMDDATE))
if XMDDATE=""!(XMDDATE>XMNOW)
QUIT
Begin DoDot:1
+9 FOR
SET XMDUZ=$ORDER(^XMB(3.7,"AC",XMDDATE,XMDUZ))
if XMDUZ=""
QUIT
Begin DoDot:2
+10 FOR
SET XMK=$ORDER(^XMB(3.7,"AC",XMDDATE,XMDUZ,XMK))
if XMK=""
QUIT
Begin DoDot:3
+11 FOR
SET XMZ=$ORDER(^XMB(3.7,"AC",XMDDATE,XMDUZ,XMK,XMZ))
if XMZ=""
QUIT
Begin DoDot:4
+12 IF $DATA(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0))
DO ZAPIT^XMXMSGS2(XMDUZ,XMK,XMZ)
QUIT
+13 KILL ^XMB(3.7,"AC",XMDDATE,XMDUZ,XMK,XMZ)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
FILTRFWD ; This routine forwards messages for a user when a filter
+1 ; with 'forward to' recipients has activated during message delivery.
+2 NEW XMDUZ,XMUPTR,XMZ,XMREC,XMV,XMINSTR,XMTO,XMPRIVAT,XMFIEN,XMFWDIEN
+3 ; " [Private Mail Group]"
SET XMPRIVAT=$$EZBLD^DIALOG(39135)
+4 SET XMINSTR("FWD BY XMDUZ")="F"
+5 SET XMFIEN=0
+6 FOR
SET XMFIEN=$ORDER(^XMB(3.9,"AF",XMFIEN))
if 'XMFIEN
QUIT
Begin DoDot:1
+7 SET XMZ=0
+8 FOR
SET XMZ=$ORDER(^XMB(3.9,"AF",XMFIEN,XMZ))
if 'XMZ
QUIT
Begin DoDot:2
+9 SET XMUPTR=0
+10 FOR
SET XMUPTR=$ORDER(^XMB(3.9,"AF",XMFIEN,XMZ,XMUPTR))
if 'XMUPTR
QUIT
Begin DoDot:3
+11 SET XMREC=$GET(^XMB(3.9,XMZ,1,XMUPTR,0))
+12 SET XMDUZ=$PIECE(XMREC,U,1)
+13 IF XMREC=""!'XMDUZ!($PIECE(XMREC,U,13)'=XMFIEN)
KILL ^XMB(3.9,"AF",XMFIEN,XMZ,XMUPTR)
QUIT
+14 SET XMFWDIEN=0
+15 DO INIT^XMXADDR
+16 FOR
SET XMFWDIEN=$ORDER(^XMB(3.7,XMDUZ,15,XMFIEN,1,XMFWDIEN))
if 'XMFWDIEN
QUIT
SET XMREC=$GET(^(XMFWDIEN,0))
Begin DoDot:4
+17 SET XMTO=$PIECE(XMREC,U,1)
if XMTO=""
QUIT
+18 NEW XMERROR,XMFULL,XMFWDADD
+19 ; " [Private Mail Group]" (set in ^XMXADDRG)
IF XMTO[XMPRIVAT
SET XMTO=$PIECE(XMTO,XMPRIVAT,1)
+20 ;I $P(XMREC,U,2)'="" S XMTO=$P(XMREC,U,2)_":"_XMTO
+21 DO ADDRESS^XMXADDR(XMDUZ,XMTO,.XMFULL,.XMERROR)
if '$DATA(XMERROR)
QUIT
+22 DO DELFWDTO^XMTDF(XMDUZ,XMFIEN,XMFWDIEN,XMTO,$$GETERR^XMXADDR4)
End DoDot:4
+23 SET XMINSTR("FWD BY")=$$NAME^XMXUTIL(XMDUZ)
+24 if $DATA(^TMP("XMY",$JOB))
DO FWD^XMKP(XMDUZ,XMZ,.XMINSTR)
+25 DO CLEANUP^XMXADDR
+26 NEW XMFDA
+27 ; filter forward completed
SET XMFDA(3.91,XMUPTR_","_XMZ_",",15)=0
+28 DO FILE^DIE("","XMFDA")
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
