source: FOIAVistA/trunk/r/MAILMAN-XM/XMS3.m@ 931

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1XMS3 ;ISC-SF/GMB-SMTP Send (RFC 822) ;04/15/2003 12:44
2 ;;8.0;MailMan;**18**;Jun 28, 2002
3 ; Entry points (DBIA 10073):
4 ; REC Get the next line of message text
5 Q
6HEADER(XMZ,XMZREC,XMFROM,XMNETNAM) ; RFC 822 - Header Records
7 ; These records are what you see when you do a "QN" at the prompt:
8 ; "Message Action: Ignore//"
9 S XMSG="Subject: "_$S($P(XMZREC,U)=$$EZBLD^DIALOG(34012):"",1:$P(XMZREC,U)) X XMSEN Q:ER
10 S XMSG="Date: "_$$INDT^XMXUTIL1($P(XMZREC,U,3)) X XMSEN Q:ER
11 S XMSG="Message-ID: <"_$$NETID(XMZ)_">" X XMSEN Q:ER
12 I $D(^XMB(3.9,XMZ,"IN")) D Q:ER
13 . N XMINRE
14 . S XMINRE=^XMB(3.9,XMZ,"IN")
15 . I $P(XMINRE,"@",1)?.E1".VA.GOV"!($P(XMINRE,"@",2)?.N) S XMINRE=$P(XMINRE,"@",2)_"@"_$P(XMINRE,"@")
16 . S XMSG="In-reply-to: <"_XMINRE_">" X XMSEN
17 I "^Y^y^"[(U_$P(XMZREC,U,5)_U) D Q:ER
18 . S XMSG="Return-Receipt-To: "_XMFROM X XMSEN
19 I $D(^XMB(3.9,XMZ,"K")) D Q:ER
20 . S XMSG="Encrypted: "_$P(XMZREC,U,10)_U_^("K") X XMSEN
21 I $P(XMZREC,U,4)'="" D Q:ER
22 . S XMSG="Sender: "_$$FROM^XMS1($P(XMZREC,U,4),XMNETNAM) X XMSEN
23 S XMSG="From: "_XMFROM X XMSEN Q:ER
24 I $P(XMZREC,U,6)'="" D Q:ER
25 . S XMSG="Expiry-Date: "_$$INDT^XMXUTIL1($P(XMZREC,U,6)) X XMSEN
26 I $P(XMZREC,U,7)["P" D Q:ER
27 . S XMSG="Importance: high" X XMSEN Q:ER
28 . S XMSG="X-Priority: 1" X XMSEN
29 I "^Y^y^"[(U_$P(XMZREC,U,11)_U) D Q:ER
30 . S XMSG="Sensitivity: Private" X XMSEN
31 I $D(^XMB(3.9,XMZ,.5)) D Q:ER
32 . N XMZBSKT
33 . S XMZBSKT=$P($G(^XMB(3.9,XMZ,.5)),U,1)
34 . Q:XMZBSKT=""
35 . S XMSG="X-MM-Basket: "_XMZBSKT X XMSEN
36 I $P(XMZREC,U,7)'="",$P(XMZREC,U,7)'="P" D Q:ER
37 . S XMSG="X-MM-Type: "_$P(XMZREC,U,7) X XMSEN
38 I "^Y^y^"[(U_$P(XMZREC,U,9)_U) D Q:ER
39 . S XMSG="X-MM-Closed: YES" X XMSEN
40 I "^Y^y^"[(U_$P(XMZREC,U,12)_U) D Q:ER
41 . S XMSG="X-MM-Info-Only: YES" X XMSEN
42 D TOLIST(XMZ,XMNETNAM) Q:ER
43 Q
44NETID(XMZ) ;
45 N XMCRE8
46 S XMCRE8=$P($G(^XMB(3.9,XMZ,.6)),U,1)
47 I 'XMCRE8 D
48 . S XMCRE8=$P($G(^XMB(3.9,XMZ,0)),U,3)
49 . I $P(XMCRE8,".")?7N S XMCRE8=$P(XMCRE8,".")
50 . E D
51 . . S XMCRE8=$$CONVERT^XMXUTIL1(XMCRE8)
52 . . I XMCRE8=-1 S XMCRE8=DT
53 . S $P(^XMB(3.9,XMZ,.6),U,1)=XMCRE8
54 . S ^XMB(3.9,"C",XMCRE8,XMZ)=""
55 N XMREMID
56 I $D(^XMB(3.9,XMZ,5)) D Q:XMREMID'="" XMREMID
57 . S XMREMID=^XMB(3.9,XMZ,5)
58 . I $P(XMREMID,"@",1)?.E1".VA.GOV"!($P(XMREMID,"@",2)?.N) S XMREMID=$P(XMREMID,"@",2)_"@"_$P(XMREMID,"@")
59 . Q:XMREMID'=""
60 . D PARSE^XMR3(XMZ,.XMREMID)
61 ;Q XMZ_"@"_^XMB("NETNAME")
62 Q XMZ_"."_XMCRE8_"@"_^XMB("NETNAME")
63TOLIST(XMZ,XMNETNAM) ;
64 N XMTO,XMIEN
65 S XMIEN=$O(^XMB(3.9,XMZ,6,0)),XMSG="To: "_$$TOFORMAT($P(^XMB(3.9,XMZ,6,XMIEN,0),U,1),$S($G(XMC("MAILMAN")):$P(^(0),U,2),1:""))
66 F S XMIEN=$O(^XMB(3.9,XMZ,6,XMIEN)) Q:'XMIEN!(XMIEN>50) D Q:ER
67 . S XMTO=$$TOFORMAT($P(^XMB(3.9,XMZ,6,XMIEN,0),U,1),$S($G(XMC("MAILMAN")):$P(^(0),U,2),1:""))
68 . S XMSG=XMSG_","
69 . I $L(XMSG)+$L(XMTO)>80 D TOSEND(.XMSG) Q:ER
70 . S XMSG=XMSG_" "_XMTO
71 Q:ER
72 D TOSEND(.XMSG) Q:ER
73 I XMIEN>50 S XMSG="(Too many recipients to list...)" D TOSEND(.XMSG) Q:ER
74 Q
75TOFORMAT(XMTO,XMPREFIX) ;
76 N XMDOM
77 S XMDOM=$S(XMTO["@":$P(XMTO,"@",2,99),1:XMNETNAM)
78 S XMTO=$$TO($P(XMTO,"@"))
79 Q $S(XMPREFIX="":"",$E(XMTO,1)=$C(34):"",1:XMPREFIX_":")_XMTO_"@"_XMDOM
80TO(XMTO) ;
81 I $E(XMTO)'=$C(34),(XMTO[",")!(XMTO[" ") D
82 . I XMTO["," S XMTO=$TR(XMTO,", .","._+")
83 . I XMTO[" " S XMTO=$C(34)_XMTO_$C(34)
84 Q XMTO
85TOSEND(XMSG) ;
86 I $L(XMSG)>80 D Q
87 . N XMSGHOLD,XMPIECES
88 . S XMPIECES=$L(XMSG,"@")
89 . S XMSGHOLD=$P(XMSG,"@",XMPIECES)
90 . S XMSG=$P(XMSG,"@",1,XMPIECES-1)
91 . X XMSEN
92 . S XMSG=" @"_XMSGHOLD
93 X XMSEN
94 S XMSG=" "
95 Q
96TEXT(XMZ) ; Send body of text
97 N XMS0AJ
98 ;S XMBLOCK=1 ; *** What's this? See ^XML4CRC* & ^XMLSWP*
99 S XMS0AJ=0
100 F S XMS0AJ=$O(^XMB(3.9,XMZ,2,XMS0AJ)) Q:XMS0AJ'>0 D Q:ER
101 . S XMSG=^XMB(3.9,XMZ,2,XMS0AJ,0)
102 . I $E(XMSG)="." S XMSG="."_XMSG
103 . E I $E(XMSG,1,4)="~*~^" S XMSG=" "_XMSG ; *** What's this?
104 . X XMSEN
105 I ER S ER("MSG")="Error sending msg "_XMZ_", text line "_XMS0AJ Q
106 ;D:$D(XMBLOCK) KILL^XML4CRC
107 Q
108RCPTERR(XMERRMSG,XMZ,XMZREC,XMNVFROM,XMRCPTO,XMRCPT,XMIEN) ; Non-delivery to recipient
109 N XMFDA,XMIENS,XMTO,XMPARM,XMINSTR
110 S XMIENS=XMIEN_","_XMZ_","
111 S XMFDA(3.91,XMIENS,3)="@" ; remote msg id
112 S XMFDA(3.91,XMIENS,4)=XMCM("START","FM") ; xmit date/time
113 S XMFDA(3.91,XMIENS,5)=$E($P(XMERRMSG," ",2,999),1,30) ; status
114 S XMFDA(3.91,XMIENS,6)="@" ; path
115 D FILE^DIE("","XMFDA")
116 S XMTO=$$SENDER(XMZ,XMZREC,XMNVFROM,XMIEN,1,XMERRMSG) Q:"<>"[XMTO
117 S XMINSTR("FROM")="POSTMASTER"
118 S XMPARM(1)=$P(XMZREC,U,1) ; subject
119 S XMPARM(2)=XMRCPTO
120 S XMPARM(3)=XMERRMSG
121 S XMPARM(4)=XMRCPT
122 S XMPARM(5)=$S(XMTO["@":$G(^XMB(3.9,XMZ,5)),1:XMZ)
123 D TASKBULL^XMXBULL(.5,"XM SEND ERR RECIPIENT",.XMPARM,"",XMTO,.XMINSTR)
124 Q
125MSGERR(XMSITE,XMINST,XMERRMSG,XMZ,XMZREC,XMNVFROM,XMRCPT) ;
126 ; If a message is rejected at a site for any reason (the whole message,
127 ; not just one recipient), then this message may be sent.
128 N XMTO,XMPARM,XMIEN,XMNAME,XMCNT,XMINSTR
129 D DOTRAN^XMC1(XMERRMSG)
130 S XMPARM(3)=XMERRMSG
131 S XMERRMSG=$E($P(XMERRMSG," ",2,999),1,30)
132 K ^TMP("XM",$J,"REJECT")
133 S XMIEN=""
134 F S XMIEN=$S($D(XMRCPT):$O(XMRCPT(XMIEN)),1:$O(^XMB(3.9,XMZ,1,"AQUEUE",XMINST,XMIEN))) Q:XMIEN="" D
135 . N XMFDA,XMIENS
136 . S XMIENS=XMIEN_","_XMZ_","
137 . S XMFDA(3.91,XMIENS,3)="@" ; remote msg id
138 . S XMFDA(3.91,XMIENS,4)=XMCM("START","FM") ; xmit date/time
139 . S XMFDA(3.91,XMIENS,5)=XMERRMSG ; status
140 . S XMFDA(3.91,XMIENS,6)="@" ; path
141 . S XMFDA(3.91,XMIENS,9)="@" ; xmit time
142 . D FILE^DIE("","XMFDA")
143 . S XMNAME=$P($G(^XMB(3.9,XMZ,1,XMIEN,0)),U,1) Q:XMNAME=""
144 . S XMTO=$$SENDER(XMZ,XMZREC,XMNVFROM,XMIEN) Q:"<>"[XMTO
145 . S (XMCNT,^(XMTO))=$G(^TMP("XM",$J,"REJECT",XMTO))+1
146 . S ^TMP("XM",$J,"REJECT",XMTO,XMCNT)=XMNAME
147 S XMINSTR("FROM")="POSTMASTER"
148 S XMPARM(1)=$P(XMZREC,U,1) ; subject
149 S XMPARM(2)=XMSITE
150 S XMTO=""
151 F S XMTO=$O(^TMP("XM",$J,"REJECT",XMTO)) Q:XMTO="" D TASKBULL^XMXBULL(.5,"XM SEND ERR MSG",.XMPARM,"^TMP(""XM"",$J,""REJECT"",XMTO)",XMTO,.XMINSTR)
152 K ^TMP("XM",$J,"REJECT")
153 Q
154SENDER(XMZ,XMZREC,XMNVFROM,XMIEN,XMDELFWD,XMERRMSG) ; Function returns 'to whom to send error message'
155 N XMFWDREC,XMFWDR
156 S XMFWDREC=$G(^XMB(3.9,XMZ,1,XMIEN,"F")) ; Try to find forwarder
157 S XMFWDR=$P(XMFWDREC,U,2)
158 I XMFWDR'="" D Q XMFWDR ; Forwarder is local
159 . I $G(XMDELFWD) D DELFWD(XMZ,XMIEN,XMFWDR,XMERRMSG)
160 I $E(XMFWDREC)="<" Q $E($P($P(XMFWDREC,U,1),">",1),2,999) ; Forwarder is remote
161 Q:$D(^XMB(3.9,XMZ,.7)) XMNVFROM ; Sender is remote
162 N XMFROM
163 S XMFROM=$P(XMZREC,U,2)
164 I +XMFROM=XMFROM Q XMFROM ; Sender is local
165 I XMFROM'["@" Q .5 ; Sender is fictitious, so notify postmaster
166 Q XMNVFROM ; Sender is remote
167DELFWD(XMZ,XMIEN,XMFWDR,XMERRMSG) ; Delete user's forwarding address
168 Q:+XMFWDR'=XMFWDR
169 N XMFWD
170 S XMFWD=$P(^XMB(3.7,XMFWDR,0),U,2) Q:XMFWD=""
171 N XMINSTR,XMADDR,XMFULL,XMERROR,XMFDA,XMTXT,XMFWDADD
172 S XMINSTR("ADDR FLAGS")="X" ; do not create ^TMP(, just check.
173 S XMADDR=$P(^XMB(3.9,XMZ,1,XMIEN,0),U,1)
174 D ADDRESS^XMXADDR(DUZ,XMFWD,.XMFULL,.XMERROR)
175 I '$D(XMERROR),XMADDR'=$G(XMFULL) Q
176 D DELFWD^XMVVITA(XMFWDR,XMFWD,XMERRMSG)
177 Q
178 ; The following has nothing to do with the above.
179 ; These are used by the SERVER Communications Protocol in file 3.4.
180REC ; Read the next line of text from the message. When called for the
181 ; first time, returns the first line.
182 ; In:
183 ; XMZ - IEN of the message in file 3.9
184 ; XMPOS - (optional) line number of the previous line read
185 ; Default is .999999
186 ; Out:
187 ; XMPOS - line number of XMRG
188 ; XMRG - =the next line of text, if OK; ="" if end of text reached
189 ; XMER - =0 if OK; =-1 if end of text reached
190 S XMPOS=$S('$D(XMPOS):.999999,XMPOS<.999999:.999999,1:XMPOS)
191 S XMPOS=$O(^XMB(3.9,XMZ,2,XMPOS))
192 I +XMPOS'=XMPOS S XMER=-1,XMRG="" Q
193 S XMRG=^XMB(3.9,XMZ,2,XMPOS,0),XMER=0
194 Q
195SEN ; Send a line to the return message
196 S XMSLINE=XMSLINE+1,^XMB(3.9,XMZ,2,XMSLINE,0)=XMSG
197 Q
198OPEN ; Open the reverse message path
199 Q
200CLOSE ; Close the reverse message
201 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_XMSLINE_U_XMSLINE_U_DT
202 Q
Note: See TracBrowser for help on using the repository browser.