source: WorldVistAEHR/trunk/r/MAILMAN-XM/XMS.m@ 1166

Last change on this file since 1166 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 6.0 KB
RevLine 
[613]1XMS ;ISC-SF/GMB-SMTP Send ;07/11/2002 07:52
2 ;;8.0;MailMan;;Jun 28, 2002
3ENTER ;
4 ; Variables
5 ; XMINST Institution number
6 ; XMSITE Institution name
7 ; XMIO same as ZTIO
8 D INIT
9 ; Fall through...
10SEND ;
11 S XMC("DIR")="S"
12 S:'$D(XMC("TURN")) XMC("TURN")=0
13 D SYNCH Q:ER
14 I $D(XMC("CHRISTEN")) D CHRISTN,TESTLNK Q
15 I $D(XMC("TEST")) D TESTLNK Q
16 D HELO(XMINST,XMSITE) L -^DIC(4.2,XMINST,0) Q:ER
17 D PROCESS(XMINST,.XMB)
18 D TURN(XMINST)
19 D QUIT
20 Q
21INIT ;
22 S ER=0
23 S $P(^XMBS(4.2999,XMINST,3),U,6)=$E(IO,1,9)_" "_XMPROT
24 S:'$D(XMC("START")) XMC("START")=$$TSTAMP^XMXUTIL1-.001
25 I '$D(DT) D DT^DICRW
26 S:'$D(XMC("BATCH")) XMC("BATCH")=0
27 S XMTLER=0
28 Q
29SYNCH ; Recv: "220 REMOTE.MED.VA.GOV MailMan 8.0 ready"
30 I XMC("BATCH") S XMC("MAILMAN")=+$P($T(XMS+1),";",3) Q
31 S XMC("MAILMAN")=0
32 N XMI,XMX
33 F XMI=1:1:5 D Q:ER Q:$E(XMRG)=2
34 . X XMREC Q:ER
35 . S XMX=$P(XMRG," MailMan ",2)
36 . I XMX>4,XMX[" ready" S XMC("MAILMAN")=+XMX
37 . I $E(XMRG)'=2 S XMSG="NOOP" X XMSEN Q
38 Q
39HELO(XMINST,XMSITE) ;
40 ; Send: "HELO LOCAL.MED.VA.GOV <security num>"
41 ; Recv: "250 OK REMOTE.MED.VA.GOV <security num> [8.0,DUP,SER,FTP]"
42 N XMINREC,XMSVAL,I
43 S XMINREC=^DIC(4.2,XMINST,0)
44 S XMSVAL=$P(XMINREC,U,15) ; Security code
45 I XMSVAL L +^DIC(4.2,XMINST,0):0 E D Q
46 . D ERTRAN^XMC1(42350) ;Domain file locked.
47 S XMSG="HELO "_^XMB("NETNAME")_$S('XMSVAL:"",1:"<"_XMSVAL_">") X XMSEN
48 I ER D ERTRAN^XMC1(42351,XMSG) Q ;HELO SEND failed: |1|
49 Q:XMC("BATCH")
50 X XMREC I ER D ERTRAN^XMC1(42352) Q ;HELO RECEIVE failed.
51 I $E(XMRG)'=2 D Q
52 . D ERTRAN^XMC1(42353,^XMB("NETNAME"),XMSITE) ;|1| not recognized by |2|
53 ;I $P(XMRG,"[",2)'="" S XMC("CAPABLE")=$P(XMRG,"[",2)
54 F I=1:1:$L(XMRG," ") Q:$P(XMRG," ",I)["."
55 S XMC("HELO SEND")=$P(XMRG," ",I)
56 Q:'XMSVAL
57 S XMSVAL=$P($P(XMRG,"<",2),">")
58 I XMSVAL<1000000 D Q
59 . N XMPARM,XMINSTR
60 . S XMSG="500 Invalid domain validation response" X XMSEN
61 . S XMPARM(1)=XMSITE,XMINSTR("FROM")="POSTMASTER"
62 . D TASKBULL^XMXBULL(.5,"XMVALBAD",.XMPARM,,,.XMINSTR)
63 . S ER=1,ER("MSG")=XMSG
64 ;Double set below prevents replicated ^DIC from
65 ;going out of synch when link is down.
66 S ^DIC(4.2,XMINST,0)=XMINREC,$P(XMINREC,U,15)=XMSVAL,^(0)=XMINREC
67 Q
68PROCESS(XMINST,XMB) ;
69 N XMK,XMZ
70 S XMK=XMINST+1000
71 I '$$BMSGCT^XMXUTIL(.5,XMK) D Q
72 . D DOTRAN^XMC1(42358) ; There are no messages in the queue to send
73 ; First send msgs the postmaster has flagged to go first
74 ; (NETWORK MESSAGE FLAG) set to 1), then send rest.
75 F S XMZ=$$NEXT(XMK) Q:XMZ="" D Q:ER
76 . L +^XMNET(XMINST,XMZ):0 E D Q
77 . . S XMC("NOREQUEUE")=1
78 . . D ERTRAN^XMC1(42354) ;Queue being transmitted by another job - Aborting now.
79 . D SENDMSG^XMS1(XMK,XMZ,.XMB)
80 . I '$D(^XMB(3.9,XMZ,1,"AQUEUE",XMINST)) D ZAPIT^XMXMSGS2(.5,XMK,XMZ) H 1
81 . I ER,$G(ER("NONFATAL")) D
82 . . K ER S ER=0
83 . . I $D(^XMB(3.7,.5,2,XMK,1,XMZ,0)) D XP^XMXMSGS1(.5,XMK,XMZ,2) ; Set xmit priority LOW
84 . . D RSET
85 . L -^XMNET(XMINST,XMZ)
86 Q
87NEXT(XMK) ; Returns the next message (XMZ) in basket XMK to go out.
88 ; The next XMZ flagged 'high-priority' is next.
89 ; Barring that, the next 'regular-priority' XMZ is next.
90 ; Barring that, the next 'low-priority' XMZ is next.
91 ; If an XMZ was involved in the failure of the previous transmission,
92 ; that XMZ will be 'low-priority'.
93 N XMZ,XMOK
94 S XMZ=$$NEXTPRI(XMK,1) Q:XMZ XMZ ; Get next high priority msg, if any
95 S (XMZ,XMOK)=0 ; Get next regular priority msg, if any
96 F S XMZ=$O(^XMB(3.7,.5,2,XMK,1,XMZ)) Q:'XMZ D Q:XMOK
97 . Q:$D(^XMB(3.7,.5,2,XMK,1,"AC",2,XMZ)) ; Skip if low priority
98 . S:$$NEXTOK(XMK,XMZ) XMOK=1 ; Check msg OK
99 Q:XMZ XMZ
100 Q $$NEXTPRI(XMK,2) ; Get next low priority msg, if any
101NEXTPRI(XMK,XMTPRI) ; Get the next high/low priority message
102 N XMZ
103 F S XMZ=$O(^XMB(3.7,.5,2,XMK,1,"AC",XMTPRI,0)) Q:'XMZ D Q:XMZ
104 . I '$D(^XMB(3.7,.5,2,XMK,1,XMZ,0)) D Q
105 . . K ^XMB(3.7,.5,2,XMK,1,"AC",XMTPRI,XMZ) ; msg not in bskt, kill xref
106 . . S XMZ=0
107 . I '$$NEXTOK(XMK,XMZ) S XMZ=0 ; Check msg OK
108 Q XMZ
109NEXTOK(XMK,XMZ) ; Ensure msg is in file 3.9 & still has recipients q'd
110 I $D(^XMB(3.9,XMZ,0)),$O(^XMB(3.9,XMZ,1,"AQUEUE",XMK-1000,0)) Q 1
111 D ZAPIT^XMXMSGS2(.5,XMK,XMZ)
112 Q 0
113QUIT ;
114 Q:$G(XMC("QUIT"))
115 S XMSG="QUIT" X XMSEN Q:ER
116 X XMREC
117 S XMC("QUIT")=1
118 Q
119RSET ; Send: "RSET"
120 ; Recv: "250"
121 S XMSG="RSET" X XMSEN Q:ER!XMC("BATCH")
122 X XMREC Q:ER
123 I $E(XMRG)'=2 S ER=1
124 Q
125TURN(XMINST) ; Turn around channel
126 ; Send: "TURN"
127 ; Recv: "250 REMOTE.MED.VA.GOV has messages to export"
128 ; or: "502 REMOTE.MED.VA.GOV has no messages to export"
129 Q:XMC("TURN")!XMC("BATCH")
130 I $F("Yy",$P(^DIC(4.2,XMINST,0),U,16))>1 D Q
131 . D DOTRAN^XMC1(42355.1,XMSITE) ; TURN command disabled for |1|
132 S XMC("TURN")=1
133 N XMFDA,XMIENS
134 S XMIENS=XMINST_","
135 S XMFDA(4.2999,XMIENS,1)=$H
136 S XMFDA(4.2999,XMIENS,25)=$S($D(ZTQUEUED):$G(ZTSK),1:"@") ; Task number
137 D FILE^DIE("","XMFDA")
138 S XMSG="TURN" X XMSEN Q:ER
139 X XMREC Q:$E(XMRG)'="2"!ER
140 D DOTRAN^XMC1(42355) ;Turning around receiver
141 G RECEIVE^XMR ; Go into receive mode
142 Q
143CHRISTN ; Christen the remote domain
144 S XMSG="CHRS "_XMC("CHRISTEN") X XMSEN Q:ER X XMREC Q:ER
145 Q
146TESTLNK ; Test the link
147 N XMSTIME,XMETIME,XMTLER,XMCHARS,XMUERR,XMLINES
148 S XMSG="ECHO" X XMSEN I ER D TESTERR Q
149 X XMREC I ER D TESTERR Q
150 S XMSTIME=$$NOW^XLFDT
151 D TESTIT(.XMLINES,.XMCHARS,.XMUERR,.XMTLER)
152 S XMETIME=$$NOW^XLFDT
153 D:ER TESTERR
154 U IO(0)
155 D TESTRSLT(XMSTIME,XMETIME,XMLINES,XMCHARS,XMUERR,XMTLER)
156 Q
157TESTERR ;
158 S XMSG="****Physical link protocol error. Unable to proceed" D TRAN^XMC1
159 Q
160TESTIT(XMLINES,XMCHARS,XMUERR,XMTLER) ;
161 N I
162 S (I,XMLINES,XMCHARS,XMUERR,XMTLER)=0
163 F S I=$O(^TMP("XMS",$J,"S",I)) Q:'I S XMSG=^(I) D Q:ER
164 . S XMLINES=XMLINES+1
165 . S XMCHARS=XMCHARS+$L(XMSG)
166 . X XMSEN Q:ER X XMREC Q:ER
167 . Q:XMRG=XMSG
168 . S XMUERR=XMUERR+1
169 . U IO(0)
170 . S XMSG="*****Sent: "_XMSG D TRAN^XMC1
171 . S XMSG="*****Rec'd: "_XMRG D TRAN^XMC1
172 . U IO
173 Q:ER
174 S XMSG="." X XMSEN Q:ER X XMREC
175 Q
176TESTRSLT(XMSTIME,XMETIME,XMLINES,XMCHARS,XMUERR,XMTLER) ;
177 S XMSG=XMLINES_" Lines,"_XMCHARS_" characters transmitted." D TRAN^XMC1
178 S XMSG="Errors detected: "_XMUERR_" unrecoverable, "_XMTLER_" recoverable."
179 S XMSG=$J(XMCHARS/$$FMDIFF^XLFDT(XMETIME,XMSTIME,2),0,1)_" chars/sec effective transmission rate." D TRAN^XMC1
180 Q
Note: See TracBrowser for help on using the repository browser.