source: WorldVistAEHR/trunk/r/MAILMAN-XM/XMS3.m@ 862

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
HEADER(XMZ,XMZREC,XMFROM,XMNETNAM) ; RFC 822 - Header Records
 ; 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".VA.GOV"!($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".VA.GOV"!($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