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

XMS3.m

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