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

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

revised back to 6/30/08 version

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