- 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 Jan 18, 2025@03:13:56 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