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