Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XMS1

XMS1.m

Go to the documentation of this file. 
  1. XMS1 ;ISC-SF/GMB-SMTP Send (RFC 821) ;05/20/2002  08:40
  1.  ;;8.0;MailMan;**30**;Jun 28, 2002;Build 1
  1.  ; Was ISC-WASH/THM/CAP
  1.  ;
  1.  ; Entry points (DBIA 1151):
  1.  ; $$SRVTIME Set message transmission status information
  1.  ; $$STATUS  Get message transmission status information
  1. SENDMSG(XMK,XMZ,XMB) ;
  1.  N XMZREC,XMNVFROM,XMFROM,XMRCPT,XMNETNAM,XMRZ,XMCM
  1.  ; XMCM("START") - timestamp at start of msg xmit
  1.  ; XMCM("START","FM") - FM date/time (no seconds) at start of msg xmit
  1.  K XMTLER,XMBLOCK,XMLIN
  1.  D INIT(XMINST,XMZ,.XMZREC,.XMNVFROM,.XMFROM,.XMNETNAM)
  1.  D ENVELOPE(XMNETNAM,XMINST,XMZ,XMZREC,XMNVFROM,.XMRZ,.XMRCPT) Q:ER
  1.  D FINISH(XMINST,XMZ,XMRZ)
  1.  Q
  1. INIT(XMINST,XMZ,XMZREC,XMNVFROM,XMFROM,XMNETNAM) ;
  1.  N XMFDA,XMIENS
  1.  S XMIENS=XMINST_","
  1.  S XMFDA(4.2999,XMIENS,1)=$H
  1.  S XMFDA(4.2999,XMIENS,2)=XMZ ; Message in transit
  1.  ;S XMFDA(4.2999,XMIENS,3)="@" ; Last line xmit'd
  1.  D FILE^DIE("","XMFDA")
  1.  S XMNETNAM=^XMB("NETNAME")
  1.  S XMCM("START")=$$TSTAMP^XMXUTIL1
  1.  S XMCM("START","FM")=+$E($$NOW^XLFDT,1,12) ; Strip off the seconds
  1.  S XMZREC=^XMB(3.9,XMZ,0)
  1.  S XMFROM=$$FROM($P(XMZREC,U,2),XMNETNAM)
  1.  S XMNVFROM=$P($G(^XMB(3.9,XMZ,.7)),U,1) ; envelope from
  1.  I XMNVFROM="" S XMNVFROM=XMFROM
  1.  Q
  1. ENVELOPE(XMNETNAM,XMINST,XMZ,XMZREC,XMNVFROM,XMRZ,XMRCPT) ;
  1.  ; These commands are part of RFC 821 - SMTP.
  1.  N XMRSET
  1.  D MAIL(XMZ,XMZREC,.XMNVFROM,.XMRZ) Q:ER
  1.  D RCPT(XMNETNAM,XMINST,XMZ,XMZREC,XMNVFROM,.XMRCPT) Q:ER
  1.  ;I 'XMC("MAILMAN") D CHEKSPEC^XMS2(XMZREC)
  1.  I XMC("MAILMAN") D NONSTD^XMS2(XMNETNAM,XMZ,XMZREC,.XMRZ,.XMRSET) Q:ER
  1.  D DATACMD Q:ER
  1.  I $G(XMRSET) D  Q:ER  ; Send: "" (if 'duplicate message')
  1.  . S XMSG="" X XMSEN
  1.  E  D  Q:ER  ; Send: header records followed by message text
  1.  . I '$D(^XMB(3.9,XMZ,2,.001)) D  Q:ER
  1.  . . D HEADER^XMS3(XMZ,XMZREC,XMFROM,XMNETNAM) Q:ER
  1.  . . S XMSG="" X XMSEN Q:ER
  1.  . D TEXT^XMS3(XMZ)
  1.  ; Send: "."
  1.  ; Recv: "250 'data' accepted"
  1.  ;   or: "254 Duplicate (no add'l recipients).  Msg rejected."
  1.  ;   or: "551 Too many lines.  Msg rejected."
  1.  ;   or: "554 Duplicate (purged).  Msg rejected."
  1.  ;   or: "555 Reply to 'Info Only'.  Msg rejected."
  1.  S XMSG="." X XMSEN Q:ER
  1.  I 'XMC("BATCH") S XMSTIME=300 X XMREC K XMSTIME Q:ER
  1.  S:XMC("BATCH") XMRG="250 OK"
  1.  Q:$E(XMRG)=2
  1.  S (ER,ER("NONFATAL"))=1
  1.  I "^551^554^555^552^"'[(U_$E(XMRG,1,3)_U) Q
  1.  S XMRZ=$P(XMRG," ",2,99)
  1.  D MSGERR^XMS3(XMSITE,XMINST,XMRG,XMZ,XMZREC,XMNVFROM,.XMRCPT)
  1.  Q
  1. DATACMD ; Send: "DATA"
  1.  ; Recv: "354 Enter data"
  1.  S XMSG="DATA" X XMSEN Q:ER
  1.  I 'XMC("BATCH") X XMREC Q:ER
  1.  S:XMC("BATCH") XMRG=300
  1.  Q:$E(XMRG)=3
  1.  D ERTRAN^XMC1(42356) ;Receiver will not accept DATA.
  1.  S ER("MSG")=XMTRAN_" - "_XMRG
  1.  Q
  1. MAIL(XMZ,XMZREC,XMNVFROM,XMRZ) ; Send mail
  1.  ; Send: "MAIL FROM:<USER.JOE@LOCAL.MED.VA.GOV>"
  1.  ; Recv: "250 OK Message-ID:123456@REMOTE.MED.VA.GOV"
  1.  S XMSG="MAIL FROM:"_XMNVFROM X XMSEN Q:ER
  1.  I 'XMC("BATCH") S XMSTIME=300 X XMREC K XMSTIME Q:ER
  1.  I XMC("BATCH") S XMRG="200 ID:Batch"
  1.  I $E(XMRG)'=2 D  Q
  1.  . S (ER,ER("NONFATAL"))=1
  1.  . Q:"^501^502^553^"'[(U_$E(XMRG,1,3)_U)
  1.  . ; 501: Exchange says Syntax error
  1.  . ; 502: MailMan says it won't accept msgs from you.
  1.  . ; 553: Exchange says something's wrong with your FROM address.
  1.  . D MSGERR^XMS3(XMSITE,XMINST,XMRG,XMZ,XMZREC,XMNVFROM)
  1.  S XMRZ=$P(XMRG,"ID:",2)
  1.  Q
  1. FROM(XMFROM,XMNETNAM) ;
  1.  I $F(XMFROM,"@"_XMNETNAM)>$L(XMFROM) S XMFROM=$P(XMFROM,"@"_XMNETNAM)
  1.  I XMFROM'["@" Q "<"_$$NETNAME^XMXUTIL(XMFROM)_">"
  1.  Q "<"_$$REMADDR^XMXADDR3(XMFROM)_">"
  1. RCPT(XMNETNAM,XMINST,XMZ,XMZREC,XMNVFROM,XMRCPT) ; Identify Recipients
  1.  ; Send: "RCPT TO:<USER.JANE@REMOTE.MED.VA.GOV>"
  1.  ; Recv: "250 'RCPT' accepted"
  1.  ;   or: "550 Addressee not found." or "550 Addressee ambiguous."
  1.  ;
  1.  ; When communicating with a MailMan site, we also can add non-standard
  1.  ; information on who forwarded the message to this recipient, and/or
  1.  ; whether the recipient is 'information only' or 'copy'.
  1.  ; Send: "RCPT TO:<I:USER.JANE@REMOTE.MED.VA.GOV> FWD BY:<USER.LEX@LOCAL.MED.VA.GOV>"
  1.  N XMIEN,XMTO,XMTOREC,XMPREFIX,XMTOX,XMTRY,XMFWDBY,XM2MANY
  1.  S (XMIEN,XM2MANY)=0
  1.  F  S XMIEN=$O(^XMB(3.9,XMZ,1,"AQUEUE",XMINST,XMIEN)) Q:XMIEN=""  D  Q:ER!XM2MANY
  1.  . S XMTOREC=$G(^XMB(3.9,XMZ,1,XMIEN,0))
  1.  . I $P(XMTOREC,U,7)'=XMINST D  Q
  1.  . . K ^XMB(3.9,XMZ,1,"AQUEUE",XMINST,XMIEN)
  1.  . I XMC("MAILMAN") D
  1.  . . S XMPREFIX=$P($G(^XMB(3.9,XMZ,1,XMIEN,"T")),U)
  1.  . . S XMFWDBY=$G(^XMB(3.9,XMZ,1,XMIEN,"F"))
  1.  . . I XMFWDBY'="" S XMFWDBY=$$FWDBY(XMFWDBY)
  1.  . E  S (XMPREFIX,XMFWDBY)=""
  1.  . S XMTO=$$TOFORMAT($P(XMTOREC,U),XMPREFIX)
  1.  . S XMSG="RCPT TO:<"_XMTO_">"_$S(XMFWDBY="":"",1:" FWD BY:"_XMFWDBY) X XMSEN Q:ER
  1.  . I 'XMC("BATCH") S XMSTIME=300 X XMREC K XMSTIME Q:ER
  1.  . I XMC("BATCH") S XMRG="250 In transit"
  1.  . I $E(XMRG,1,2)=25 S XMRCPT(XMIEN)="" Q
  1.  . I $E(XMRG,1,3)=552 S XM2MANY=1 Q  ; 552: Too many recipients / exceed storage allocation
  1.  . I $E(XMRG,1,3)=221 S ER=1 Q  ; 221: Closing Connection
  1.  . D RCPTERR^XMS3(XMRG,XMZ,XMZREC,XMNVFROM,$P(XMTOREC,U),XMTO,XMIEN)
  1.  S:'$D(XMRCPT) (ER,ER("NONFATAL"))=1
  1.  Q
  1. TOFORMAT(XMTO,XMPREFIX) ;
  1.  N XMDOM
  1.  S XMDOM=$S(XMTO["@":$P(XMTO,"@",2,99),1:XMNETNAM)
  1.  S XMTO=$$TO($P(XMTO,"@"))
  1.  Q $S(XMPREFIX="":"",$E(XMTO,1)=$C(34):"",1:XMPREFIX_":")_XMTO_"@"_XMDOM
  1. TO(XMTO) ;
  1.  I XMTO?.E1C.E S XMTO=$$CTRL^XMXUTIL1(XMTO)
  1.  Q:XMTO?.A XMTO
  1.  I $E(XMTO)=$C(34),$E(XMTO,$L(XMTO))=$C(34) Q XMTO
  1.  ; If we translate blanks to underscores, we have to be careful with
  1.  ; G. and S. names which contain blanks.  ^XMXADDR* looks for G. and
  1.  ; S. names, and it will translate them back, if necessary.
  1.  ; But Austin is running pre-patch 50 v7.1 MailMan code, which will not
  1.  ; translate them back.  So... for G. and S., we will only translate
  1.  ; when sending to non-MailMan sites.
  1.  I XMTO[","!XMTO[" " D
  1.  . I ".G.g.D.d.H.h.S.s."[("."_$E(XMTO,1,2)),XMC("MAILMAN") Q
  1.  . S XMTO=$TR(XMTO,", .","._+")
  1.  ;Allowed punctuation (without quoting rcpt name is .%_-@+!
  1.  I $TR(XMTO,"()<>@,;:\[]"_$C(34),"")=XMTO Q XMTO
  1.  N I,% ; Reformat name for \ and " characters
  1.  F %="\",$C(34) D
  1.  . S I=0
  1.  . F  S I=$F(XMTO,%,I+1) Q:'I  S XMTO=$E(XMTO,1,I-2)_"\"_$E(XMTO,I-1,999)
  1.  Q XMTO
  1. FWDBY(XMFREC) ;
  1.  I $E(XMFREC,1)=" " Q ""
  1.  I $E(XMFREC,1)="<" Q $P(XMFREC,">",1)_">"
  1.  N XMFDUZ
  1.  S XMFDUZ=$P(XMFREC,U,2)
  1.  I +XMFDUZ=XMFDUZ Q "<"_$$NETNAME^XMXUTIL(XMFDUZ)_">"
  1.  Q ""
  1. FINISH(XMINST,XMZ,XMRZ) ;
  1.  D XMTHIST^XMTDR(XMINST,"S",$P($G(^XMB(3.9,XMZ,2,0)),U,4))
  1.  N XMIEN,XMIENS
  1.  S XMIEN=0
  1.  F  S XMIEN=$O(XMRCPT(XMIEN)) Q:'XMIEN  D
  1.  . N XMFDA
  1.  . S XMIENS=XMIEN_","_XMZ_","
  1.  . S XMFDA(3.91,XMIENS,3)=XMRZ   ; remote msg id
  1.  . S XMFDA(3.91,XMIENS,4)=XMCM("START","FM") ; xmit date/time
  1.  . S XMFDA(3.91,XMIENS,5)=$S(XMC("BATCH"):$$EZBLD^DIALOG(39303.6),1:"@")   ; status: In transit
  1.  . S XMFDA(3.91,XMIENS,6)="@"    ; path
  1.  . S XMFDA(3.91,XMIENS,9)=$$TSTAMP^XMXUTIL1-XMCM("START") ; xmit time (seconds)
  1.  . D FILE^DIE("","XMFDA")
  1.  . 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.
  1.  Q
  1.  ; The following have nothing to do with the above.
  1.  ; They are simply here because of an existing DBIA.
  1. STATUS(XMZ,XMRECIP) ; Get Recipient Status
  1.  N XMIEN
  1.  S XMIEN=$$FIND1^DIC(3.91,","_XMZ_",","QX",XMRECIP,"C") Q:'XMIEN ""
  1.  Q $P($G(^XMB(3.9,XMZ,1,XMIEN,0)),U,6)
  1. SRVTIME(XMZ,XMRECIP,XMSTRING) ; Set Recipient Status
  1.  ;Returns 0 for success, 1 for failure
  1.  ;Parameters=(Message#,Recipient,Status)
  1.  I $L(XMSTRING)>30 Q "2 Status too long"
  1.  I XMSTRING[U Q "3 Bad Characters in Status"
  1.  N XMIEN,XMIENS
  1.  S XMIEN=$$FIND1^DIC(3.91,","_XMZ_",","QX",XMRECIP,"C") Q:'XMIEN "1 No Update"
  1.  S XMIENS=XMIEN_","_XMZ_","
  1.  D SETSTAT^XMTDO(XMIENS,XMSTRING)
  1.  Q 0