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