source: WorldVistAEHR/trunk/r/MAILMAN-XM/XMS1.m@ 701

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

initial load of WorldVistAEHR
File size: 7.3 KB
Line 
1XMS1 ;ISC-SF/GMB-SMTP Send (RFC 821) ;05/20/2002 08:40
2 ;;8.0;MailMan;**30**;Jun 28, 2002
3 ; Was ISC-WASH/THM/CAP
4 ;
5 ; Entry points (DBIA 1151):
6 ; $$SRVTIME Set message transmission status information
7 ; $$STATUS Get message transmission status information
8SENDMSG(XMK,XMZ,XMB) ;
9 N XMZREC,XMNVFROM,XMFROM,XMRCPT,XMNETNAM,XMRZ,XMCM
10 ; XMCM("START") - timestamp at start of msg xmit
11 ; XMCM("START","FM") - FM date/time (no seconds) at start of msg xmit
12 K XMTLER,XMBLOCK,XMLIN
13 D INIT(XMINST,XMZ,.XMZREC,.XMNVFROM,.XMFROM,.XMNETNAM)
14 D ENVELOPE(XMNETNAM,XMINST,XMZ,XMZREC,XMNVFROM,.XMRZ,.XMRCPT) Q:ER
15 D FINISH(XMINST,XMZ,XMRZ)
16 Q
17INIT(XMINST,XMZ,XMZREC,XMNVFROM,XMFROM,XMNETNAM) ;
18 N XMFDA,XMIENS
19 S XMIENS=XMINST_","
20 S XMFDA(4.2999,XMIENS,1)=$H
21 S XMFDA(4.2999,XMIENS,2)=XMZ ; Message in transit
22 ;S XMFDA(4.2999,XMIENS,3)="@" ; Last line xmit'd
23 D FILE^DIE("","XMFDA")
24 S XMNETNAM=^XMB("NETNAME")
25 S XMCM("START")=$$TSTAMP^XMXUTIL1
26 S XMCM("START","FM")=+$E($$NOW^XLFDT,1,12) ; Strip off the seconds
27 S XMZREC=^XMB(3.9,XMZ,0)
28 S XMFROM=$$FROM($P(XMZREC,U,2),XMNETNAM)
29 S XMNVFROM=$P($G(^XMB(3.9,XMZ,.7)),U,1) ; envelope from
30 I XMNVFROM="" S XMNVFROM=XMFROM
31 Q
32ENVELOPE(XMNETNAM,XMINST,XMZ,XMZREC,XMNVFROM,XMRZ,XMRCPT) ;
33 ; These commands are part of RFC 821 - SMTP.
34 N XMRSET
35 D MAIL(XMZ,XMZREC,.XMNVFROM,.XMRZ) Q:ER
36 D RCPT(XMNETNAM,XMINST,XMZ,XMZREC,XMNVFROM,.XMRCPT) Q:ER
37 ;I 'XMC("MAILMAN") D CHEKSPEC^XMS2(XMZREC)
38 I XMC("MAILMAN") D NONSTD^XMS2(XMNETNAM,XMZ,XMZREC,.XMRZ,.XMRSET) Q:ER
39 D DATACMD Q:ER
40 I $G(XMRSET) D Q:ER ; Send: "" (if 'duplicate message')
41 . S XMSG="" X XMSEN
42 E D Q:ER ; Send: header records followed by message text
43 . I '$D(^XMB(3.9,XMZ,2,.001)) D Q:ER
44 . . D HEADER^XMS3(XMZ,XMZREC,XMFROM,XMNETNAM) Q:ER
45 . . S XMSG="" X XMSEN Q:ER
46 . D TEXT^XMS3(XMZ)
47 ; Send: "."
48 ; Recv: "250 'data' accepted"
49 ; or: "254 Duplicate (no add'l recipients). Msg rejected."
50 ; or: "551 Too many lines. Msg rejected."
51 ; or: "554 Duplicate (purged). Msg rejected."
52 ; or: "555 Reply to 'Info Only'. Msg rejected."
53 S XMSG="." X XMSEN Q:ER
54 I 'XMC("BATCH") S XMSTIME=300 X XMREC K XMSTIME Q:ER
55 S:XMC("BATCH") XMRG="250 OK"
56 Q:$E(XMRG)=2
57 S (ER,ER("NONFATAL"))=1
58 I "^551^554^555^552^"'[(U_$E(XMRG,1,3)_U) Q
59 S XMRZ=$P(XMRG," ",2,99)
60 D MSGERR^XMS3(XMSITE,XMINST,XMRG,XMZ,XMZREC,XMNVFROM,.XMRCPT)
61 Q
62DATACMD ; Send: "DATA"
63 ; Recv: "354 Enter data"
64 S XMSG="DATA" X XMSEN Q:ER
65 I 'XMC("BATCH") X XMREC Q:ER
66 S:XMC("BATCH") XMRG=300
67 Q:$E(XMRG)=3
68 D ERTRAN^XMC1(42356) ;Receiver will not accept DATA.
69 S ER("MSG")=XMTRAN_" - "_XMRG
70 Q
71MAIL(XMZ,XMZREC,XMNVFROM,XMRZ) ; Send mail
72 ; Send: "MAIL FROM:<USER.JOE@LOCAL.MED.VA.GOV>"
73 ; Recv: "250 OK Message-ID:123456@REMOTE.MED.VA.GOV"
74 S XMSG="MAIL FROM:"_XMNVFROM X XMSEN Q:ER
75 I 'XMC("BATCH") S XMSTIME=300 X XMREC K XMSTIME Q:ER
76 I XMC("BATCH") S XMRG="200 ID:Batch"
77 I $E(XMRG)'=2 D Q
78 . S (ER,ER("NONFATAL"))=1
79 . Q:"^501^502^553^"'[(U_$E(XMRG,1,3)_U)
80 . ; 501: Exchange says Syntax error
81 . ; 502: MailMan says it won't accept msgs from you.
82 . ; 553: Exchange says something's wrong with your FROM address.
83 . D MSGERR^XMS3(XMSITE,XMINST,XMRG,XMZ,XMZREC,XMNVFROM)
84 S XMRZ=$P(XMRG,"ID:",2)
85 Q
86FROM(XMFROM,XMNETNAM) ;
87 I $F(XMFROM,"@"_XMNETNAM)>$L(XMFROM) S XMFROM=$P(XMFROM,"@"_XMNETNAM)
88 I XMFROM'["@" Q "<"_$$NETNAME^XMXUTIL(XMFROM)_">"
89 Q "<"_$$REMADDR^XMXADDR3(XMFROM)_">"
90RCPT(XMNETNAM,XMINST,XMZ,XMZREC,XMNVFROM,XMRCPT) ; Identify Recipients
91 ; Send: "RCPT TO:<USER.JANE@REMOTE.MED.VA.GOV>"
92 ; Recv: "250 'RCPT' accepted"
93 ; or: "550 Addressee not found." or "550 Addressee ambiguous."
94 ;
95 ; When communicating with a MailMan site, we also can add non-standard
96 ; information on who forwarded the message to this recipient, and/or
97 ; whether the recipient is 'information only' or 'copy'.
98 ; Send: "RCPT TO:<I:USER.JANE@REMOTE.MED.VA.GOV> FWD BY:<USER.LEX@LOCAL.MED.VA.GOV>"
99 N XMIEN,XMTO,XMTOREC,XMPREFIX,XMTOX,XMTRY,XMFWDBY,XM2MANY
100 S (XMIEN,XM2MANY)=0
101 F S XMIEN=$O(^XMB(3.9,XMZ,1,"AQUEUE",XMINST,XMIEN)) Q:XMIEN="" D Q:ER!XM2MANY
102 . S XMTOREC=$G(^XMB(3.9,XMZ,1,XMIEN,0))
103 . I $P(XMTOREC,U,7)'=XMINST D Q
104 . . K ^XMB(3.9,XMZ,1,"AQUEUE",XMINST,XMIEN)
105 . I XMC("MAILMAN") D
106 . . S XMPREFIX=$P($G(^XMB(3.9,XMZ,1,XMIEN,"T")),U)
107 . . S XMFWDBY=$G(^XMB(3.9,XMZ,1,XMIEN,"F"))
108 . . I XMFWDBY'="" S XMFWDBY=$$FWDBY(XMFWDBY)
109 . E S (XMPREFIX,XMFWDBY)=""
110 . S XMTO=$$TOFORMAT($P(XMTOREC,U),XMPREFIX)
111 . S XMSG="RCPT TO:<"_XMTO_">"_$S(XMFWDBY="":"",1:" FWD BY:"_XMFWDBY) X XMSEN Q:ER
112 . I 'XMC("BATCH") S XMSTIME=300 X XMREC K XMSTIME Q:ER
113 . I XMC("BATCH") S XMRG="250 In transit"
114 . I $E(XMRG,1,2)=25 S XMRCPT(XMIEN)="" Q
115 . I $E(XMRG,1,3)=552 S XM2MANY=1 Q ; 552: Too many recipients / exceed storage allocation
116 . I $E(XMRG,1,3)=221 S ER=1 Q ; 221: Closing Connection
117 . D RCPTERR^XMS3(XMRG,XMZ,XMZREC,XMNVFROM,$P(XMTOREC,U),XMTO,XMIEN)
118 S:'$D(XMRCPT) (ER,ER("NONFATAL"))=1
119 Q
120TOFORMAT(XMTO,XMPREFIX) ;
121 N XMDOM
122 S XMDOM=$S(XMTO["@":$P(XMTO,"@",2,99),1:XMNETNAM)
123 S XMTO=$$TO($P(XMTO,"@"))
124 Q $S(XMPREFIX="":"",$E(XMTO,1)=$C(34):"",1:XMPREFIX_":")_XMTO_"@"_XMDOM
125TO(XMTO) ;
126 I XMTO?.E1C.E S XMTO=$$CTRL^XMXUTIL1(XMTO)
127 Q:XMTO?.A XMTO
128 I $E(XMTO)=$C(34),$E(XMTO,$L(XMTO))=$C(34) Q XMTO
129 ; If we translate blanks to underscores, we have to be careful with
130 ; G. and S. names which contain blanks. ^XMXADDR* looks for G. and
131 ; S. names, and it will translate them back, if necessary.
132 ; But Austin is running pre-patch 50 v7.1 MailMan code, which will not
133 ; translate them back. So... for G. and S., we will only translate
134 ; when sending to non-MailMan sites.
135 I XMTO[","!XMTO[" " D
136 . I ".G.g.D.d.H.h.S.s."[("."_$E(XMTO,1,2)),XMC("MAILMAN") Q
137 . S XMTO=$TR(XMTO,", .","._+")
138 ;Allowed punctuation (without quoting rcpt name is .%_-@+!
139 I $TR(XMTO,"()<>@,;:\[]"_$C(34),"")=XMTO Q XMTO
140 N I,% ; Reformat name for \ and " characters
141 F %="\",$C(34) D
142 . S I=0
143 . F S I=$F(XMTO,%,I+1) Q:'I S XMTO=$E(XMTO,1,I-2)_"\"_$E(XMTO,I-1,999)
144 Q XMTO
145FWDBY(XMFREC) ;
146 I $E(XMFREC,1)=" " Q ""
147 I $E(XMFREC,1)="<" Q $P(XMFREC,">",1)_">"
148 N XMFDUZ
149 S XMFDUZ=$P(XMFREC,U,2)
150 I +XMFDUZ=XMFDUZ Q "<"_$$NETNAME^XMXUTIL(XMFDUZ)_">"
151 Q ""
152FINISH(XMINST,XMZ,XMRZ) ;
153 D XMTHIST^XMTDR(XMINST,"S",$P($G(^XMB(3.9,XMZ,2,0)),U,4))
154 N XMIEN,XMIENS
155 S XMIEN=0
156 F S XMIEN=$O(XMRCPT(XMIEN)) Q:'XMIEN D
157 . N XMFDA
158 . S XMIENS=XMIEN_","_XMZ_","
159 . S XMFDA(3.91,XMIENS,3)=XMRZ ; remote msg id
160 . S XMFDA(3.91,XMIENS,4)=XMCM("START","FM") ; xmit date/time
161 . S XMFDA(3.91,XMIENS,5)=$S(XMC("BATCH"):$$EZBLD^DIALOG(39303.6),1:"@") ; status: In transit
162 . S XMFDA(3.91,XMIENS,6)="@" ; path
163 . S XMFDA(3.91,XMIENS,9)=$$TSTAMP^XMXUTIL1-XMCM("START") ; xmit time (seconds)
164 . D FILE^DIE("","XMFDA")
165 . S $P(^XMB(3.9,XMZ,1,XMIEN,0),U,7)=XMINST_":"_XMINST ; violates the DD, but we've always done this, and it might help in debugging.
166 Q
167 ; The following have nothing to do with the above.
168 ; They are simply here because of an existing DBIA.
169STATUS(XMZ,XMRECIP) ; Get Recipient Status
170 N XMIEN
171 S XMIEN=$$FIND1^DIC(3.91,","_XMZ_",","QX",XMRECIP,"C") Q:'XMIEN ""
172 Q $P($G(^XMB(3.9,XMZ,1,XMIEN,0)),U,6)
173SRVTIME(XMZ,XMRECIP,XMSTRING) ; Set Recipient Status
174 ;Returns 0 for success, 1 for failure
175 ;Parameters=(Message#,Recipient,Status)
176 I $L(XMSTRING)>30 Q "2 Status too long"
177 I XMSTRING[U Q "3 Bad Characters in Status"
178 N XMIEN,XMIENS
179 S XMIEN=$$FIND1^DIC(3.91,","_XMZ_",","QX",XMRECIP,"C") Q:'XMIEN "1 No Update"
180 S XMIENS=XMIEN_","_XMZ_","
181 D SETSTAT^XMTDO(XMIENS,XMSTRING)
182 Q 0
Note: See TracBrowser for help on using the repository browser.