XMS3 ;ISC-SF/GMB-SMTP Send (RFC 822) ;04/15/2003 12:44
;;8.0;MailMan;**18**;Jun 28, 2002
; Entry points (DBIA 10073):
; REC Get the next line of message text
Q
; These records are what you see when you do a "QN" at the prompt:
; "Message Action: Ignore//"
S XMSG="Subject: "_$S($P(XMZREC,U)=$$EZBLD^DIALOG(34012):"",1:$P(XMZREC,U)) X XMSEN Q:ER
S XMSG="Date: "_$$INDT^XMXUTIL1($P(XMZREC,U,3)) X XMSEN Q:ER
S XMSG="Message-ID: <"_$$NETID(XMZ)_">" X XMSEN Q:ER
I $D(^XMB(3.9,XMZ,"IN")) D Q:ER
. N XMINRE
. S XMINRE=^XMB(3.9,XMZ,"IN")
. I $P(XMINRE,"@",1)?.E1".DOMAIN.EXT"!($P(XMINRE,"@",2)?.N) S XMINRE=$P(XMINRE,"@",2)_"@"_$P(XMINRE,"@")
. S XMSG="In-reply-to: <"_XMINRE_">" X XMSEN
I "^Y^y^"[(U_$P(XMZREC,U,5)_U) D Q:ER
. S XMSG="Return-Receipt-To: "_XMFROM X XMSEN
I $D(^XMB(3.9,XMZ,"K")) D Q:ER
. S XMSG="Encrypted: "_$P(XMZREC,U,10)_U_^("K") X XMSEN
I $P(XMZREC,U,4)'="" D Q:ER
. S XMSG="Sender: "_$$FROM^XMS1($P(XMZREC,U,4),XMNETNAM) X XMSEN
S XMSG="From: "_XMFROM X XMSEN Q:ER
I $P(XMZREC,U,6)'="" D Q:ER
. S XMSG="Expiry-Date: "_$$INDT^XMXUTIL1($P(XMZREC,U,6)) X XMSEN
I $P(XMZREC,U,7)["P" D Q:ER
. S XMSG="Importance: high" X XMSEN Q:ER
. S XMSG="X-Priority: 1" X XMSEN
I "^Y^y^"[(U_$P(XMZREC,U,11)_U) D Q:ER
. S XMSG="Sensitivity: Private" X XMSEN
I $D(^XMB(3.9,XMZ,.5)) D Q:ER
. N XMZBSKT
. S XMZBSKT=$P($G(^XMB(3.9,XMZ,.5)),U,1)
. Q:XMZBSKT=""
. S XMSG="X-MM-Basket: "_XMZBSKT X XMSEN
I $P(XMZREC,U,7)'="",$P(XMZREC,U,7)'="P" D Q:ER
. S XMSG="X-MM-Type: "_$P(XMZREC,U,7) X XMSEN
I "^Y^y^"[(U_$P(XMZREC,U,9)_U) D Q:ER
. S XMSG="X-MM-Closed: YES" X XMSEN
I "^Y^y^"[(U_$P(XMZREC,U,12)_U) D Q:ER
. S XMSG="X-MM-Info-Only: YES" X XMSEN
D TOLIST(XMZ,XMNETNAM) Q:ER
Q
NETID(XMZ) ;
N XMCRE8
S XMCRE8=$P($G(^XMB(3.9,XMZ,.6)),U,1)
I 'XMCRE8 D
. S XMCRE8=$P($G(^XMB(3.9,XMZ,0)),U,3)
. I $P(XMCRE8,".")?7N S XMCRE8=$P(XMCRE8,".")
. E D
. . S XMCRE8=$$CONVERT^XMXUTIL1(XMCRE8)
. . I XMCRE8=-1 S XMCRE8=DT
. S $P(^XMB(3.9,XMZ,.6),U,1)=XMCRE8
. S ^XMB(3.9,"C",XMCRE8,XMZ)=""
N XMREMID
I $D(^XMB(3.9,XMZ,5)) D Q:XMREMID'="" XMREMID
. S XMREMID=^XMB(3.9,XMZ,5)
. I $P(XMREMID,"@",1)?.E1".DOMAIN.EXT"!($P(XMREMID,"@",2)?.N) S XMREMID=$P(XMREMID,"@",2)_"@"_$P(XMREMID,"@")
. Q:XMREMID'=""
. D PARSE^XMR3(XMZ,.XMREMID)
;Q XMZ_"@"_^XMB("NETNAME")
Q XMZ_"."_XMCRE8_"@"_^XMB("NETNAME")
TOLIST(XMZ,XMNETNAM) ;
N XMTO,XMIEN
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:""))
F S XMIEN=$O(^XMB(3.9,XMZ,6,XMIEN)) Q:'XMIEN!(XMIEN>50) D Q:ER
. S XMTO=$$TOFORMAT($P(^XMB(3.9,XMZ,6,XMIEN,0),U,1),$S($G(XMC("MAILMAN")):$P(^(0),U,2),1:""))
. S XMSG=XMSG_","
. I $L(XMSG)+$L(XMTO)>80 D TOSEND(.XMSG) Q:ER
. S XMSG=XMSG_" "_XMTO
Q:ER
D TOSEND(.XMSG) Q:ER
I XMIEN>50 S XMSG="(Too many recipients to list...)" D TOSEND(.XMSG) Q:ER
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 $E(XMTO)'=$C(34),(XMTO[",")!(XMTO[" ") D
. I XMTO["," S XMTO=$TR(XMTO,", .","._+")
. I XMTO[" " S XMTO=$C(34)_XMTO_$C(34)
Q XMTO
TOSEND(XMSG) ;
I $L(XMSG)>80 D Q
. N XMSGHOLD,XMPIECES
. S XMPIECES=$L(XMSG,"@")
. S XMSGHOLD=$P(XMSG,"@",XMPIECES)
. S XMSG=$P(XMSG,"@",1,XMPIECES-1)
. X XMSEN
. S XMSG=" @"_XMSGHOLD
X XMSEN
S XMSG=" "
Q
TEXT(XMZ) ; Send body of text
N XMS0AJ
;S XMBLOCK=1 ; *** What's this? See ^XML4CRC* & ^XMLSWP*
S XMS0AJ=0
F S XMS0AJ=$O(^XMB(3.9,XMZ,2,XMS0AJ)) Q:XMS0AJ'>0 D Q:ER
. S XMSG=^XMB(3.9,XMZ,2,XMS0AJ,0)
. I $E(XMSG)="." S XMSG="."_XMSG
. E I $E(XMSG,1,4)="~*~^" S XMSG=" "_XMSG ; *** What's this?
. X XMSEN
I ER S ER("MSG")="Error sending msg "_XMZ_", text line "_XMS0AJ Q
;D:$D(XMBLOCK) KILL^XML4CRC
Q
RCPTERR(XMERRMSG,XMZ,XMZREC,XMNVFROM,XMRCPTO,XMRCPT,XMIEN) ; Non-delivery to recipient
N XMFDA,XMIENS,XMTO,XMPARM,XMINSTR
S XMIENS=XMIEN_","_XMZ_","
S XMFDA(3.91,XMIENS,3)="@" ; remote msg id
S XMFDA(3.91,XMIENS,4)=XMCM("START","FM") ; xmit date/time
S XMFDA(3.91,XMIENS,5)=$E($P(XMERRMSG," ",2,999),1,30) ; status
S XMFDA(3.91,XMIENS,6)="@" ; path
D FILE^DIE("","XMFDA")
S XMTO=$$SENDER(XMZ,XMZREC,XMNVFROM,XMIEN,1,XMERRMSG) Q:"<>"[XMTO
S XMINSTR("FROM")="POSTMASTER"
S XMPARM(1)=$P(XMZREC,U,1) ; subject
S XMPARM(2)=XMRCPTO
S XMPARM(3)=XMERRMSG
S XMPARM(4)=XMRCPT
S XMPARM(5)=$S(XMTO["@":$G(^XMB(3.9,XMZ,5)),1:XMZ)
D TASKBULL^XMXBULL(.5,"XM SEND ERR RECIPIENT",.XMPARM,"",XMTO,.XMINSTR)
Q
MSGERR(XMSITE,XMINST,XMERRMSG,XMZ,XMZREC,XMNVFROM,XMRCPT) ;
; If a message is rejected at a site for any reason (the whole message,
; not just one recipient), then this message may be sent.
N XMTO,XMPARM,XMIEN,XMNAME,XMCNT,XMINSTR
D DOTRAN^XMC1(XMERRMSG)
S XMPARM(3)=XMERRMSG
S XMERRMSG=$E($P(XMERRMSG," ",2,999),1,30)
K ^TMP("XM",$J,"REJECT")
S XMIEN=""
F S XMIEN=$S($D(XMRCPT):$O(XMRCPT(XMIEN)),1:$O(^XMB(3.9,XMZ,1,"AQUEUE",XMINST,XMIEN))) Q:XMIEN="" D
. N XMFDA,XMIENS
. S XMIENS=XMIEN_","_XMZ_","
. S XMFDA(3.91,XMIENS,3)="@" ; remote msg id
. S XMFDA(3.91,XMIENS,4)=XMCM("START","FM") ; xmit date/time
. S XMFDA(3.91,XMIENS,5)=XMERRMSG ; status
. S XMFDA(3.91,XMIENS,6)="@" ; path
. S XMFDA(3.91,XMIENS,9)="@" ; xmit time
. D FILE^DIE("","XMFDA")
. S XMNAME=$P($G(^XMB(3.9,XMZ,1,XMIEN,0)),U,1) Q:XMNAME=""
. S XMTO=$$SENDER(XMZ,XMZREC,XMNVFROM,XMIEN) Q:"<>"[XMTO
. S (XMCNT,^(XMTO))=$G(^TMP("XM",$J,"REJECT",XMTO))+1
. S ^TMP("XM",$J,"REJECT",XMTO,XMCNT)=XMNAME
S XMINSTR("FROM")="POSTMASTER"
S XMPARM(1)=$P(XMZREC,U,1) ; subject
S XMPARM(2)=XMSITE
S XMTO=""
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)
K ^TMP("XM",$J,"REJECT")
Q
SENDER(XMZ,XMZREC,XMNVFROM,XMIEN,XMDELFWD,XMERRMSG) ; Function returns 'to whom to send error message'
N XMFWDREC,XMFWDR
S XMFWDREC=$G(^XMB(3.9,XMZ,1,XMIEN,"F")) ; Try to find forwarder
S XMFWDR=$P(XMFWDREC,U,2)
I XMFWDR'="" D Q XMFWDR ; Forwarder is local
. I $G(XMDELFWD) D DELFWD(XMZ,XMIEN,XMFWDR,XMERRMSG)
I $E(XMFWDREC)="<" Q $E($P($P(XMFWDREC,U,1),">",1),2,999) ; Forwarder is remote
Q:$D(^XMB(3.9,XMZ,.7)) XMNVFROM ; Sender is remote
N XMFROM
S XMFROM=$P(XMZREC,U,2)
I +XMFROM=XMFROM Q XMFROM ; Sender is local
I XMFROM'["@" Q .5 ; Sender is fictitious, so notify postmaster
Q XMNVFROM ; Sender is remote
DELFWD(XMZ,XMIEN,XMFWDR,XMERRMSG) ; Delete user's forwarding address
Q:+XMFWDR'=XMFWDR
N XMFWD
S XMFWD=$P(^XMB(3.7,XMFWDR,0),U,2) Q:XMFWD=""
N XMINSTR,XMADDR,XMFULL,XMERROR,XMFDA,XMTXT,XMFWDADD
S XMINSTR("ADDR FLAGS")="X" ; do not create ^TMP(, just check.
S XMADDR=$P(^XMB(3.9,XMZ,1,XMIEN,0),U,1)
D ADDRESS^XMXADDR(DUZ,XMFWD,.XMFULL,.XMERROR)
I '$D(XMERROR),XMADDR'=$G(XMFULL) Q
D DELFWD^XMVVITA(XMFWDR,XMFWD,XMERRMSG)
Q
; The following has nothing to do with the above.
; These are used by the SERVER Communications Protocol in file 3.4.
REC ; Read the next line of text from the message. When called for the
; first time, returns the first line.
; In:
; XMZ - IEN of the message in file 3.9
; XMPOS - (optional) line number of the previous line read
; Default is .999999
; Out:
; XMPOS - line number of XMRG
; XMRG - =the next line of text, if OK; ="" if end of text reached
; XMER - =0 if OK; =-1 if end of text reached
S XMPOS=$S('$D(XMPOS):.999999,XMPOS<.999999:.999999,1:XMPOS)
S XMPOS=$O(^XMB(3.9,XMZ,2,XMPOS))
I +XMPOS'=XMPOS S XMER=-1,XMRG="" Q
S XMRG=^XMB(3.9,XMZ,2,XMPOS,0),XMER=0
Q
SEN ; Send a line to the return message
S XMSLINE=XMSLINE+1,^XMB(3.9,XMZ,2,XMSLINE,0)=XMSG
Q
OPEN ; Open the reverse message path
Q
CLOSE ; Close the reverse message
S ^XMB(3.9,XMZ,2,0)="^3.92A^"_XMSLINE_U_XMSLINE_U_DT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMS3 8125 printed Apr 09, 2024@21:15:24 Page 2
XMS3 ;ISC-SF/GMB-SMTP Send (RFC 822) ;04/15/2003 12:44
+1 ;;8.0;MailMan;**18**;Jun 28, 2002
+2 ; Entry points (DBIA 10073):
+3 ; REC Get the next line of message text
+4 QUIT
+1 ; These records are what you see when you do a "QN" at the prompt:
+2 ; "Message Action: Ignore//"
+3 SET XMSG="Subject: "_$SELECT($PIECE(XMZREC,U)=$$EZBLD^DIALOG(34012):"",1:$PIECE(XMZREC,U))
XECUTE XMSEN
if ER
QUIT
+4 SET XMSG="Date: "_$$INDT^XMXUTIL1($PIECE(XMZREC,U,3))
XECUTE XMSEN
if ER
QUIT
+5 SET XMSG="Message-ID: <"_$$NETID(XMZ)_">"
XECUTE XMSEN
if ER
QUIT
+6 IF $DATA(^XMB(3.9,XMZ,"IN"))
Begin DoDot:1
+7 NEW XMINRE
+8 SET XMINRE=^XMB(3.9,XMZ,"IN")
+9 IF $PIECE(XMINRE,"@",1)?.E1".DOMAIN.EXT"!($PIECE(XMINRE,"@",2)?.N)
SET XMINRE=$PIECE(XMINRE,"@",2)_"@"_$PIECE(XMINRE,"@")
+10 SET XMSG="In-reply-to: <"_XMINRE_">"
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+11 IF "^Y^y^"[(U_$PIECE(XMZREC,U,5)_U)
Begin DoDot:1
+12 SET XMSG="Return-Receipt-To: "_XMFROM
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+13 IF $DATA(^XMB(3.9,XMZ,"K"))
Begin DoDot:1
+14 SET XMSG="Encrypted: "_$PIECE(XMZREC,U,10)_U_^("K")
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+15 IF $PIECE(XMZREC,U,4)'=""
Begin DoDot:1
+16 SET XMSG="Sender: "_$$FROM^XMS1($PIECE(XMZREC,U,4),XMNETNAM)
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+17 SET XMSG="From: "_XMFROM
XECUTE XMSEN
if ER
QUIT
+18 IF $PIECE(XMZREC,U,6)'=""
Begin DoDot:1
+19 SET XMSG="Expiry-Date: "_$$INDT^XMXUTIL1($PIECE(XMZREC,U,6))
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+20 IF $PIECE(XMZREC,U,7)["P"
Begin DoDot:1
+21 SET XMSG="Importance: high"
XECUTE XMSEN
if ER
QUIT
+22 SET XMSG="X-Priority: 1"
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+23 IF "^Y^y^"[(U_$PIECE(XMZREC,U,11)_U)
Begin DoDot:1
+24 SET XMSG="Sensitivity: Private"
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+25 IF $DATA(^XMB(3.9,XMZ,.5))
Begin DoDot:1
+26 NEW XMZBSKT
+27 SET XMZBSKT=$PIECE($GET(^XMB(3.9,XMZ,.5)),U,1)
+28 if XMZBSKT=""
QUIT
+29 SET XMSG="X-MM-Basket: "_XMZBSKT
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+30 IF $PIECE(XMZREC,U,7)'=""
IF $PIECE(XMZREC,U,7)'="P"
Begin DoDot:1
+31 SET XMSG="X-MM-Type: "_$PIECE(XMZREC,U,7)
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+32 IF "^Y^y^"[(U_$PIECE(XMZREC,U,9)_U)
Begin DoDot:1
+33 SET XMSG="X-MM-Closed: YES"
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+34 IF "^Y^y^"[(U_$PIECE(XMZREC,U,12)_U)
Begin DoDot:1
+35 SET XMSG="X-MM-Info-Only: YES"
XECUTE XMSEN
End DoDot:1
if ER
QUIT
+36 DO TOLIST(XMZ,XMNETNAM)
if ER
QUIT
+37 QUIT
NETID(XMZ) ;
+1 NEW XMCRE8
+2 SET XMCRE8=$PIECE($GET(^XMB(3.9,XMZ,.6)),U,1)
+3 IF 'XMCRE8
Begin DoDot:1
+4 SET XMCRE8=$PIECE($GET(^XMB(3.9,XMZ,0)),U,3)
+5 IF $PIECE(XMCRE8,".")?7N
SET XMCRE8=$PIECE(XMCRE8,".")
+6 IF '$TEST
Begin DoDot:2
+7 SET XMCRE8=$$CONVERT^XMXUTIL1(XMCRE8)
+8 IF XMCRE8=-1
SET XMCRE8=DT
End DoDot:2
+9 SET $PIECE(^XMB(3.9,XMZ,.6),U,1)=XMCRE8
+10 SET ^XMB(3.9,"C",XMCRE8,XMZ)=""
End DoDot:1
+11 NEW XMREMID
+12 IF $DATA(^XMB(3.9,XMZ,5))
Begin DoDot:1
+13 SET XMREMID=^XMB(3.9,XMZ,5)
+14 IF $PIECE(XMREMID,"@",1)?.E1".DOMAIN.EXT"!($PIECE(XMREMID,"@",2)?.N)
SET XMREMID=$PIECE(XMREMID,"@",2)_"@"_$PIECE(XMREMID,"@")
+15 if XMREMID'=""
QUIT
+16 DO PARSE^XMR3(XMZ,.XMREMID)
End DoDot:1
if XMREMID'=""
QUIT XMREMID
+17 ;Q XMZ_"@"_^XMB("NETNAME")
+18 QUIT XMZ_"."_XMCRE8_"@"_^XMB("NETNAME")
TOLIST(XMZ,XMNETNAM) ;
+1 NEW XMTO,XMIEN
+2 SET XMIEN=$ORDER(^XMB(3.9,XMZ,6,0))
SET XMSG="To: "_$$TOFORMAT($PIECE(^XMB(3.9,XMZ,6,XMIEN,0),U,1),$SELECT($GET(XMC("MAILMAN")):$PIECE(^(0),U,2),1:""))
+3 FOR
SET XMIEN=$ORDER(^XMB(3.9,XMZ,6,XMIEN))
if 'XMIEN!(XMIEN>50)
QUIT
Begin DoDot:1
+4 SET XMTO=$$TOFORMAT($PIECE(^XMB(3.9,XMZ,6,XMIEN,0),U,1),$SELECT($GET(XMC("MAILMAN")):$PIECE(^(0),U,2),1:""))
+5 SET XMSG=XMSG_","
+6 IF $LENGTH(XMSG)+$LENGTH(XMTO)>80
DO TOSEND(.XMSG)
if ER
QUIT
+7 SET XMSG=XMSG_" "_XMTO
End DoDot:1
if ER
QUIT
+8 if ER
QUIT
+9 DO TOSEND(.XMSG)
if ER
QUIT
+10 IF XMIEN>50
SET XMSG="(Too many recipients to list...)"
DO TOSEND(.XMSG)
if ER
QUIT
+11 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 $EXTRACT(XMTO)'=$CHAR(34)
IF (XMTO[",")!(XMTO[" ")
Begin DoDot:1
+2 IF XMTO[","
SET XMTO=$TRANSLATE(XMTO,", .","._+")
+3 IF XMTO[" "
SET XMTO=$CHAR(34)_XMTO_$CHAR(34)
End DoDot:1
+4 QUIT XMTO
TOSEND(XMSG) ;
+1 IF $LENGTH(XMSG)>80
Begin DoDot:1
+2 NEW XMSGHOLD,XMPIECES
+3 SET XMPIECES=$LENGTH(XMSG,"@")
+4 SET XMSGHOLD=$PIECE(XMSG,"@",XMPIECES)
+5 SET XMSG=$PIECE(XMSG,"@",1,XMPIECES-1)
+6 XECUTE XMSEN
+7 SET XMSG=" @"_XMSGHOLD
End DoDot:1
QUIT
+8 XECUTE XMSEN
+9 SET XMSG=" "
+10 QUIT
TEXT(XMZ) ; Send body of text
+1 NEW XMS0AJ
+2 ;S XMBLOCK=1 ; *** What's this? See ^XML4CRC* & ^XMLSWP*
+3 SET XMS0AJ=0
+4 FOR
SET XMS0AJ=$ORDER(^XMB(3.9,XMZ,2,XMS0AJ))
if XMS0AJ'>0
QUIT
Begin DoDot:1
+5 SET XMSG=^XMB(3.9,XMZ,2,XMS0AJ,0)
+6 IF $EXTRACT(XMSG)="."
SET XMSG="."_XMSG
+7 ; *** What's this?
IF '$TEST
IF $EXTRACT(XMSG,1,4)="~*~^"
SET XMSG=" "_XMSG
+8 XECUTE XMSEN
End DoDot:1
if ER
QUIT
+9 IF ER
SET ER("MSG")="Error sending msg "_XMZ_", text line "_XMS0AJ
QUIT
+10 ;D:$D(XMBLOCK) KILL^XML4CRC
+11 QUIT
RCPTERR(XMERRMSG,XMZ,XMZREC,XMNVFROM,XMRCPTO,XMRCPT,XMIEN) ; Non-delivery to recipient
+1 NEW XMFDA,XMIENS,XMTO,XMPARM,XMINSTR
+2 SET XMIENS=XMIEN_","_XMZ_","
+3 ; remote msg id
SET XMFDA(3.91,XMIENS,3)="@"
+4 ; xmit date/time
SET XMFDA(3.91,XMIENS,4)=XMCM("START","FM")
+5 ; status
SET XMFDA(3.91,XMIENS,5)=$EXTRACT($PIECE(XMERRMSG," ",2,999),1,30)
+6 ; path
SET XMFDA(3.91,XMIENS,6)="@"
+7 DO FILE^DIE("","XMFDA")
+8 SET XMTO=$$SENDER(XMZ,XMZREC,XMNVFROM,XMIEN,1,XMERRMSG)
if "<>"[XMTO
QUIT
+9 SET XMINSTR("FROM")="POSTMASTER"
+10 ; subject
SET XMPARM(1)=$PIECE(XMZREC,U,1)
+11 SET XMPARM(2)=XMRCPTO
+12 SET XMPARM(3)=XMERRMSG
+13 SET XMPARM(4)=XMRCPT
+14 SET XMPARM(5)=$SELECT(XMTO["@":$GET(^XMB(3.9,XMZ,5)),1:XMZ)
+15 DO TASKBULL^XMXBULL(.5,"XM SEND ERR RECIPIENT",.XMPARM,"",XMTO,.XMINSTR)
+16 QUIT
MSGERR(XMSITE,XMINST,XMERRMSG,XMZ,XMZREC,XMNVFROM,XMRCPT) ;
+1 ; If a message is rejected at a site for any reason (the whole message,
+2 ; not just one recipient), then this message may be sent.
+3 NEW XMTO,XMPARM,XMIEN,XMNAME,XMCNT,XMINSTR
+4 DO DOTRAN^XMC1(XMERRMSG)
+5 SET XMPARM(3)=XMERRMSG
+6 SET XMERRMSG=$EXTRACT($PIECE(XMERRMSG," ",2,999),1,30)
+7 KILL ^TMP("XM",$JOB,"REJECT")
+8 SET XMIEN=""
+9 FOR
SET XMIEN=$SELECT($DATA(XMRCPT):$ORDER(XMRCPT(XMIEN)),1:$ORDER(^XMB(3.9,XMZ,1,"AQUEUE",XMINST,XMIEN)))
if XMIEN=""
QUIT
Begin DoDot:1
+10 NEW XMFDA,XMIENS
+11 SET XMIENS=XMIEN_","_XMZ_","
+12 ; remote msg id
SET XMFDA(3.91,XMIENS,3)="@"
+13 ; xmit date/time
SET XMFDA(3.91,XMIENS,4)=XMCM("START","FM")
+14 ; status
SET XMFDA(3.91,XMIENS,5)=XMERRMSG
+15 ; path
SET XMFDA(3.91,XMIENS,6)="@"
+16 ; xmit time
SET XMFDA(3.91,XMIENS,9)="@"
+17 DO FILE^DIE("","XMFDA")
+18 SET XMNAME=$PIECE($GET(^XMB(3.9,XMZ,1,XMIEN,0)),U,1)
if XMNAME=""
QUIT
+19 SET XMTO=$$SENDER(XMZ,XMZREC,XMNVFROM,XMIEN)
if "<>"[XMTO
QUIT
+20 SET (XMCNT,^(XMTO))=$GET(^TMP("XM",$JOB,"REJECT",XMTO))+1
+21 SET ^TMP("XM",$JOB,"REJECT",XMTO,XMCNT)=XMNAME
End DoDot:1
+22 SET XMINSTR("FROM")="POSTMASTER"
+23 ; subject
SET XMPARM(1)=$PIECE(XMZREC,U,1)
+24 SET XMPARM(2)=XMSITE
+25 SET XMTO=""
+26 FOR
SET XMTO=$ORDER(^TMP("XM",$JOB,"REJECT",XMTO))
if XMTO=""
QUIT
DO TASKBULL^XMXBULL(.5,"XM SEND ERR MSG",.XMPARM,"^TMP(""XM"",$J,""REJECT"",XMTO)",XMTO,.XMINSTR)
+27 KILL ^TMP("XM",$JOB,"REJECT")
+28 QUIT
SENDER(XMZ,XMZREC,XMNVFROM,XMIEN,XMDELFWD,XMERRMSG) ; Function returns 'to whom to send error message'
+1 NEW XMFWDREC,XMFWDR
+2 ; Try to find forwarder
SET XMFWDREC=$GET(^XMB(3.9,XMZ,1,XMIEN,"F"))
+3 SET XMFWDR=$PIECE(XMFWDREC,U,2)
+4 ; Forwarder is local
IF XMFWDR'=""
Begin DoDot:1
+5 IF $GET(XMDELFWD)
DO DELFWD(XMZ,XMIEN,XMFWDR,XMERRMSG)
End DoDot:1
QUIT XMFWDR
+6 ; Forwarder is remote
IF $EXTRACT(XMFWDREC)="<"
QUIT $EXTRACT($PIECE($PIECE(XMFWDREC,U,1),">",1),2,999)
+7 ; Sender is remote
if $DATA(^XMB(3.9,XMZ,.7))
QUIT XMNVFROM
+8 NEW XMFROM
+9 SET XMFROM=$PIECE(XMZREC,U,2)
+10 ; Sender is local
IF +XMFROM=XMFROM
QUIT XMFROM
+11 ; Sender is fictitious, so notify postmaster
IF XMFROM'["@"
QUIT .5
+12 ; Sender is remote
QUIT XMNVFROM
DELFWD(XMZ,XMIEN,XMFWDR,XMERRMSG) ; Delete user's forwarding address
+1 if +XMFWDR'=XMFWDR
QUIT
+2 NEW XMFWD
+3 SET XMFWD=$PIECE(^XMB(3.7,XMFWDR,0),U,2)
if XMFWD=""
QUIT
+4 NEW XMINSTR,XMADDR,XMFULL,XMERROR,XMFDA,XMTXT,XMFWDADD
+5 ; do not create ^TMP(, just check.
SET XMINSTR("ADDR FLAGS")="X"
+6 SET XMADDR=$PIECE(^XMB(3.9,XMZ,1,XMIEN,0),U,1)
+7 DO ADDRESS^XMXADDR(DUZ,XMFWD,.XMFULL,.XMERROR)
+8 IF '$DATA(XMERROR)
IF XMADDR'=$GET(XMFULL)
QUIT
+9 DO DELFWD^XMVVITA(XMFWDR,XMFWD,XMERRMSG)
+10 QUIT
+11 ; The following has nothing to do with the above.
+12 ; These are used by the SERVER Communications Protocol in file 3.4.
REC ; Read the next line of text from the message. When called for the
+1 ; first time, returns the first line.
+2 ; In:
+3 ; XMZ - IEN of the message in file 3.9
+4 ; XMPOS - (optional) line number of the previous line read
+5 ; Default is .999999
+6 ; Out:
+7 ; XMPOS - line number of XMRG
+8 ; XMRG - =the next line of text, if OK; ="" if end of text reached
+9 ; XMER - =0 if OK; =-1 if end of text reached
+10 SET XMPOS=$SELECT('$DATA(XMPOS):.999999,XMPOS<.999999:.999999,1:XMPOS)
+11 SET XMPOS=$ORDER(^XMB(3.9,XMZ,2,XMPOS))
+12 IF +XMPOS'=XMPOS
SET XMER=-1
SET XMRG=""
QUIT
+13 SET XMRG=^XMB(3.9,XMZ,2,XMPOS,0)
SET XMER=0
+14 QUIT
SEN ; Send a line to the return message
+1 SET XMSLINE=XMSLINE+1
SET ^XMB(3.9,XMZ,2,XMSLINE,0)=XMSG
+2 QUIT
OPEN ; Open the reverse message path
+1 QUIT
CLOSE ; Close the reverse message
+1 SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_XMSLINE_U_XMSLINE_U_DT
+2 QUIT
