181 lines
6.0 KiB
Mathematica
181 lines
6.0 KiB
Mathematica
XMS ;ISC-SF/GMB-SMTP Send ;07/11/2002 07:52
|
|
;;8.0;MailMan;;Jun 28, 2002
|
|
ENTER ;
|
|
; Variables
|
|
; XMINST Institution number
|
|
; XMSITE Institution name
|
|
; XMIO same as ZTIO
|
|
D INIT
|
|
; Fall through...
|
|
SEND ;
|
|
S XMC("DIR")="S"
|
|
S:'$D(XMC("TURN")) XMC("TURN")=0
|
|
D SYNCH Q:ER
|
|
I $D(XMC("CHRISTEN")) D CHRISTN,TESTLNK Q
|
|
I $D(XMC("TEST")) D TESTLNK Q
|
|
D HELO(XMINST,XMSITE) L -^DIC(4.2,XMINST,0) Q:ER
|
|
D PROCESS(XMINST,.XMB)
|
|
D TURN(XMINST)
|
|
D QUIT
|
|
Q
|
|
INIT ;
|
|
S ER=0
|
|
S $P(^XMBS(4.2999,XMINST,3),U,6)=$E(IO,1,9)_" "_XMPROT
|
|
S:'$D(XMC("START")) XMC("START")=$$TSTAMP^XMXUTIL1-.001
|
|
I '$D(DT) D DT^DICRW
|
|
S:'$D(XMC("BATCH")) XMC("BATCH")=0
|
|
S XMTLER=0
|
|
Q
|
|
SYNCH ; Recv: "220 REMOTE.MED.VA.GOV MailMan 8.0 ready"
|
|
I XMC("BATCH") S XMC("MAILMAN")=+$P($T(XMS+1),";",3) Q
|
|
S XMC("MAILMAN")=0
|
|
N XMI,XMX
|
|
F XMI=1:1:5 D Q:ER Q:$E(XMRG)=2
|
|
. X XMREC Q:ER
|
|
. S XMX=$P(XMRG," MailMan ",2)
|
|
. I XMX>4,XMX[" ready" S XMC("MAILMAN")=+XMX
|
|
. I $E(XMRG)'=2 S XMSG="NOOP" X XMSEN Q
|
|
Q
|
|
HELO(XMINST,XMSITE) ;
|
|
; Send: "HELO LOCAL.MED.VA.GOV <security num>"
|
|
; Recv: "250 OK REMOTE.MED.VA.GOV <security num> [8.0,DUP,SER,FTP]"
|
|
N XMINREC,XMSVAL,I
|
|
S XMINREC=^DIC(4.2,XMINST,0)
|
|
S XMSVAL=$P(XMINREC,U,15) ; Security code
|
|
I XMSVAL L +^DIC(4.2,XMINST,0):0 E D Q
|
|
. D ERTRAN^XMC1(42350) ;Domain file locked.
|
|
S XMSG="HELO "_^XMB("NETNAME")_$S('XMSVAL:"",1:"<"_XMSVAL_">") X XMSEN
|
|
I ER D ERTRAN^XMC1(42351,XMSG) Q ;HELO SEND failed: |1|
|
|
Q:XMC("BATCH")
|
|
X XMREC I ER D ERTRAN^XMC1(42352) Q ;HELO RECEIVE failed.
|
|
I $E(XMRG)'=2 D Q
|
|
. D ERTRAN^XMC1(42353,^XMB("NETNAME"),XMSITE) ;|1| not recognized by |2|
|
|
;I $P(XMRG,"[",2)'="" S XMC("CAPABLE")=$P(XMRG,"[",2)
|
|
F I=1:1:$L(XMRG," ") Q:$P(XMRG," ",I)["."
|
|
S XMC("HELO SEND")=$P(XMRG," ",I)
|
|
Q:'XMSVAL
|
|
S XMSVAL=$P($P(XMRG,"<",2),">")
|
|
I XMSVAL<1000000 D Q
|
|
. N XMPARM,XMINSTR
|
|
. S XMSG="500 Invalid domain validation response" X XMSEN
|
|
. S XMPARM(1)=XMSITE,XMINSTR("FROM")="POSTMASTER"
|
|
. D TASKBULL^XMXBULL(.5,"XMVALBAD",.XMPARM,,,.XMINSTR)
|
|
. S ER=1,ER("MSG")=XMSG
|
|
;Double set below prevents replicated ^DIC from
|
|
;going out of synch when link is down.
|
|
S ^DIC(4.2,XMINST,0)=XMINREC,$P(XMINREC,U,15)=XMSVAL,^(0)=XMINREC
|
|
Q
|
|
PROCESS(XMINST,XMB) ;
|
|
N XMK,XMZ
|
|
S XMK=XMINST+1000
|
|
I '$$BMSGCT^XMXUTIL(.5,XMK) D Q
|
|
. D DOTRAN^XMC1(42358) ; There are no messages in the queue to send
|
|
; First send msgs the postmaster has flagged to go first
|
|
; (NETWORK MESSAGE FLAG) set to 1), then send rest.
|
|
F S XMZ=$$NEXT(XMK) Q:XMZ="" D Q:ER
|
|
. L +^XMNET(XMINST,XMZ):0 E D Q
|
|
. . S XMC("NOREQUEUE")=1
|
|
. . D ERTRAN^XMC1(42354) ;Queue being transmitted by another job - Aborting now.
|
|
. D SENDMSG^XMS1(XMK,XMZ,.XMB)
|
|
. I '$D(^XMB(3.9,XMZ,1,"AQUEUE",XMINST)) D ZAPIT^XMXMSGS2(.5,XMK,XMZ) H 1
|
|
. I ER,$G(ER("NONFATAL")) D
|
|
. . K ER S ER=0
|
|
. . I $D(^XMB(3.7,.5,2,XMK,1,XMZ,0)) D XP^XMXMSGS1(.5,XMK,XMZ,2) ; Set xmit priority LOW
|
|
. . D RSET
|
|
. L -^XMNET(XMINST,XMZ)
|
|
Q
|
|
NEXT(XMK) ; Returns the next message (XMZ) in basket XMK to go out.
|
|
; The next XMZ flagged 'high-priority' is next.
|
|
; Barring that, the next 'regular-priority' XMZ is next.
|
|
; Barring that, the next 'low-priority' XMZ is next.
|
|
; If an XMZ was involved in the failure of the previous transmission,
|
|
; that XMZ will be 'low-priority'.
|
|
N XMZ,XMOK
|
|
S XMZ=$$NEXTPRI(XMK,1) Q:XMZ XMZ ; Get next high priority msg, if any
|
|
S (XMZ,XMOK)=0 ; Get next regular priority msg, if any
|
|
F S XMZ=$O(^XMB(3.7,.5,2,XMK,1,XMZ)) Q:'XMZ D Q:XMOK
|
|
. Q:$D(^XMB(3.7,.5,2,XMK,1,"AC",2,XMZ)) ; Skip if low priority
|
|
. S:$$NEXTOK(XMK,XMZ) XMOK=1 ; Check msg OK
|
|
Q:XMZ XMZ
|
|
Q $$NEXTPRI(XMK,2) ; Get next low priority msg, if any
|
|
NEXTPRI(XMK,XMTPRI) ; Get the next high/low priority message
|
|
N XMZ
|
|
F S XMZ=$O(^XMB(3.7,.5,2,XMK,1,"AC",XMTPRI,0)) Q:'XMZ D Q:XMZ
|
|
. I '$D(^XMB(3.7,.5,2,XMK,1,XMZ,0)) D Q
|
|
. . K ^XMB(3.7,.5,2,XMK,1,"AC",XMTPRI,XMZ) ; msg not in bskt, kill xref
|
|
. . S XMZ=0
|
|
. I '$$NEXTOK(XMK,XMZ) S XMZ=0 ; Check msg OK
|
|
Q XMZ
|
|
NEXTOK(XMK,XMZ) ; Ensure msg is in file 3.9 & still has recipients q'd
|
|
I $D(^XMB(3.9,XMZ,0)),$O(^XMB(3.9,XMZ,1,"AQUEUE",XMK-1000,0)) Q 1
|
|
D ZAPIT^XMXMSGS2(.5,XMK,XMZ)
|
|
Q 0
|
|
QUIT ;
|
|
Q:$G(XMC("QUIT"))
|
|
S XMSG="QUIT" X XMSEN Q:ER
|
|
X XMREC
|
|
S XMC("QUIT")=1
|
|
Q
|
|
RSET ; Send: "RSET"
|
|
; Recv: "250"
|
|
S XMSG="RSET" X XMSEN Q:ER!XMC("BATCH")
|
|
X XMREC Q:ER
|
|
I $E(XMRG)'=2 S ER=1
|
|
Q
|
|
TURN(XMINST) ; Turn around channel
|
|
; Send: "TURN"
|
|
; Recv: "250 REMOTE.MED.VA.GOV has messages to export"
|
|
; or: "502 REMOTE.MED.VA.GOV has no messages to export"
|
|
Q:XMC("TURN")!XMC("BATCH")
|
|
I $F("Yy",$P(^DIC(4.2,XMINST,0),U,16))>1 D Q
|
|
. D DOTRAN^XMC1(42355.1,XMSITE) ; TURN command disabled for |1|
|
|
S XMC("TURN")=1
|
|
N XMFDA,XMIENS
|
|
S XMIENS=XMINST_","
|
|
S XMFDA(4.2999,XMIENS,1)=$H
|
|
S XMFDA(4.2999,XMIENS,25)=$S($D(ZTQUEUED):$G(ZTSK),1:"@") ; Task number
|
|
D FILE^DIE("","XMFDA")
|
|
S XMSG="TURN" X XMSEN Q:ER
|
|
X XMREC Q:$E(XMRG)'="2"!ER
|
|
D DOTRAN^XMC1(42355) ;Turning around receiver
|
|
G RECEIVE^XMR ; Go into receive mode
|
|
Q
|
|
CHRISTN ; Christen the remote domain
|
|
S XMSG="CHRS "_XMC("CHRISTEN") X XMSEN Q:ER X XMREC Q:ER
|
|
Q
|
|
TESTLNK ; Test the link
|
|
N XMSTIME,XMETIME,XMTLER,XMCHARS,XMUERR,XMLINES
|
|
S XMSG="ECHO" X XMSEN I ER D TESTERR Q
|
|
X XMREC I ER D TESTERR Q
|
|
S XMSTIME=$$NOW^XLFDT
|
|
D TESTIT(.XMLINES,.XMCHARS,.XMUERR,.XMTLER)
|
|
S XMETIME=$$NOW^XLFDT
|
|
D:ER TESTERR
|
|
U IO(0)
|
|
D TESTRSLT(XMSTIME,XMETIME,XMLINES,XMCHARS,XMUERR,XMTLER)
|
|
Q
|
|
TESTERR ;
|
|
S XMSG="****Physical link protocol error. Unable to proceed" D TRAN^XMC1
|
|
Q
|
|
TESTIT(XMLINES,XMCHARS,XMUERR,XMTLER) ;
|
|
N I
|
|
S (I,XMLINES,XMCHARS,XMUERR,XMTLER)=0
|
|
F S I=$O(^TMP("XMS",$J,"S",I)) Q:'I S XMSG=^(I) D Q:ER
|
|
. S XMLINES=XMLINES+1
|
|
. S XMCHARS=XMCHARS+$L(XMSG)
|
|
. X XMSEN Q:ER X XMREC Q:ER
|
|
. Q:XMRG=XMSG
|
|
. S XMUERR=XMUERR+1
|
|
. U IO(0)
|
|
. S XMSG="*****Sent: "_XMSG D TRAN^XMC1
|
|
. S XMSG="*****Rec'd: "_XMRG D TRAN^XMC1
|
|
. U IO
|
|
Q:ER
|
|
S XMSG="." X XMSEN Q:ER X XMREC
|
|
Q
|
|
TESTRSLT(XMSTIME,XMETIME,XMLINES,XMCHARS,XMUERR,XMTLER) ;
|
|
S XMSG=XMLINES_" Lines,"_XMCHARS_" characters transmitted." D TRAN^XMC1
|
|
S XMSG="Errors detected: "_XMUERR_" unrecoverable, "_XMTLER_" recoverable."
|
|
S XMSG=$J(XMCHARS/$$FMDIFF^XLFDT(XMETIME,XMSTIME,2),0,1)_" chars/sec effective transmission rate." D TRAN^XMC1
|
|
Q
|