XMR3 ;ISC-SF/GMB-SMTP Receiver (RFC 822) ;07/01/2002 14:11
;;8.0;MailMan;;Jun 28, 2002
DATA ; TEXT / ASSUMES VALID RECIPIENT
; Incoming Variables:
; XMINSTR("FWD BY")=""
; XMZ message number of new message
; XMZFDA FM FDA for new message
; XMZIENS IENS for new message
; $D(XMC("DX")) means Test mode: Messages will not be delivered
; If the msg is from a VA site, the following may be set:
; XMREMID always set if the msg is from a VA site
; $G(XMRXMZ) message number of message we already have.
; Set if new message is a duplicate of one we already have.
N XMLIN,XMINCR,XMHDR,XMREJECT,XMSUBJ,XMFROM,XMDATE,XMENCR,XMZO,XMSENDER,XMREPLTO
D GETDATA Q:ER
I '$G(XMRXMZ),'$D(XMC("DX")) D HDRPROC Q:ER
I '$G(XMREJECT),'$D(XMC("DX")) D SET
S XMSTATE="^HELO^MAIL^"
K ^TMP("XMY",$J),^TMP("XMY0",$J)
D ZAPIT^XMXMSGS2(.5,.95,XMZ)
I '$G(XMREJECT) D
. S XMSG="250 'data' accepted" X XMSEN
. D XMTHIST^XMTDR(XMINST,"R",$P($G(^XMB(3.9,XMZ,2,0)),U,4))
K XMNVFROM,XMINSTR,XMREMID,XMRXMZ,XMZ,XMZIENS,XMZFDA
Q
GETDATA ;
N XMH
S XMSG="354 Enter data" X XMSEN Q:ER
S XMLIN=.001,XMINCR=.001,XMH=""
F X XMREC Q:ER Q:XMRG="." D
. I $E(XMRG)="." S XMRG=$E(XMRG,2,999)
. S XMLIN=XMLIN+XMINCR
. S ^XMB(3.9,XMZ,2,XMLIN,0)=XMRG
. Q:XMINCR=1
. I XMRG="" S XMINCR=1,XMLIN=0 Q
. I XMLIN=.99 S XMINCR=.000001
. I $E(XMRG,1)=" "!($E(XMRG,1)=$C(9)) Q:XMH="" D NEXT(XMH,.XMHDR,XMRG) Q
. ;I $E(XMRG,1)=" " Q:XMH="" D NEXT(XMH,.XMHDR,XMRG)
. S XMH=$$UP^XLFSTR($P(XMRG,":"))
. I "^DATE^FROM^IMPORTANCE^IN-REPLY-TO^MESSAGE-ID^SUBJECT^"[(U_XMH_U) S XMH=$E($TR(XMH,"-"),1,4),XMHDR(XMH)=$$SCRUB($P(XMRG,":",2,99)) Q
. I "^ENCRYPTED^EXPIRY-DATE^REFERENCES^REPLY-TO^RETURN-RECEIPT-TO^SENDER^SENSITIVITY^"[(U_XMH_U) S XMH=$E($TR(XMH,"-"),1,4),XMHDR(XMH)=$$SCRUB($P(XMRG,":",2,99)) Q
. I "^X-PRIORITY^"[(U_XMH_U) S XMH=$E($P(XMH,"-",2),1,4),XMHDR(XMH)=$$SCRUB($P(XMRG,":",2,99)) Q
. I "^X-MM-BASKET^X-MM-CLOSED^X-MM-INFO-ONLY^X-MM-TYPE^"[(U_XMH_U) S XMH=$E($P(XMH,"-",3),1,4),XMHDR(XMH)=$$SCRUB($P(XMRG,":",2,99)) Q
. S XMH=""
Q:ER
Q
NEXT(XMH,XMHDR,XMDATA) ;
N I
S XMDATA=$$SCRUB(XMDATA) Q:XMDATA=""
I XMHDR(XMH)="" S XMHDR(XMH)=XMDATA Q
I $L(XMHDR(XMH))+$L(XMDATA)<255 S XMHDR(XMH)=XMHDR(XMH)_" "_XMDATA Q
S I=$O(^XMHDR(XMH,":"),-1)+1
I $G(XMHDR(XMH,I))'="",$L(XMHDR(XMH,I))+$L(XMDATA)<255 S XMHDR(XMH,I)=$G(XMHDR(XMH,I))_" "_XMDATA Q
S XMHDR(XMH,I+1)=XMDATA
Q
HDRPROC ; Process header commands
N XMH,XMP,XMRINFO
I XMLIN,$O(^XMB(3.9,XMZ,2,XMLIN)) D Q
. S XMREJECT=1
. S XMSG="500 Synchronization Lost. Msg rejected." X XMSEN
. D KILLIT^XMR3A
;I '$D(XMHDR("FROM")) D Q
;. S XMREJECT=1
;. S XMSG="501 Missing FROM Header. Msg rejected." X XMSEN
;. D KILLIT^XMR3A
I $$TOOLONG D Q
. S XMREJECT=1
. S XMSG="551 Too many lines. Msg rejected." X XMSEN
. D KILLIT^XMR3A
I '$D(XMREMID) S XMREMID=""
S (XMH,XMZO,XMFROM,XMENCR,XMSENDER,XMDATE,XMSUBJ)=""
F S XMH=$O(XMHDR(XMH)) Q:XMH="" D
. S XMP=XMHDR(XMH)
. D @XMH
I '$O(^XMB(3.9,XMZ,2,.999999)),'$D(XMZFDA(3.9,XMZIENS,.01)) D Q
. S XMSG="552 No subject or text. Msg rejected." X XMSEN
. D KILLIT^XMR3A
. S XMREJECT=1
I $G(XMRINFO) D Q
. S XMSG="555 Reply to 'Info Only'. Msg rejected." X XMSEN
. D KILLIT^XMR3A
. S XMREJECT=1
;I $G(XMZFDA(3.9,XMZIENS,9))="" D Q
;. S XMSG="501 No MESSAGE-ID. Msg rejected." X XMSEN
;. D KILLIT^XMR3A
;. S XMREJECT=1
;I '$O(^XMB(3.9,XMZ,2,.999999)) S ^XMB(3.9,XMZ,2,1,0)=" "
S ^XMB(3.9,XMZ,2,0)="^^"_XMLIN_U_XMLIN
Q
TOOLONG() ;
N XMLIMIT
S XMLIMIT=$P($G(^XMB(1,1,"NETWORK-LIMIT")),U,2)
Q:'XMLIMIT 0
Q:$G(XM2LONG) 1
Q:XMLIN'>XMLIMIT 0
I $G(XMHDR("TYPE"))["X"!($G(XMHDR("TYPE"))["K") Q 0
Q 1
SCRUB(X) ; Strip ctrl chars and leading/trailing blanks
S:X?.E1C.E X=$$CTRL^XMXUTIL1(X)
S:$E(X,1)=" "!($E(X,$L(X))=" ") X=$$STRIP^XMXUTIL1(X)
Q X
BASK ; "X-MM-BASKET:" (Delivery Basket)
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,21)=XMP
Q
CLOS ; "X-MM-CLOSED:YES"
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,1.95)="y"
Q
DATE ; "DATE:"
S XMDATE=XMP
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,1.4)=XMDATE
Q
ENCR ; "ENCRYPT:"
S XMENCR=XMP
Q:'$D(XMZIENS)
S XMZFDA(3.9,XMZIENS,1.8)=$P(XMENCR,U,1) ; scramble hint
S XMZFDA(3.9,XMZIENS,1.85)=$P(XMENCR,U,2,999) ; scramble key
Q
EXPI ; "EXPIRY-DATE:" (vaporize date)
N XMVAPOR
S XMVAPOR=$$CONVERT^XMXUTIL1(XMP,1) Q:XMVAPOR=-1
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,1.6)=XMVAPOR
Q
FROM ; "FROM:"
S XMFROM=XMP
Q:'$D(XMZIENS)
;I $D(XMHDR("FROM",1)) D CONTINU(.XMFROM,"FROM",.XMHDR)
S XMZFDA(3.9,XMZIENS,1)=XMFROM
Q
CONTINU(XMVBL,XMH,XMHDR) ;
N I
S I=0
F S I=$O(XMHDR(XMH,I)) Q:'I S XMVBL=XMVBL_" "_XMHDR(XMH,I)
Q
IMPO ; "IMPORTANCE:HIGH" (Priority)
I $$UP^XLFSTR(XMP)'="HIGH"!'$D(XMZIENS) Q
S:$G(XMZFDA(3.9,XMZIENS,1.7))'["P" XMZFDA(3.9,XMZIENS,1.7)=$G(XMZFDA(3.9,XMZIENS,1.7))_"P"
Q
INFO ; "X-MM-INFO-ONLY:YES"
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,1.97)="y"
Q
REFE ; "REFERENCES:" (used by some systems, instead of 'in-reply-to')
Q
INRE ; "IN-REPLY-TO:" message at this site
N I,XMLOCID,XMREC
S XMLOCID=$$REMID(XMP)
S XMZO=$$LOCALXMZ^XMR3A(XMLOCID)
Q:'XMZO
I $P(XMZO,U,3)'="E" S XMZO="" Q
S XMZO=+XMZO
S XMREC=$G(^XMB(3.9,XMZO,0))
I $P(XMREC,U,8) D ; If reply to a reply, get original msg #
. S XMZO=$P(XMREC,U,8)
. S XMREC=$G(^XMB(3.9,XMZO,0))
I XMREC="" S XMZO="" Q ; Original message not found, so make this reply a message.
I "^y^Y^"[(U_$P(XMREC,U,12)_U) S XMRINFO=1 Q ; Reply to 'info only' msg
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,1.35)=XMZO ; Point from response to original msg
Q
REMID(X) ;
Q:X["<" $TR($P(X,">",1),"<")
; I've seen some like this: "<<...>>"
; I've seen some like this: "<...> comment here"
Q X
MESS ; "MESSAGE-ID:" at site where message originated
S XMREMID=$$REMID(XMP)
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,9)=XMREMID
Q
PRIO ; "X-PRIORITY:1" (Priority)
I $$UP^XLFSTR(XMP)'=1!'$D(XMZIENS) Q
S:$G(XMZFDA(3.9,XMZIENS,1.7))'["P" XMZFDA(3.9,XMZIENS,1.7)=$G(XMZFDA(3.9,XMZIENS,1.7))_"P"
Q
REPL ; "REPLY-TO:"
S XMREPLTO=XMP
;I $D(XMHDR("REPL",1)) D CONTINU(.XMREPLTO,"REPL",.XMHDR)
Q
RETU ; "RETURN-RECEIPT-TO:"
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,1.3)="y"
Q
SEND ; "SENDER:" (Surrogate)
S XMSENDER=XMP
;I $D(XMHDR("SEND",1)) D CONTINU(.XMSENDER,"SEND",.XMHDR)
Q:XMSENDER=$G(XMFROM)
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,1.1)=XMSENDER
Q
SENS ; "SENSITIVITY:PERSONAL" (Confidential)
Q:"^PERSONAL^PRIVATE^COMPANY-CONFIDENTIAL^"'[(U_$$UP^XLFSTR(XMP)_U)
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,1.96)="y"
Q
SUBJ ; "SUBJECT:"
S XMSUBJ=XMP
I XMSUBJ[" " S XMSUBJ=$$MAXBLANK^XMXUTIL1(XMSUBJ)
I XMSUBJ["^" S XMSUBJ=$$ENCODEUP^XMXUTIL1(XMSUBJ)
S XMSUBJ=$E(XMSUBJ,1,65)
Q:XMSUBJ=""!'$D(XMZIENS)
I $L(XMSUBJ)<3 S XMSUBJ="..."
S XMZFDA(3.9,XMZIENS,.01)=XMSUBJ
Q
TYPE ; "X-MM-TYPE:"
S:$D(XMZIENS) XMZFDA(3.9,XMZIENS,1.7)=XMP
Q
SET ; Set data into message file
I $G(XMREMID)'="" D CHEKDUP^XMR3A Q:$G(XMREJECT)
I $D(XMZFDA) D
. I $D(XMZFDA(3.9,XMZIENS,1.1)),$L(XMZFDA(3.9,XMZIENS,1))+$L(XMZFDA(3.9,XMZIENS,1.1))>130 S XMZFDA(3.9,XMZIENS,1.1)=$E($$REMADDR^XMXADDR3(XMZFDA(3.9,XMZIENS,1.1)),1,64)
. I $L(XMZFDA(3.9,XMZIENS,1))>100 S XMZFDA(3.9,XMZIENS,1)="<"_$$REMADDR^XMXADDR3(XMZFDA(3.9,XMZIENS,1))_">"
. D FILE^DIE("","XMZFDA")
;SENDER only RCPT / REMOTE sender drops thru (local>0=pointer)
I $G(XMZO) D Q:$O(^TMP("XMY",$J,"")) ; I don't understand this.
. D DOTRAN^XMC1(42315,XMZ,XMZO) ;> Putting response |1| into message |2|
. D DOTRAN^XMC1(42316,XMZO) ;> Delivering message |1|
. D RPOST^XMKP("NR",XMZO,XMZ)
D FWD^XMKP(.5,XMZ,.XMINSTR)
D CHECK^XMKPL
Q
PARSE(XMZ,XMREMID,XMSUBJ,XMFROM,XMDATE,XMSENDER,XMENCR,XMZO) ; Get data for remotely originated message
; This is used by ^XMRENT & ^XMS3
; XMSUBJ subject
; XMFROM from
; XMDATE date
; XMENCR scramble hint "^" scramble key
; XMREMID message id at site where msg originated (not necessarily at the sending site)
; XMZO original message xmz (to which this msg is a response)
N XMP,XMH,XMHDR,XMRINFO,XMZFDA,XMZIENS,XMFIND
; Don't add anything to this list:
S XMFIND="^DATE^ENCRYPTED^FROM^IN-REPLY-TO^MESSAGE-ID^SENDER^SUBJECT^"
D HDRFIND(XMZ,XMFIND,.XMHDR)
S XMH=""
F S XMH=$O(XMHDR(XMH)) Q:XMH="" D
. S XMP=XMHDR(XMH)
. D @XMH
Q
HDRFIND(XMZ,XMFIND,XMHDR) ;
N XMH,XMI,XMREC
I XMFIND'?1"^".E1"^" D
. I $E(XMFIND,1)'=U S XMFIND=U_XMFIND
. I $E(XMFIND,$L(XMFIND))'=U S XMFIND=XMFIND_U
S XMI=0
F S XMI=$O(^XMB(3.9,XMZ,2,XMI)) Q:XMI'<1!'XMI S XMREC=^(XMI,0) Q:XMREC="" D
. I $E(XMREC,1)=" "!($E(XMREC,1)=$C(9)) Q:XMH="" D NEXT(XMH,.XMHDR,XMREC) Q
. S XMH=$$UP^XLFSTR($P(XMREC,":"))
. I XMFIND'[(U_XMH_U) S XMH="" Q
. I "^DATE^FROM^IMPORTANCE^IN-REPLY-TO^MESSAGE-ID^SUBJECT^"[(U_XMH_U) S XMH=$E($TR(XMH,"-"),1,4),XMHDR(XMH)=$$SCRUB($P(XMREC,":",2,99)) Q
. I "^ENCRYPTED^EXPIRY-DATE^REFERENCES^REPLY-TO^RETURN-RECEIPT-TO^SENDER^SENSITIVITY^"[(U_XMH_U) S XMH=$E($TR(XMH,"-"),1,4),XMHDR(XMH)=$$SCRUB($P(XMREC,":",2,99)) Q
. I "^X-PRIORITY^"[(U_XMH_U) S XMH=$E($P(XMH,"-",2),1,4),XMHDR(XMH)=$$SCRUB($P(XMREC,":",2,99)) Q
. I "^X-MM-BASKET^X-MM-CLOSED^X-MM-INFO-ONLY^X-MM-TYPE^"[(U_XMH_U) S XMH=$E($P(XMH,"-",3),1,4),XMHDR(XMH)=$$SCRUB($P(XMREC,":",2,99)) Q
. S XMH=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMR3 9364 printed Apr 09, 2024@21:13:55 Page 2
XMR3 ;ISC-SF/GMB-SMTP Receiver (RFC 822) ;07/01/2002 14:11
+1 ;;8.0;MailMan;;Jun 28, 2002
DATA ; TEXT / ASSUMES VALID RECIPIENT
+1 ; Incoming Variables:
+2 ; XMINSTR("FWD BY")=""
+3 ; XMZ message number of new message
+4 ; XMZFDA FM FDA for new message
+5 ; XMZIENS IENS for new message
+6 ; $D(XMC("DX")) means Test mode: Messages will not be delivered
+7 ; If the msg is from a VA site, the following may be set:
+8 ; XMREMID always set if the msg is from a VA site
+9 ; $G(XMRXMZ) message number of message we already have.
+10 ; Set if new message is a duplicate of one we already have.
+11 NEW XMLIN,XMINCR,XMHDR,XMREJECT,XMSUBJ,XMFROM,XMDATE,XMENCR,XMZO,XMSENDER,XMREPLTO
+12 DO GETDATA
if ER
QUIT
+13 IF '$GET(XMRXMZ)
IF '$DATA(XMC("DX"))
DO HDRPROC
if ER
QUIT
+14 IF '$GET(XMREJECT)
IF '$DATA(XMC("DX"))
DO SET
+15 SET XMSTATE="^HELO^MAIL^"
+16 KILL ^TMP("XMY",$JOB),^TMP("XMY0",$JOB)
+17 DO ZAPIT^XMXMSGS2(.5,.95,XMZ)
+18 IF '$GET(XMREJECT)
Begin DoDot:1
+19 SET XMSG="250 'data' accepted"
XECUTE XMSEN
+20 DO XMTHIST^XMTDR(XMINST,"R",$PIECE($GET(^XMB(3.9,XMZ,2,0)),U,4))
End DoDot:1
+21 KILL XMNVFROM,XMINSTR,XMREMID,XMRXMZ,XMZ,XMZIENS,XMZFDA
+22 QUIT
GETDATA ;
+1 NEW XMH
+2 SET XMSG="354 Enter data"
XECUTE XMSEN
if ER
QUIT
+3 SET XMLIN=.001
SET XMINCR=.001
SET XMH=""
+4 FOR
XECUTE XMREC
if ER
QUIT
if XMRG="."
QUIT
Begin DoDot:1
+5 IF $EXTRACT(XMRG)="."
SET XMRG=$EXTRACT(XMRG,2,999)
+6 SET XMLIN=XMLIN+XMINCR
+7 SET ^XMB(3.9,XMZ,2,XMLIN,0)=XMRG
+8 if XMINCR=1
QUIT
+9 IF XMRG=""
SET XMINCR=1
SET XMLIN=0
QUIT
+10 IF XMLIN=.99
SET XMINCR=.000001
+11 IF $EXTRACT(XMRG,1)=" "!($EXTRACT(XMRG,1)=$CHAR(9))
if XMH=""
QUIT
DO NEXT(XMH,.XMHDR,XMRG)
QUIT
+12 ;I $E(XMRG,1)=" " Q:XMH="" D NEXT(XMH,.XMHDR,XMRG)
+13 SET XMH=$$UP^XLFSTR($PIECE(XMRG,":"))
+14 IF "^DATE^FROM^IMPORTANCE^IN-REPLY-TO^MESSAGE-ID^SUBJECT^"[(U_XMH_U)
SET XMH=$EXTRACT($TRANSLATE(XMH,"-"),1,4)
SET XMHDR(XMH)=$$SCRUB($PIECE(XMRG,":",2,99))
QUIT
+15 IF "^ENCRYPTED^EXPIRY-DATE^REFERENCES^REPLY-TO^RETURN-RECEIPT-TO^SENDER^SENSITIVITY^"[(U_XMH_U)
SET XMH=$EXTRACT($TRANSLATE(XMH,"-"),1,4)
SET XMHDR(XMH)=$$SCRUB($PIECE(XMRG,":",2,99))
QUIT
+16 IF "^X-PRIORITY^"[(U_XMH_U)
SET XMH=$EXTRACT($PIECE(XMH,"-",2),1,4)
SET XMHDR(XMH)=$$SCRUB($PIECE(XMRG,":",2,99))
QUIT
+17 IF "^X-MM-BASKET^X-MM-CLOSED^X-MM-INFO-ONLY^X-MM-TYPE^"[(U_XMH_U)
SET XMH=$EXTRACT($PIECE(XMH,"-",3),1,4)
SET XMHDR(XMH)=$$SCRUB($PIECE(XMRG,":",2,99))
QUIT
+18 SET XMH=""
End DoDot:1
+19 if ER
QUIT
+20 QUIT
NEXT(XMH,XMHDR,XMDATA) ;
+1 NEW I
+2 SET XMDATA=$$SCRUB(XMDATA)
if XMDATA=""
QUIT
+3 IF XMHDR(XMH)=""
SET XMHDR(XMH)=XMDATA
QUIT
+4 IF $LENGTH(XMHDR(XMH))+$LENGTH(XMDATA)<255
SET XMHDR(XMH)=XMHDR(XMH)_" "_XMDATA
QUIT
+5 SET I=$ORDER(^XMHDR(XMH,":"),-1)+1
+6 IF $GET(XMHDR(XMH,I))'=""
IF $LENGTH(XMHDR(XMH,I))+$LENGTH(XMDATA)<255
SET XMHDR(XMH,I)=$GET(XMHDR(XMH,I))_" "_XMDATA
QUIT
+7 SET XMHDR(XMH,I+1)=XMDATA
+8 QUIT
HDRPROC ; Process header commands
+1 NEW XMH,XMP,XMRINFO
+2 IF XMLIN
IF $ORDER(^XMB(3.9,XMZ,2,XMLIN))
Begin DoDot:1
+3 SET XMREJECT=1
+4 SET XMSG="500 Synchronization Lost. Msg rejected."
XECUTE XMSEN
+5 DO KILLIT^XMR3A
End DoDot:1
QUIT
+6 ;I '$D(XMHDR("FROM")) D Q
+7 ;. S XMREJECT=1
+8 ;. S XMSG="501 Missing FROM Header. Msg rejected." X XMSEN
+9 ;. D KILLIT^XMR3A
+10 IF $$TOOLONG
Begin DoDot:1
+11 SET XMREJECT=1
+12 SET XMSG="551 Too many lines. Msg rejected."
XECUTE XMSEN
+13 DO KILLIT^XMR3A
End DoDot:1
QUIT
+14 IF '$DATA(XMREMID)
SET XMREMID=""
+15 SET (XMH,XMZO,XMFROM,XMENCR,XMSENDER,XMDATE,XMSUBJ)=""
+16 FOR
SET XMH=$ORDER(XMHDR(XMH))
if XMH=""
QUIT
Begin DoDot:1
+17 SET XMP=XMHDR(XMH)
+18 DO @XMH
End DoDot:1
+19 IF '$ORDER(^XMB(3.9,XMZ,2,.999999))
IF '$DATA(XMZFDA(3.9,XMZIENS,.01))
Begin DoDot:1
+20 SET XMSG="552 No subject or text. Msg rejected."
XECUTE XMSEN
+21 DO KILLIT^XMR3A
+22 SET XMREJECT=1
End DoDot:1
QUIT
+23 IF $GET(XMRINFO)
Begin DoDot:1
+24 SET XMSG="555 Reply to 'Info Only'. Msg rejected."
XECUTE XMSEN
+25 DO KILLIT^XMR3A
+26 SET XMREJECT=1
End DoDot:1
QUIT
+27 ;I $G(XMZFDA(3.9,XMZIENS,9))="" D Q
+28 ;. S XMSG="501 No MESSAGE-ID. Msg rejected." X XMSEN
+29 ;. D KILLIT^XMR3A
+30 ;. S XMREJECT=1
+31 ;I '$O(^XMB(3.9,XMZ,2,.999999)) S ^XMB(3.9,XMZ,2,1,0)=" "
+32 SET ^XMB(3.9,XMZ,2,0)="^^"_XMLIN_U_XMLIN
+33 QUIT
TOOLONG() ;
+1 NEW XMLIMIT
+2 SET XMLIMIT=$PIECE($GET(^XMB(1,1,"NETWORK-LIMIT")),U,2)
+3 if 'XMLIMIT
QUIT 0
+4 if $GET(XM2LONG)
QUIT 1
+5 if XMLIN'>XMLIMIT
QUIT 0
+6 IF $GET(XMHDR("TYPE"))["X"!($GET(XMHDR("TYPE"))["K")
QUIT 0
+7 QUIT 1
SCRUB(X) ; Strip ctrl chars and leading/trailing blanks
+1 if X?.E1C.E
SET X=$$CTRL^XMXUTIL1(X)
+2 if $EXTRACT(X,1)=" "!($EXTRACT(X,$LENGTH(X))=" ")
SET X=$$STRIP^XMXUTIL1(X)
+3 QUIT X
BASK ; "X-MM-BASKET:" (Delivery Basket)
+1 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,21)=XMP
+2 QUIT
CLOS ; "X-MM-CLOSED:YES"
+1 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,1.95)="y"
+2 QUIT
DATE ; "DATE:"
+1 SET XMDATE=XMP
+2 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,1.4)=XMDATE
+3 QUIT
ENCR ; "ENCRYPT:"
+1 SET XMENCR=XMP
+2 if '$DATA(XMZIENS)
QUIT
+3 ; scramble hint
SET XMZFDA(3.9,XMZIENS,1.8)=$PIECE(XMENCR,U,1)
+4 ; scramble key
SET XMZFDA(3.9,XMZIENS,1.85)=$PIECE(XMENCR,U,2,999)
+5 QUIT
EXPI ; "EXPIRY-DATE:" (vaporize date)
+1 NEW XMVAPOR
+2 SET XMVAPOR=$$CONVERT^XMXUTIL1(XMP,1)
if XMVAPOR=-1
QUIT
+3 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,1.6)=XMVAPOR
+4 QUIT
FROM ; "FROM:"
+1 SET XMFROM=XMP
+2 if '$DATA(XMZIENS)
QUIT
+3 ;I $D(XMHDR("FROM",1)) D CONTINU(.XMFROM,"FROM",.XMHDR)
+4 SET XMZFDA(3.9,XMZIENS,1)=XMFROM
+5 QUIT
CONTINU(XMVBL,XMH,XMHDR) ;
+1 NEW I
+2 SET I=0
+3 FOR
SET I=$ORDER(XMHDR(XMH,I))
if 'I
QUIT
SET XMVBL=XMVBL_" "_XMHDR(XMH,I)
+4 QUIT
IMPO ; "IMPORTANCE:HIGH" (Priority)
+1 IF $$UP^XLFSTR(XMP)'="HIGH"!'$DATA(XMZIENS)
QUIT
+2 if $GET(XMZFDA(3.9,XMZIENS,1.7))'["P"
SET XMZFDA(3.9,XMZIENS,1.7)=$GET(XMZFDA(3.9,XMZIENS,1.7))_"P"
+3 QUIT
INFO ; "X-MM-INFO-ONLY:YES"
+1 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,1.97)="y"
+2 QUIT
REFE ; "REFERENCES:" (used by some systems, instead of 'in-reply-to')
+1 QUIT
INRE ; "IN-REPLY-TO:" message at this site
+1 NEW I,XMLOCID,XMREC
+2 SET XMLOCID=$$REMID(XMP)
+3 SET XMZO=$$LOCALXMZ^XMR3A(XMLOCID)
+4 if 'XMZO
QUIT
+5 IF $PIECE(XMZO,U,3)'="E"
SET XMZO=""
QUIT
+6 SET XMZO=+XMZO
+7 SET XMREC=$GET(^XMB(3.9,XMZO,0))
+8 ; If reply to a reply, get original msg #
IF $PIECE(XMREC,U,8)
Begin DoDot:1
+9 SET XMZO=$PIECE(XMREC,U,8)
+10 SET XMREC=$GET(^XMB(3.9,XMZO,0))
End DoDot:1
+11 ; Original message not found, so make this reply a message.
IF XMREC=""
SET XMZO=""
QUIT
+12 ; Reply to 'info only' msg
IF "^y^Y^"[(U_$PIECE(XMREC,U,12)_U)
SET XMRINFO=1
QUIT
+13 ; Point from response to original msg
if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,1.35)=XMZO
+14 QUIT
REMID(X) ;
+1 if X["<"
QUIT $TRANSLATE($PIECE(X,">",1),"<")
+2 ; I've seen some like this: "<<...>>"
+3 ; I've seen some like this: "<...> comment here"
+4 QUIT X
MESS ; "MESSAGE-ID:" at site where message originated
+1 SET XMREMID=$$REMID(XMP)
+2 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,9)=XMREMID
+3 QUIT
PRIO ; "X-PRIORITY:1" (Priority)
+1 IF $$UP^XLFSTR(XMP)'=1!'$DATA(XMZIENS)
QUIT
+2 if $GET(XMZFDA(3.9,XMZIENS,1.7))'["P"
SET XMZFDA(3.9,XMZIENS,1.7)=$GET(XMZFDA(3.9,XMZIENS,1.7))_"P"
+3 QUIT
REPL ; "REPLY-TO:"
+1 SET XMREPLTO=XMP
+2 ;I $D(XMHDR("REPL",1)) D CONTINU(.XMREPLTO,"REPL",.XMHDR)
+3 QUIT
RETU ; "RETURN-RECEIPT-TO:"
+1 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,1.3)="y"
+2 QUIT
SEND ; "SENDER:" (Surrogate)
+1 SET XMSENDER=XMP
+2 ;I $D(XMHDR("SEND",1)) D CONTINU(.XMSENDER,"SEND",.XMHDR)
+3 if XMSENDER=$GET(XMFROM)
QUIT
+4 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,1.1)=XMSENDER
+5 QUIT
SENS ; "SENSITIVITY:PERSONAL" (Confidential)
+1 if "^PERSONAL^PRIVATE^COMPANY-CONFIDENTIAL^"'[(U_$$UP^XLFSTR(XMP)_U)
QUIT
+2 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,1.96)="y"
+3 QUIT
SUBJ ; "SUBJECT:"
+1 SET XMSUBJ=XMP
+2 IF XMSUBJ[" "
SET XMSUBJ=$$MAXBLANK^XMXUTIL1(XMSUBJ)
+3 IF XMSUBJ["^"
SET XMSUBJ=$$ENCODEUP^XMXUTIL1(XMSUBJ)
+4 SET XMSUBJ=$EXTRACT(XMSUBJ,1,65)
+5 if XMSUBJ=""!'$DATA(XMZIENS)
QUIT
+6 IF $LENGTH(XMSUBJ)<3
SET XMSUBJ="..."
+7 SET XMZFDA(3.9,XMZIENS,.01)=XMSUBJ
+8 QUIT
TYPE ; "X-MM-TYPE:"
+1 if $DATA(XMZIENS)
SET XMZFDA(3.9,XMZIENS,1.7)=XMP
+2 QUIT
SET ; Set data into message file
+1 IF $GET(XMREMID)'=""
DO CHEKDUP^XMR3A
if $GET(XMREJECT)
QUIT
+2 IF $DATA(XMZFDA)
Begin DoDot:1
+3 IF $DATA(XMZFDA(3.9,XMZIENS,1.1))
IF $LENGTH(XMZFDA(3.9,XMZIENS,1))+$LENGTH(XMZFDA(3.9,XMZIENS,1.1))>130
SET XMZFDA(3.9,XMZIENS,1.1)=$EXTRACT($$REMADDR^XMXADDR3(XMZFDA(3.9,XMZIENS,1.1)),1,64)
+4 IF $LENGTH(XMZFDA(3.9,XMZIENS,1))>100
SET XMZFDA(3.9,XMZIENS,1)="<"_$$REMADDR^XMXADDR3(XMZFDA(3.9,XMZIENS,1))_">"
+5 DO FILE^DIE("","XMZFDA")
End DoDot:1
+6 ;SENDER only RCPT / REMOTE sender drops thru (local>0=pointer)
+7 ; I don't understand this.
IF $GET(XMZO)
Begin DoDot:1
+8 ;> Putting response |1| into message |2|
DO DOTRAN^XMC1(42315,XMZ,XMZO)
+9 ;> Delivering message |1|
DO DOTRAN^XMC1(42316,XMZO)
+10 DO RPOST^XMKP("NR",XMZO,XMZ)
End DoDot:1
if $ORDER(^TMP("XMY",$JOB,""))
QUIT
+11 DO FWD^XMKP(.5,XMZ,.XMINSTR)
+12 DO CHECK^XMKPL
+13 QUIT
PARSE(XMZ,XMREMID,XMSUBJ,XMFROM,XMDATE,XMSENDER,XMENCR,XMZO) ; Get data for remotely originated message
+1 ; This is used by ^XMRENT & ^XMS3
+2 ; XMSUBJ subject
+3 ; XMFROM from
+4 ; XMDATE date
+5 ; XMENCR scramble hint "^" scramble key
+6 ; XMREMID message id at site where msg originated (not necessarily at the sending site)
+7 ; XMZO original message xmz (to which this msg is a response)
+8 NEW XMP,XMH,XMHDR,XMRINFO,XMZFDA,XMZIENS,XMFIND
+9 ; Don't add anything to this list:
+10 SET XMFIND="^DATE^ENCRYPTED^FROM^IN-REPLY-TO^MESSAGE-ID^SENDER^SUBJECT^"
+11 DO HDRFIND(XMZ,XMFIND,.XMHDR)
+12 SET XMH=""
+13 FOR
SET XMH=$ORDER(XMHDR(XMH))
if XMH=""
QUIT
Begin DoDot:1
+14 SET XMP=XMHDR(XMH)
+15 DO @XMH
End DoDot:1
+16 QUIT
HDRFIND(XMZ,XMFIND,XMHDR) ;
+1 NEW XMH,XMI,XMREC
+2 IF XMFIND'?1"^".E1"^"
Begin DoDot:1
+3 IF $EXTRACT(XMFIND,1)'=U
SET XMFIND=U_XMFIND
+4 IF $EXTRACT(XMFIND,$LENGTH(XMFIND))'=U
SET XMFIND=XMFIND_U
End DoDot:1
+5 SET XMI=0
+6 FOR
SET XMI=$ORDER(^XMB(3.9,XMZ,2,XMI))
if XMI'<1!'XMI
QUIT
SET XMREC=^(XMI,0)
if XMREC=""
QUIT
Begin DoDot:1
+7 IF $EXTRACT(XMREC,1)=" "!($EXTRACT(XMREC,1)=$CHAR(9))
if XMH=""
QUIT
DO NEXT(XMH,.XMHDR,XMREC)
QUIT
+8 SET XMH=$$UP^XLFSTR($PIECE(XMREC,":"))
+9 IF XMFIND'[(U_XMH_U)
SET XMH=""
QUIT
+10 IF "^DATE^FROM^IMPORTANCE^IN-REPLY-TO^MESSAGE-ID^SUBJECT^"[(U_XMH_U)
SET XMH=$EXTRACT($TRANSLATE(XMH,"-"),1,4)
SET XMHDR(XMH)=$$SCRUB($PIECE(XMREC,":",2,99))
QUIT
+11 IF "^ENCRYPTED^EXPIRY-DATE^REFERENCES^REPLY-TO^RETURN-RECEIPT-TO^SENDER^SENSITIVITY^"[(U_XMH_U)
SET XMH=$EXTRACT($TRANSLATE(XMH,"-"),1,4)
SET XMHDR(XMH)=$$SCRUB($PIECE(XMREC,":",2,99))
QUIT
+12 IF "^X-PRIORITY^"[(U_XMH_U)
SET XMH=$EXTRACT($PIECE(XMH,"-",2),1,4)
SET XMHDR(XMH)=$$SCRUB($PIECE(XMREC,":",2,99))
QUIT
+13 IF "^X-MM-BASKET^X-MM-CLOSED^X-MM-INFO-ONLY^X-MM-TYPE^"[(U_XMH_U)
SET XMH=$EXTRACT($PIECE(XMH,"-",3),1,4)
SET XMHDR(XMH)=$$SCRUB($PIECE(XMREC,":",2,99))
QUIT
+14 SET XMH=""
End DoDot:1
+15 QUIT
