source: FOIAVistA/trunk/r/MAILMAN-XM/XMTDL.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1XMTDL ;ISC-SF/GMB-Deliver local mail to mailbox ;10/23/2002 06:37
2 ;;8.0;MailMan;**1,6**;Jun 28, 2002
3 ; Replaces ^XMAD0,GO^XMADGO,STATS^XMADJF0,^XMADJF1,^XMADJF1A (ISC-WASH/CAP)
4GO ;
5 ; Variables provided through TASKMAN: XMHANG,XMGROUP,XMQUEUE
6 N XMTSTAMP,XMUID,XMIDLE,X,XMMCNT,XMRCNT,XMACNT
7 ; XMMCNT # of messages/responses processed
8 ; XMRCNT # of potential local recipients to process
9 ; XMACNT # of actual local recipients processed
10 S:$D(ZTQUEUED) ZTREQ="@"
11 Q:$P($G(^XMB(1,1,0)),U,16)
12 I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D R^XMCTRAP"
13 E S X="R^XMCTRAP",@^%ZOSF("TRAP")
14 I $D(^%ZOSF("TRAP")) S X="^%ET",@^("TRAP")
15 I $D(^%ZOSF("PRIORITY")) S X=$S(+$G(^XMB(1,1,.13)):+^(.13),1:5) X ^%ZOSF("PRIORITY")
16 L +^XMBPOST(XMGROUP,XMQUEUE):0 E H 0 Q
17 S XMIDLE=0
18 F D Q:$P($G(^XMB(1,1,0)),U,16)!($$TSTAMP^XMXUTIL1-XMIDLE>900)
19 . F S XMTSTAMP=$O(^XMBPOST(XMGROUP,XMQUEUE,"")) Q:XMTSTAMP'>0 D
20 . . S XMIDLE=0
21 . . F S XMUID=$O(^XMBPOST(XMGROUP,XMQUEUE,XMTSTAMP,"")) Q:XMUID="" D
22 . . . I XMGROUP="M" D
23 . . . . D MDELIVER(XMGROUP,XMQUEUE,XMTSTAMP,XMUID,.XMMCNT,.XMRCNT,.XMACNT)
24 . . . E D
25 . . . . D RDELIVER(XMGROUP,XMQUEUE,XMTSTAMP,XMUID,.XMMCNT,.XMRCNT,.XMACNT)
26 . . . K ^XMBPOST(XMGROUP,XMQUEUE,XMTSTAMP,XMUID)
27 . . . D:'$D(^XMBPOST("STATS","OFF")) STATS^XMTDL1(XMGROUP,XMQUEUE,XMMCNT,XMRCNT,XMACNT) ; Delivered to # users
28 . L +^XMBPOST("QSTATS",XMGROUP,XMQUEUE):0
29 . S ^XMBPOST(XMGROUP,XMQUEUE)=""
30 . L -^XMBPOST("QSTATS",XMGROUP,XMQUEUE)
31 . S:XMIDLE=0 XMIDLE=$$TSTAMP^XMXUTIL1
32 . H XMHANG
33 L -^XMBPOST(XMGROUP,XMQUEUE)
34 Q
35RDELIVER(XMGROUP,XMQUEUE,XMTSTAMP,XMZ,XMMCNT,XMRCNT,XMACNT) ; was ^XMADJF1
36 ; Note: We know that XMGROUP="R" here
37 N XMZR,XMREC,XMFROM,XMFLIST,XMFIRST,XMFDA,I,XMZREC,XMZSUBJ,XMZFROM,XMZDATE,XMRESPS,XMTO,XMZRLIST
38 ; XMFIRST sender of the first response processed
39 K ^XMBPOST(XMGROUP,XMQUEUE,"B",XMZ,XMTSTAMP) ; Accept no more additions to this batch of replies
40 ;Post responses to message response multiple, keeping track of number of deliveries
41 S (XMMCNT,XMRCNT,XMACNT)=0
42 I '$D(^XMB(3.9,XMZ,0)) D Q
43 . D BADERR(36240,XMZ) ; Message |1| does not exist. Can't post responses to it.
44 . S XMZR=""
45 . F S XMZR=$O(^XMBPOST(XMGROUP,XMQUEUE,XMTSTAMP,XMZ,XMZR)) Q:XMZR="" S XMRCNT=XMRCNT+^(XMZR),XMMCNT=XMMCNT+1
46 S XMZREC=^XMB(3.9,XMZ,0)
47 S XMZSUBJ=$P(XMZREC,U),XMZFROM=$P(XMZREC,U,2),XMZDATE=$P(XMZREC,U,3)
48 S:XMZFROM="" XMZFROM=.5
49 ; If the sender of the original msg is not a recipient, make him one.
50 I XMZFROM=+XMZFROM,'$D(^XMB(3.9,XMZ,1,"C",XMZFROM)) D
51 . D ADDRECP(XMZ,$P(XMZREC,U,7)["P",XMZFROM)
52 . ;D LASTREAD(XMZ,XMZFROM,XMZDATE)
53 S XMZR=""
54 F S XMZR=$O(^XMBPOST(XMGROUP,XMQUEUE,XMTSTAMP,XMZ,XMZR)) Q:XMZR="" S XMREC=^(XMZR) D
55 . S XMMCNT=XMMCNT+1
56 . S XMRCNT=XMRCNT+$P(XMREC,U,1)
57 . I '$D(^XMB(3.9,XMZR)) D Q
58 . . N XMPARM S XMPARM(1)=XMZ,XMPARM(2)=XMZR
59 . . D BADERR(36241,.XMPARM) ; Response |2| to message |1| does not exist. Can't deliver it.
60 . ;S XMFDA(3.9001,"+1,"_XMZ_",",.01)=XMZR ; *** Moved to ^XMKP ***
61 . ;D UPDATE^DIE("","XMFDA") ; Add to response multiple in original msg
62 . S XMZRLIST(XMZR)="" ; (not used, but helps in debugging)
63 . S XMFROM=$P(XMREC,U,2)
64 . S:'$D(XMFIRST) XMFIRST=XMFROM
65 . S XMFLIST(XMFROM)=$G(XMFLIST(XMFROM))+1 ; Number of replies by this user
66 . Q:XMFROM="NR" ; Network reply *** If we implement fully networked mail, we must get the real sender, and make sure s/he's in the 'addressed to' and 'recipient' multiples.
67 . ; If the sender of the reply is not a recipient, make him one.
68 . I XMFROM,'$D(^XMB(3.9,XMZ,1,"C",XMFROM)) D ADDRECP(XMZ,$P(XMZREC,U,7)["P",XMFROM)
69 Q:'$D(XMFLIST)
70 I $O(XMFLIST(""))=XMFIRST,$O(XMFLIST(XMFIRST))="" S XMFROM=XMFIRST ; There's one sender
71 E S XMFROM="" ; There's multiple senders
72 ; At this point, XMFROM has the sender's DUZ (or 'NR' if remote)
73 ; if there was only 1 sender.
74 ; If there was more than 1 sender, then XMFROM="", so that ^XMTDL1 will
75 ; make the msg new for all recipients.
76 ; Now, deliver replies...
77 S XMRESPS=$P(^XMB(3.9,XMZ,3,0),U,4) ; Number of replies to msg
78 S XMTO=""
79 F S XMTO=$O(^XMB(3.9,XMZ,1,"C",XMTO)) Q:XMTO'>0 D
80 . S I=$O(^XMB(3.9,XMZ,1,"C",XMTO,0))
81 . Q:$G(^XMB(3.9,XMZ,1,I,"D")) ; User terminated
82 . I $D(XMFLIST(XMTO)) D:XMTO=XMFIRST GOTREPLY(XMZ,XMRESPS,I,XMFLIST(XMTO)) Q:XMTO=XMFROM ; If recipient is the only sender, don't bother delivering to him, because he's already seen it.
83 . Q:$P(^XMB(3.9,XMZ,1,I,0),U,2)=XMRESPS ; Don't deliver if recipient has already seen all responses
84 . S XMACNT=XMACNT+1
85 . D DELIVER^XMTDL2(XMTO,XMZ,XMZSUBJ,XMZFROM,XMFROM,1)
86 Q
87ADDRECP(XMZ,XMPRI,XMRECP) ; Add a recipient to the message
88 N XMFDA
89 S XMFDA(3.91,"+1,"_XMZ_",",.01)=XMRECP
90 I XMPRI,+XMRECP=XMRECP,$P($G(^XMB(3.7,XMRECP,0)),U,11) S XMFDA(3.91,"+1,"_XMZ_",",10)=$P(^(0),U,11) ; priority response flag
91 D UPDATE^DIE("","XMFDA")
92 S XMFDA(3.911,"+1,"_XMZ_",",.01)=$$NAME^XMXUTIL(XMRECP)
93 D UPDATE^DIE("","XMFDA")
94 Q
95LASTREAD(XMZ,XMZFROM,XMZDATE) ; Note that the sender has read the original message
96 N XMFDA,XMIEN
97 S XMIEN=$O(^XMB(3.9,XMZ,1,"C",XMZFROM,0)) Q:'XMIEN
98 S XMFDA(3.91,XMIEN_","_XMZ_",",1)=0 ; Read the original msg
99 S XMFDA(3.91,XMIEN_","_XMZ_",",2)=XMZDATE ; Last Read
100 S XMFDA(3.91,XMIEN_","_XMZ_",",11)=XMZDATE ; First Read
101 D FILE^DIE("","XMFDA")
102 Q
103GOTREPLY(XMZ,XMRESPS,XMIEN,XMRNEW) ; Note that recipient has seen his own reply.
104 N XMFDA
105 ; If last reply seen + # responses made = total responses...
106 I $P(^XMB(3.9,XMZ,1,XMIEN,0),U,2)+XMRNEW=XMRESPS D
107 . S XMFDA(3.91,XMIEN_","_XMZ_",",1)=XMRESPS
108 . D FILE^DIE("","XMFDA")
109 Q
110MDELIVER(XMGROUP,XMQUEUE,XMTSTAMP,XMUID,XMMCNT,XMRCNT,XMACNT) ; was ^XMADJF1
111 N XMZSUBJ,XMZFROM,XMZDATE,XMZPDATE,XMZBSKT,XMREC,XMZ,XMK,XMDEL,XMBCAST
112 ; Note: We know that XMGROUP="M" here
113 ; If $L(XMUID,U)>1, it's a forwarded message, else it's a new message.
114 S XMMCNT=1
115 S XMREC=^XMBPOST(XMGROUP,XMQUEUE,XMTSTAMP,XMUID)
116 S XMRCNT=+$P(XMREC,U,1)
117 S XMACNT=0
118 S XMZ=+XMUID
119 I '$D(^XMB(3.9,XMZ,0)) D Q
120 . I $L(XMUID,U)>1 K ^XMBPOST("FWD",XMUID_U_XMTSTAMP)
121 . D BADERR(36242,XMZ) ; Message |1| does not exist. Can't deliver it.
122 S XMZSUBJ=$P(^XMB(3.9,XMZ,0),U),XMZFROM=$P(^(0),U,2),XMZDATE=$P(^(0),U,3),XMZPDATE=$P(^(0),U,6)
123 S:XMZFROM="" XMZFROM=.5
124 I XMZPDATE,XMZPDATE'>DT D Q ; If purge date has passed, don't deliver
125 . I $L(XMUID,U)>1 K ^XMBPOST("FWD",XMUID_U_XMTSTAMP)
126 I $P(XMREC,U,2)'="" D ; basket selection
127 . I $L(XMUID,U)=1 S XMK(XMZFROM)=$P(XMREC,U,2) Q ; sending person
128 . I $P(XMUID,U,2) S XMK($P(XMUID,U,2))=$P(XMREC,U,2) ; forwarding person
129 I $P(XMREC,U,3)'="" S XMK(.6)=$P(XMREC,U,3)
130 I $P(XMREC,U,4) S XMDEL(.6)=$P(XMREC,U,4)
131 S XMBCAST=($P(XMREC,U,5)'="")
132 S XMZBSKT=$P($G(^XMB(3.9,XMZ,.5)),U,1)
133 I $L(XMUID,U)=1 D NEW(XMGROUP,XMQUEUE,XMTSTAMP,XMZ,XMBCAST,.XMK,.XMDEL,XMZSUBJ,XMZFROM,XMZDATE,XMZPDATE,XMZBSKT,.XMACNT) Q
134 D FORWARD(XMGROUP,XMQUEUE,XMTSTAMP,XMUID,XMZ,XMBCAST,.XMK,.XMDEL,XMZSUBJ,XMZFROM,XMZPDATE,XMZBSKT,.XMACNT)
135 Q
136NEW(XMGROUP,XMQUEUE,XMTSTAMP,XMZ,XMBCAST,XMK,XMDEL,XMZSUBJ,XMZFROM,XMZDATE,XMZPDATE,XMZBSKT,XMACNT) ;
137 D:XMZFROM=+XMZFROM LASTREAD(XMZ,XMZFROM,XMZDATE)
138 I XMBCAST D BRODCAST^XMTDL1(XMZ,XMZSUBJ,XMZFROM,XMZFROM,.XMK,.XMDEL,XMZPDATE,XMZBSKT,.XMACNT)
139 N XMTO
140 S XMTO=0 ; Q: on next line ensures only local user delivery
141 F S XMTO=$O(^XMB(3.9,XMZ,1,"C",XMTO)) Q:XMTO'>0 D
142 . I XMBCAST,$D(^XMB(3.7,"M",XMZ,XMTO)) Q
143 . S XMACNT=XMACNT+1
144 . D DELIVER^XMTDL2(XMTO,XMZ,XMZSUBJ,XMZFROM,XMZFROM,0,$G(XMK(XMTO)),$G(XMDEL(XMTO),XMZPDATE),XMZBSKT)
145 Q
146FORWARD(XMGROUP,XMQUEUE,XMTSTAMP,XMUID,XMZ,XMBCAST,XMK,XMDEL,XMZSUBJ,XMZFROM,XMZPDATE,XMZBSKT,XMACNT) ;
147 N I,J,XMFROM,XMTO,XMTOLIST
148 S XMFROM=$P(XMUID,U,2)
149 S XMUID=XMUID_U_XMTSTAMP
150 I XMBCAST D BRODCAST^XMTDL1(XMZ,XMZSUBJ,XMZFROM,XMFROM,.XMK,.XMDEL,XMZPDATE,XMZBSKT,.XMACNT) Q:'$D(^XMBPOST("FWD",XMUID))
151 S I=0
152 F S I=$O(^XMBPOST("FWD",XMUID,I)) Q:'I S XMTOLIST=^(I) D
153 . F J=1:1:$L(XMTOLIST,U) D
154 . . S XMTO=$P(XMTOLIST,U,J)
155 . . Q:$O(^XMB(3.7,"M",XMZ,XMTO,"")) ; User already has msg
156 . . Q:'$D(^XMB(3.9,XMZ,1,"C",XMTO)) ; User is not on recipient list (Should never happen
157 . . S XMACNT=XMACNT+1
158 . . D DELIVER^XMTDL2(XMTO,XMZ,XMZSUBJ,XMZFROM,XMFROM,0,$G(XMK(XMTO)),$G(XMDEL(XMTO),XMZPDATE),XMZBSKT)
159 K ^XMBPOST("FWD",XMUID)
160 Q
161BADERR(XMDIALOG,XMPARM) ;
162 N XMTEXT,XMINSTR
163 D BLD^DIALOG(XMDIALOG,.XMPARM,"","XMTEXT")
164 S XMINSTR("FROM")="MailMan"
165 D TASKBULL^XMXBULL(DUZ,"XM_TRANSMISSION_ERROR","","XMTEXT",.5,.XMINSTR)
166 Q
Note: See TracBrowser for help on using the repository browser.