- 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 Jan 18, 2025@03:14:15 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