source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m@ 617

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

initial load of WorldVistAEHR
File size: 9.1 KB
RevLine 
[613]1HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/15/08 11:11
2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122,140**;OCT 13,1995;Build 5
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;Receiver
5 ;connection is initiated by sender and listener accepts connection
6 ;and calls this routine
7 ;
8 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"
9 N HLMIEN,HLASTMSG
10 ;
11 ; patch HL*1.6*140, save IO
12 S HLTCPORT("IO")=IO ;RWF
13 ; patch HL*1.6*122 start
14 ; variable to replace ^TMP
15 N HLTMBUF
16 ;
17 ; for HL7 application proxy user
18 ;; N HLDUZ,DUZ ; patch HL*1.6*122 TEST v2: DUZ code removed
19 N HLDUZ
20 S HLDUZ=+$G(DUZ)
21 ;
22 D MON^HLCSTCP("Open")
23 ; K ^TMP("HLCSTCP",$J,0)
24 S HLMIEN=0,HLASTMSG=""
25 ;
26 ; patch HL*1.6*122 TEST v2: DUZ code removed
27 ; set DUZ for application proxy user
28 ;; D PROXY^HLCSTCP4
29 ;
30 F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3
31 . ; clean variables
32 . D CLEANVAR^HLCSTCP4
33 . ; patch HL*1.6*140, restore the saved IO
34 . S IO=HLTCPORT("IO") ;RWF
35 . S HLMIEN=$$READ
36 . Q:'HLMIEN
37 . ;
38 . ; patch HL*1.6*122 TEST v2: DUZ code removed
39 . ; DUZ comparison/reset for application proxy user
40 . ;; D HLDUZ^HLCSTCP4
41 . D HLDUZ2^HLCSTCP4
42 . ; protect HLDUZ
43 . N HLDUZ
44 . D PROCESS
45 ; patch HL*1.6*122 end
46 Q
47 ;
48PROCESS ;check message and reply
49 ;HLDP=LL in 870
50 N HLTCP,HLTCPI,HLTCPO
51 S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
52 ;update monitor, msg. received
53 D LLCNT^HLCSTCP(HLDP,1)
54 D NEW^HLTP3(HLMIEN)
55 ;I IO'=HLTCPORT("IO") D ^%ZTER ;RWF
56 ;update monitor, msg. processed
57 D LLCNT^HLCSTCP(HLDP,2)
58 Q
59 ;
60READ() ;read 1 message, returns ien in 773^ien in 772 for message
61 D MON^HLCSTCP("Reading")
62 N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
63 ;HLDSTRT=start char., HLDEND=end char., HLRS=record separator
64 S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
65 ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
66 ;HLHDR=have a header, HLTMBUF()=excess from last read, HLACKWT=wait for ack
67 ; HL*1.6*122 start
68 ; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
69 S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(HLTMBUF(0)),HLACKWT=HLDBACK
70 N HLBUFF,HLXX,MAXWAIT
71 ; based on patch 132 for readtime
72 S MAXWAIT=$S((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD)
73 S HLRS("START-FLAG")=0
74 S HLTMBUF(0)=""
75 ; variable used to store data in HLBUFF
76 S HLX(1)=$G(HLTMBUF(1))
77 S HLTMBUF(1)=""
78 S HLBUFF("START")=0
79 S HLBUFF("END")=0
80 I (HLX]"")!(HLX(1)]"") D
81 . I (HLX[HLDSTRT)!(HLX(1)[HLDSTRT) D
82 .. S HLBUFF("START")=1
83 . I (HLX[HLDEND)!(HLX(1)[HLDEND) D
84 .. S HLBUFF("END")=1
85 F D RDBLK Q:HLRDOUT
86 ;**132**
87 ;switch to null device if opened to prevent 'leakage'
88 I $G(IO(0))]"",IO(0)'=IO U IO(0)
89 ;
90 ;save any excess for next time
91 S:HLX]"" HLTMBUF(0)=HLX
92 S:HLX(1)]"" HLTMBUF(1)=HLX(1)
93 I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
94 Q HLIND1
95 ;
96RDBLK ;
97 ; initialize
98 S HLBUFF=""
99 ;
100 ;S HLDB=HLDBSIZE-$L(HLX)
101 ; store the total length of HLX and HLX(1) in HLDB(1)
102 S HLDB(1)=$L(HLX)+$L(HLX(1))
103 ;
104 ;**132 **
105 ;U IO R X#HLDB:HLDREAD
106 ; U IO R X#HLDB:MAXWAIT
107 ;
108 ; remove the readcount to speedup GT.M
109 U IO
110 R:(HLDB(1)<HLDBSIZE) HLBUFF:MAXWAIT
111 ;
112 I HLBUFF]"" D
113 . I HLBUFF[HLDSTRT,(HLBUFF("START")=0) D
114 .. ; remove the extraneous text prefixing the "START" char
115 .. I $P(HLBUFF,HLDSTRT)]"" S HLBUFF=HLDSTRT_$P(HLBUFF,HLDSTRT,2,99)
116 .. S HLBUFF("START")=1
117 . ;
118 . I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1
119 ; detect disconnect for GT.M
120 I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=",UREAD,"
121 ; timedout, <clean up>, quit
122 ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
123 ;I '$T,X="",HLX="" D:'HLHDR CLEAN Q
124 ; patch HL*1.6*140
125 ; I '$T,HLBUFF="",HLX="",HLX(1)="" D Q
126 I HLBUFF="",HLX="",HLX(1)="" D Q
127 . D:('HLHDR)&('HLIND1) CLEAN
128 ;add incoming line to what wasn't processed in last read
129 ;S HLX=$G(HLX)_X
130 ; get block of characters from read buffer HLBUFF
131 ; every 'for-loop' deal with one read at most, and one message at most
132 ; if HLX is not empty, loop continues even no data is read
133 ; quit, if both HLDBUFF and HLX(1) are empty, means one read is done
134 ; quit, when HLRDOUT is set to 1, means one message is encountered
135 ; an "end"
136 ; F D Q:HLXX=""!(HLRDOUT)
137 F D Q:(HLRDOUT)!(HLBUFF=""&(HLX(1)=""))
138 . ;
139 . ; if HLX(1) is not empty
140 . I HLX(1)]"" D
141 .. ; hldb(2) is the number of characters extracted from hlx(1)
142 .. ; to be concatenated with hlx
143 .. S HLDB(2)=HLDBSIZE-$L(HLX)
144 .. ; hlx(2) stores the first hldb(2) characters extracted
145 .. ; from hlx(1)
146 .. S HLX(2)=$E(HLX(1),1,HLDB(2))
147 .. S HLX(1)=$E(HLX(1),HLDB(2)+1,$L(HLX(1)))
148 .. S HLX=$G(HLX)_HLX(2)
149 . ;
150 . ; if HLX(1) is empty, and HLBUFF contains data
151 . ; all the data in hlx(1) need to be extracted first
152 . I HLX(1)="",HLBUFF]"" D
153 .. S HLDB=HLDBSIZE-$L(HLX)
154 .. S HLXX=$E(HLBUFF,1,HLDB)
155 .. S HLBUFF=$E(HLBUFF,HLDB+1,$L(HLBUFF))
156 .. S HLX=$G(HLX)_HLXX
157 . ; quit when HLX is empty
158 . Q:(HLX="")
159 . ; ** 132 **
160 . ; if no segment end, HLX not full, go back for more
161 . I $L(HLX)<HLDBSIZE,HLX'[HLRS,HLX'[HLDEND Q
162 . ;add incoming line to what wasn't processed
163 . D RDBLK2
164 ;
165 ; it is possible one message is encountered an "end" and other
166 ; messages left in buffer,HLBUFF, save it in HLX for next run
167 I HLBUFF]"" D
168 . ; variable HLBUFF may remain data with size more than HLDBSIZE
169 . ; variable HLBUFF is not empty, only if the total length of
170 . ; HLX and HLX(1) is less than HLDBSIZE and HLX(1) should be
171 . ; empty when the command s hlx(1)=$g(hlx(1))_hlbuff is executed
172 . ; use hlx(1) to store the data of hlbuff to avoid "MAXTRING" error
173 . S HLX(1)=$G(HLX(1))_HLBUFF
174 . S HLBUFF=""
175 Q
176 ;
177RDBLK2 ;data stream: <sb>dddd<cr><eb><cr>
178 ; HL*1.6*122 end
179 ; look for segment= <CR>
180 F Q:HLX'[HLRS D Q:HLRDOUT
181 . ; Get the first piece, save the rest of the line
182 . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
183 . ; check for start block, Quit if no ien
184 . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q
185 .. S HLRS("START-FLAG")=1 ; HL*1.6*122
186 .. D:HLMSG(HLINE,0)[HLDSTRT
187 ... S X=$L(HLMSG(HLINE,0),HLDSTRT)
188 ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
189 ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
190 ... D RESET:(HLINE>1)
191 .. ;
192 .. ; patch HL*1.6*122
193 .. ; if the first line less than 10 characters
194 .. I HLHDR,$L(HLMSG(1,0))<10,$D(HLMSG(2,0)) D
195 ... S HLMSG(1,0)=HLMSG(1,0)_$E(HLMSG(2,0),1,10)
196 ... S HLMSG(2,0)=$E(HLMSG(2,0),11,9999999)
197 .. ;
198 .. ;ping message
199 .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
200 .. ; get next ien to store
201 .. D MIEN^HLCSTCP4
202 .. K HLMSG
203 .. S (HLINE,HLHDR)=0
204 . ; check for end block; <eb><cr>
205 . I HLMSG(HLINE,0)[HLDEND D
206 .. ; patch HL*1.6*122 start
207 .. ;no msg. ien
208 .. ; Q:'HLIND1
209 .. I 'HLIND1 D CLEAN Q
210 .. ; Kill just the last line if no data before HLDEND
211 .. I $P(HLMSG(HLINE,0),HLDEND)']"" D
212 ... K HLMSG(HLINE,0) S HLINE=HLINE-1
213 .. E S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDEND)
214 .. ; patch HL*1.6*122 end
215 .. ;
216 .. ; move into 772
217 .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
218 .. ;mark that end block has been received
219 .. ;HLIND1=ien in 773^ien in 772^1 if end block was received
220 .. S $P(HLIND1,U,3)=1
221 .. S HLBUFF("HLIND1")=HLIND1
222 .. ;reset variables for next message
223 .. D CLEAN
224 . ;add blank line for carriage return
225 . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
226 Q:HLRDOUT
227 ;If the line is long and no <CR> move it into the array.
228 I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q
229 . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
230 ;have start block but no record separator
231 I HLX[HLDSTRT D Q
232 . ;check for more than 1 start block
233 . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
234 . ;
235 . ; patch HL*1.6*122
236 . ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
237 . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
238 . ;
239 . D RESET:(HLHDR&(HLINE>1))
240 ;if no ien, reset
241 ; patch HL*1.6*122
242 ; I 'HLIND1 D CLEAN Q
243 I (HLRS("START-FLAG")=1),'HLIND1 D CLEAN Q
244 ; big message-merge from local to global every 100 lines
245 I (HLINE-$O(HLMSG(0)))>100 D
246 . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
247 . ; reset working array
248 . K HLMSG
249 Q
250 ;
251SAVE(SRC,DEST) ;save into global & set top node
252 ;SRC=source array (passed by ref.), DEST=destination global
253 ;
254 ; patch HL*1.6*122: MPI-client/server
255 I DEST["HLMA" D
256 . F L +^HLMA(+HLIND1):10 Q:$T H 1
257 E D
258 . F L +^HL(772,+$P(HLIND1,U,2)):10 Q:$T H 1
259 ;
260 M @DEST=SRC
261 S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
262 ;
263 I DEST["HLMA" L -^HLMA(+HLIND1)
264 E L -^HL(772,+$P(HLIND1,U,2))
265 ;
266 Q
267 ;
268DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
269 N DIK,DA
270 S DA=+HLMAMT,DIK="^HLMA("
271 D ^DIK
272 S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
273 D ^DIK
274 Q
275PING ;process PING message
276 S X=HLMSG(1,0)
277 ; patch HL*1.6*140, flush character- HLTCPLNK("IOF")
278 ; I X[HLDEND U IO W X,! D
279 I X[HLDEND U IO W X,HLTCPLNK("IOF") D
280 . ; switch to null device if opened to prevent 'leakage'
281 . I $G(IO(0))]"",$G(IO(0))'=IO U IO(0)
282CLEAN ;reset var. for next message
283 K HLMSG
284 S HLINE=0,HLRDOUT=1
285 Q
286 ;
287ERROR ; Error trap for disconnect error and return back to the read loop.
288 ; patch HL*1.6*122
289 ; move to routine HLCSTCP4 (splitted-size over 10000)
290 D ERROR1^HLCSTCP4
291 Q
292 ;
293CC(X) ;cleanup and close
294 D MON^HLCSTCP(X)
295 H 2
296 Q
297RESET ;reset info as a result of no end block
298 N %
299 S HLMSG(1,0)=HLMSG(HLINE,0)
300 F %=2:1:HLINE K HLMSG(%,0)
301 S HLINE=1
302 Q
Note: See TracBrowser for help on using the repository browser.