Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XMS

XMS.m

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