source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.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: 7.2 KB
Line 
1HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;03/22/2007
2 ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5OPEN(HLCSTATE,LOGICAL) ;
6 ;This may be called either in the context of a client or a server.
7 ;For the server, there are 3 situations:
8 ; 1) The server is not concurrent. In this case the TCP device should be opened.
9 ; 2) The server is concurrent, but this process was spawned by the OS
10 ; (via a VMS TCP Service) In this case, the device should be opened
11 ; via the LOGICAL that was passed in.
12 ; 3) The server is concurrent, but this process was spawned by the
13 ; TaskMan multi-listener. In this case TaskMan already opened the
14 ; device. This case can be determined by the absence of the LOGICAL
15 ; input parameter.
16 ;
17 N IP,PORT,DNSFLAG
18 ;
19 S DNSFLAG=0 ;DNS has not been contacted for IP
20 ;
21 S:'$G(HLCSTATE("SERVER")) IP=HLCSTATE("LINK","IP")
22 S PORT=HLCSTATE("LINK","PORT")
23 S HLCSTATE("CONNECTED")=0
24 S HLCSTATE("READ HEADER")="READHDR^HLOTCP"
25 S HLCSTATE("WRITE HEADER")="WRITEHDR^HLOTCP"
26 S HLCSTATE("READ SEGMENT")="READSEG^HLOTCP"
27 S HLCSTATE("WRITE SEGMENT")="WRITESEG^HLOTCP"
28 S HLCSTATE("END MESSAGE")="ENDMSG^HLOTCP"
29 S HLCSTATE("CLOSE")="CLOSE^HLOTCP"
30 ;
31 ;spawned by TaskMan multi-listener? If so, the device has already been opened
32 I $G(HLCSTATE("SERVER")),$G(HLCSTATE("LINK","SERVER"))="1^M",$G(LOGICAL)="" D Q
33 .S HLCSTATE("DEVICE")=IO(0),HLCSTATE("FLUSH")="!",HLCSTATE("TCP BUFFER SIZE")=510
34 .S HLCSTATE("CONNECTED")=1
35 ;
36 ;if no IP, not a server, give DNS a shot
37 I '$G(HLCSTATE("SERVER")),IP="" S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")),HLCSTATE("LINK","IP")=IP Q:IP=""
38 ;
39RETRY I HLCSTATE("SYSTEM","OS")="DSM" D
40 .S HLCSTATE("TCP BUFFER SIZE")=512
41 .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
42 .E S HLCSTATE("DEVICE")=PORT
43 .S HLCSTATE("FLUSH")="!"
44 .I $G(HLCSTATE("SERVER")) D
45 ..O:$G(LOGICAL)]"" HLCSTATE("DEVICE"):(TCPDEV,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
46 ..O:$G(LOGICAL)="" HLCSTATE("DEVICE"):(TCPCHAN,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
47 ..I $T D
48 ...S HLCSTATE("CONNECTED")=1
49 ...U HLCSTATE("DEVICE"):NOECHO
50 .E D ;client
51 ..O HLCSTATE("DEVICE"):(TCPCHAN,ADDRESS=IP,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT")
52 ..I $T D
53 ...S HLCSTATE("CONNECTED")=1
54 ...U HLCSTATE("DEVICE"):NOECHO
55 E I HLCSTATE("SYSTEM","OS")="CACHE" D
56 .S HLCSTATE("FLUSH")="!"
57 .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL
58 .E S HLCSTATE("DEVICE")="|TCP|"_PORT
59 .S HLCSTATE("TCP BUFFER SIZE")=510
60 .I $G(HLCSTATE("SERVER")) D
61 ..I HLCSTATE("SERVER")="1^S" D Q
62 ...;single server (no concurrent connections)
63 ...O HLCSTATE("DEVICE"):(:PORT:"+A-S":::):HLCSTATE("OPEN TIMEOUT")
64 ...I $T D
65 ....N A
66 ....S HLCSTATE("CONNECTED")=1
67 ....U HLCSTATE("DEVICE")
68 ....F R *A:HLCSTATE("READ TIMEOUT") Q:$T I $$CHKSTOP^HLOPROC S HLCSTATE("CONNECTED")=0 D CLOSE(.HLCSTATE) Q
69 ..;
70 ..;multi-server spawned by OS - VMS TCP Services
71 ..O HLCSTATE("DEVICE")::HLCSTATE("OPEN TIMEOUT") I '$T S HLCSTATE("CONNECTED")=0 Q
72 ..S HLCSTATE("CONNECTED")=1
73 ..U HLCSTATE("DEVICE"):(::"-S")
74 ..;
75 .E D ;client
76 ..S HLCSTATE("TCP BUFFER SIZE")=510
77 ..O HLCSTATE("DEVICE"):(IP:PORT:"-S":::):HLCSTATE("OPEN TIMEOUT")
78 ..I $T D
79 ...S HLCSTATE("CONNECTED")=1
80 E D ;any other system but Cache or DSM
81 .S HLCSTATE("TCP BUFFER SIZE")=256
82 .D CALL^%ZISTCP(IP,PORT,HLCSTATE("OPEN TIMEOUT"))
83 .S HLCSTATE("CONNECTED")='POP
84 .I HLCSTATE("CONNECTED") S HLCSTATE("DEVICE")=IO
85 ;
86 ;if not connected, not the server, give DNS a shot if not tried already
87 I '$G(HLCSTATE("SERVER")),'HLCSTATE("CONNECTED"),'DNSFLAG S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")) I IP]"",IP'=HLCSTATE("LINK","IP") S HLCSTATE("LINK","IP")=IP G RETRY
88 I HLCSTATE("CONNECTED"),DNSFLAG S $P(^HLCS(870,HLCSTATE("LINK","IEN"),400),"^")=IP
89 Q
90 ;
91DNS(DOMAIN) ;
92 Q $P($$ADDRESS^XLFNSLK(DOMAIN),",")
93 ;
94WRITEHDR(HLCSTATE,HDR) ;
95 ;
96 ;insure that package buffer is empty
97 K HLCSTATE("BUFFER")
98 S HLCSTATE("BUFFER","BYTE COUNT")=0
99 S HLCSTATE("BUFFER","SEGMENT COUNT")=0
100 S HLCSTATE("FIRST WRITE")=1 ;so that FLUSH knows $X should be 0
101 ;
102 ;Start the message with <SB>, then write the header
103 N SEG
104 S SEG(1)=$C(11)_HDR(1)
105 S SEG(2)=HDR(2)
106 Q $$WRITESEG(.HLCSTATE,.SEG)
107 ;
108WRITESEG(HLCSTATE,SEG) ;
109 N I,LAST
110 S HLCSTATE("BUFFER","SEGMENT COUNT")=HLCSTATE("BUFFER","SEGMENT COUNT")+1
111 S I=0,LAST=$O(SEG(99999),-1)
112 F S I=$O(SEG(I)) Q:'I D
113 .I HLCSTATE("BUFFER","BYTE COUNT")>HLCSTATE("SYSTEM","BUFFER") D FLUSH
114 .I I=LAST S SEG(I)=SEG(I)_$C(13)
115 .S HLCSTATE("BUFFER",HLCSTATE("BUFFER","SEGMENT COUNT"),I)=SEG(I),HLCSTATE("BUFFER","BYTE COUNT")=HLCSTATE("BUFFER","BYTE COUNT")+$L(SEG(I))+20
116 Q HLCSTATE("CONNECTED")
117 ;
118FLUSH ;flushes the HL7 package buffer, and the system TCP buffer when full
119 N SEGMENT,MAX
120 S SEGMENT=0
121 S MAX=HLCSTATE("TCP BUFFER SIZE")
122 U HLCSTATE("DEVICE") I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
123 F S SEGMENT=$O(HLCSTATE("BUFFER",SEGMENT)) Q:'SEGMENT D
124 .N I S I=0
125 .F S I=$O(HLCSTATE("BUFFER",SEGMENT,I)) Q:'I D
126 ..N LINE,J
127 ..S J=$S(HLCSTATE("FIRST WRITE"):0,1:$X)
128 ..S HLCSTATE("FIRST WRITE")=0
129 ..S LINE=HLCSTATE("BUFFER",SEGMENT,I)
130 ..F Q:'(J+$L(LINE)>MAX) D
131 ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH")
132 ...S LINE=$E(LINE,(MAX-J)+1,99999)
133 ...S J=0
134 ..W:(LINE]"") LINE
135 K HLCSTATE("BUFFER")
136 S HLCSTATE("BUFFER","SEGMENT COUNT")=1
137 S HLCSTATE("BUFFER","BYTE COUNT")=0
138 S HLCSTATE("FIRST WRITE")=0
139 Q
140 ;
141READSEG(HLCSTATE,SEG) ;
142 ;
143 ;Output:
144 ; SEG - returns the segment (pass by reference)
145 ; Function returns 1 on success, 0 on failure
146 ;
147 N SUCCESS,COUNT,BUF
148 S (COUNT,SUCCESS)=0
149 K SEG
150 ;
151 ;anything left from last read?
152 S BUF=HLCSTATE("READ")
153 S HLCSTATE("READ")=""
154 I BUF]"" D ;something was left!
155 .S COUNT=1
156 .I BUF[$C(13) D Q
157 ..S SEG(1)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999)
158 ..S SUCCESS=1
159 .S SEG(1)=BUF,BUF=""
160 I 'SUCCESS U HLCSTATE("DEVICE") F R BUF:HLCSTATE("READ TIMEOUT") Q:'$T D Q:SUCCESS
161 .I BUF[$C(13) S SUCCESS=1,COUNT=COUNT+1,SEG(COUNT)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999) Q
162 .S COUNT=COUNT+1,SEG(COUNT)=BUF
163 ;
164 I SUCCESS D
165 .S HLCSTATE("READ")=BUF ;save the leftover
166 .I COUNT>1,SEG(COUNT)="" K SEG(COUNT) S COUNT=COUNT-1
167 ;Cache can return the connection status
168 E I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE)
169 ;
170 ;if the <EB> character was encountered, then there are no more segments in the message, set the end of message flag
171 I SUCCESS,SEG(COUNT)[$C(28) D
172 .K SEG
173 .S SUCCESS=0
174 .S HLCSTATE("MESSAGE ENDED")=1
175 Q SUCCESS
176 ;
177READHDR(HLCSTATE,HDR) ;
178 ;reads the next header segment in the message stream, discarding everything that comes before it
179 ;
180 N SEG,SUCCESS,J,I
181 S SUCCESS=0
182 K HDR
183 F Q:'$$READSEG(.HLCSTATE,.SEG) D Q:SUCCESS
184 .S I=0
185 .;look for the <SB>
186 .;perhaps the <SB> isn't in the first line
187 .F S I=$O(SEG(I)) Q:'I D Q:SUCCESS
188 ..I (SEG(I)'[$C(11)) K SEG(I) Q
189 ..S SEG(I)=$P(SEG(I),$C(11),2)
190 ..S SUCCESS=1
191 ..K:SEG(I)="" SEG(I)
192 I SUCCESS S (I,J)=0 F S J=$O(SEG(J)) Q:'J S I=I+1,HDR(I)=SEG(J)
193 Q SUCCESS
194 ;
195CLOSE(HLCSTATE) ;
196 CLOSE HLCSTATE("DEVICE")
197 Q
198 ;
199ENDMSG(HLCSTATE) ;
200 N SEG
201 S SEG(1)=$C(28)
202 I $$WRITESEG(.HLCSTATE,.SEG) D Q 1
203 .D FLUSH
204 .U HLCSTATE("DEVICE")
205 .W:$X @HLCSTATE("FLUSH")
206 Q 0
Note: See TracBrowser for help on using the repository browser.