source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m@ 810

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

initial load of FOIAVistA 6/30/08 version
File size: 9.0 KB
Line 
1HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;07/19/2007
2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5GETWORK(WORK) ;
6 ;GET WORK function for a single server or a Taskman multi-server
7 N LINK
8 I '$$CHKSTOP^HLOPROC,$G(WORK("LINK"))]"",$$GETLINK^HLOTLNK(WORK("LINK"),.LINK),+LINK("SERVER") S WORK("PORT")=LINK("PORT") Q 1
9 Q 0
10 ;
11DOWORKS(WORK) ;
12 ;DO WORK rtn for a single server (non-concurrent)
13 D SERVER(WORK("LINK"))
14 Q
15DOWORKM(WORK) ;
16 ;DO WORK rtn for a Taskman multi-server (Cache systems only)
17 D LISTEN^%ZISTCPS(WORK("PORT"),"SERVER^HLOSRVR("""_WORK("LINK")_""")")
18 Q
19 ;
20VMS2(LINKNAME) ;called from a VMS TCP Service once a connection request has been received. This entry point should be used only if an additional VMS TCPIP Services are being created for HLO.
21 ;Input:
22 ; LINKNAME - only pass it in if an additional service is being created on a different port
23 Q:'$L(LINKNAME)
24 D VMS
25 Q
26 ;
27VMS ;Called from VMS TCP Service once a connection request has been received. This entry point should be used only by the standard HLO service that runs on the standard HLO port.
28 Q:$$CHKSTOP^HLOPROC
29 D
30 .Q:$L($G(LINKNAME))
31 .;
32 .N PROC,NODE
33 .S PROC=$O(^HLD(779.3,"B","VMS TCP LISTENER",0))
34 .I PROC S LINKNAME=$P($G(^HLD(779.3,PROC,0)),"^",14) Q:$L(LINKNAME)
35 .S NODE=$G(^HLD(779.1,1,0)) I $P(NODE,"^",10) S LINKNAME=$P($G(^HLCS(870,$P(NODE,"^",10),0)),"^") Q:$L(LINKNAME)
36 .S LINKNAME="HLO DEFAULT LISTENER"
37 ;
38 D SERVER(LINKNAME,"SYS$NET")
39 Q
40 ;
41SERVER(LINKNAME,LOGICAL) ; LINKNAME identifies the logical link, which describes the communication channel to be used
42 N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR1"
43 N HLCSTATE,INQUE
44 S INQUE=0
45 Q:'$$CONNECT(.HLCSTATE,LINKNAME,.LOGICAL)
46 K LINKNAME
47 F Q:'HLCSTATE("CONNECTED") D Q:$$CHKSTOP^HLOPROC
48 .N HLMSTATE,SENT
49 .;
50 .;read msg and parse the hdr
51 .;HLMSTATE("MSA",1) is set with type of ack to return
52 .I $$READMSG^HLOSRVR1(.HLCSTATE,.HLMSTATE) D
53 ..;
54 ..;send an ack if required and save the MSA segment
55 ..I (HLMSTATE("MSA",1)]"") S SENT=$$WRITEACK(.HLCSTATE,.HLMSTATE) D:HLMSTATE("IEN") SAVEACK(.HLMSTATE,SENT)
56 ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE)
57 ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
58 ..I $G(HLMSTATE("ACK TO","IEN")),$L($G(HLMSTATE("ACK TO","SEQUENCE QUEUE"))) D ADVANCE^HLOQUE(HLMSTATE("ACK TO","SEQUENCE QUEUE"),+HLMSTATE("ACK TO","IEN"))
59 .E D INQUE() H:HLCSTATE("CONNECTED") 1
60 ;
61END D CLOSE^HLOT(.HLCSTATE)
62 D INQUE()
63 D SAVECNTS^HLOSTAT(.HLCSTATE)
64 Q
65 ;
66CONNECT(HLCSTATE,LINKNAME,LOGICAL) ;
67 ;sets up HLCSTATE() and opens a server connection
68 ;
69 N LINK,NODE
70 S HLCSTATE("CONNECTED")=0
71 Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINK) 0
72 Q:+LINK("SERVER")'=1 0
73 S HLCSTATE("SERVER")=LINK("SERVER")
74 M HLCSTATE("LINK")=LINK
75 S HLCSTATE("READ TIMEOUT")=20
76 S HLCSTATE("OPEN TIMEOUT")=30
77 S HLCSTATE("READ")="" ;buffer for reads
78 ;
79 ;HLCSTATE("BUFFER",<seg>,<line>) write buffer
80 S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of bytes in buffer
81 S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer
82 ;
83 S HLCSTATE("COUNTS")=0
84 S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag
85 S NODE=^%ZOSF("OS")
86 S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"")
87 Q:HLCSTATE("SYSTEM","OS")="" 0
88 D ;get necessary system parameters
89 .N SYS,SUB
90 .D SYSPARMS^HLOSITE(.SYS)
91 .F SUB="MAXSTRING","DOMAIN","STATION","PROCESSING ID","NORMAL PURGE","ERROR PURGE" S HLCSTATE("SYSTEM",SUB)=SYS(SUB)
92 .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER")
93 I HLCSTATE("LINK","LLP")="TCP" D
94 .D OPEN^HLOTCP(.HLCSTATE,.LOGICAL)
95 E ;no other LLP implemented
96 ;
97 Q HLCSTATE("CONNECTED")
98 ;
99INQUE(MSGIEN,PARMS) ;
100 ;puts received messages on the incoming queue and sets the B x-refs
101 I $G(MSGIEN) S INQUE=INQUE+1 M INQUE(MSGIEN)=PARMS
102 I ('$G(MSGIEN))!(INQUE>20) S MSGIEN=0 D
103 .F S MSGIEN=$O(INQUE(MSGIEN)) Q:'MSGIEN D
104 ..S ^HLB("B",INQUE(MSGIEN,"MSGID"),MSGIEN)=""
105 ..S ^HLA("B",INQUE(MSGIEN,"DT/TM"),INQUE(MSGIEN,"BODY"))=""
106 ..D:INQUE(MSGIEN,"PASS")
107 ...N PURGE
108 ...S PURGE=+$G(INQUE(MSGIEN,"PURGE"))
109 ...S PURGE("ACKTOIEN")=$G(INQUE(MSGIEN,"ACKTOIEN"))
110 ...D INQUE^HLOQUE(INQUE(MSGIEN,"FROM"),INQUE(MSGIEN,"QUEUE"),MSGIEN,INQUE(MSGIEN,"ACTION"),.PURGE)
111 .K INQUE S INQUE=0
112 Q
113 ;
114SAVEACK(HLMSTATE,SENT) ;
115 ;Input:
116 ; SENT - flag = 1 if transmission of ack succeeded, 0 otherwise
117 ;
118 N NODE,I
119 S $P(NODE,"^")=HLMSTATE("MSA","DT/TM OF MESSAGE")
120 S $P(NODE,"^",2)=HLMSTATE("MSA","MESSAGE CONTROL ID")
121 S $P(NODE,"^",3)="MSA"
122 F I=1:1:3 S NODE=NODE_"|"_$G(HLMSTATE("MSA",I))
123 S ^HLB(HLMSTATE("IEN"),4)=NODE
124 S:SENT $P(^HLB(HLMSTATE("IEN"),0),"^",$S($E(HLMSTATE("MSA",1))="A":18,1:17))=1
125 Q
126 ;
127UPDATE(HLMSTATE,HLCSTATE) ;
128 ;Updates status and purge date when appropriate
129 ;Also, sets the "B" xrefs, files 777,778, and places message on the incoming queue
130 ;
131 N PARMS,PURGE,WAIT
132 S PARMS("PASS")=0
133 I HLMSTATE("STATUS","ACTION")]"",HLMSTATE("STATUS")'="SE" D
134 .N IEN
135 .S IEN=HLMSTATE("IEN")
136 .S PARMS("PASS")=1,$P(^HLB(IEN,0),"^",6)=HLMSTATE("STATUS","QUEUE"),$P(^HLB(IEN,0),"^",10)=$P(HLMSTATE("STATUS","ACTION"),"^"),$P(^HLB(IEN,0),"^",11)=$P(HLMSTATE("STATUS","ACTION"),"^",2)
137 D:'PARMS("PASS") ;if not passing to the app, set the purge date
138 .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU"
139 .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE")
140 .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="ER"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="ER":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
141 .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT)
142 .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE
143 .S ^HLB("AD","IN",PURGE,HLMSTATE("IEN"))=""
144 .;if this is an app ack, purge the original message at the same time
145 .I $G(HLMSTATE("ACK TO","IEN")),'HLMSTATE("BATCH") D
146 ..S $P(^HLB(+HLMSTATE("ACK TO","IEN"),0),"^",9)=PURGE
147 ..S ^HLB("AD","IN",PURGE,+HLMSTATE("ACK TO","IEN"))=""
148 ;
149 ;if not waiting for an application ack, set the status now even if passing to the app - but don't set the purge until the infiler passes the message
150 I HLMSTATE("STATUS")="",($G(HLMSTATE("ACK TO","IEN"))!HLMSTATE("HDR","APP ACK TYPE")'="AL") S HLMSTATE("STATUS")="SU"
151 I HLMSTATE("STATUS")'="" S $P(^HLB(HLMSTATE("IEN"),0),"^",20)=HLMSTATE("STATUS") S:$G(HLMSTATE("MSA",3))]"" $P(^HLB(HLMSTATE("IEN"),0),"^",21)=HLMSTATE("MSA",3) D:HLMSTATE("STATUS")="SE"
152 .N APP
153 .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
154 .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
155 ;
156 ;set the necessary parms for passing the msg to the app via the infiler
157 D:PARMS("PASS")
158 .N I,FROM
159 .S FROM=HLMSTATE("HDR","SENDING FACILITY",1)
160 .I HLMSTATE("HDR","SENDING FACILITY",2)]"" S FROM=FROM_"~"_HLMSTATE("HDR","SENDING FACILITY",2)_"~"_HLMSTATE("HDR","SENDING FACILITY",3)
161 .I FROM="" S FROM="UNKNOWN SENDING FACILITY"
162 .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION")
163 .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")="ER":2,$G(HLMSTATE("ACK TO","STATUS"))="ER":2,1:1)
164 .S:$G(HLMSTATE("ACK TO","IEN")) PARMS("ACKTOIEN")=HLMSTATE("ACK TO","IEN") ;to insure that the infiler will know to set the purge date at the same time as the initial message
165 ;
166 S PARMS("BODY")=HLMSTATE("BODY")
167 S PARMS("DT/TM")=HLMSTATE("DT/TM")
168 S PARMS("MSGID")=HLMSTATE("ID")
169 D INQUE(HLMSTATE("IEN"),.PARMS)
170 Q
171 ;
172WRITEACK(HLCSTATE,HLMSTATE) ;
173 ;Sends an accept ack
174 ;
175 ;Input:
176 ; HLCSTATE (pass by reference) defines the communication channel
177 ; HLMSTATE (pass by reference) the message being acked
178 ; ("MSA",1) - value for MSA-1
179 ; ("MSA",2) - value for MSA-2
180 ; ("MSA",3) - value for MSA-3
181 ; ("HDR") - parsed values for the message being ack'd
182 ;Output:
183 ; Function returns 1 if successful, 0 otherwise
184 ; HLMSTATE("MSA","MESSAGE CONTROL ID") - the msg id of the ack
185 ; HLMSTATE(,"MSA","DT/TM OF MESSAGE") - from the ack header
186 ;
187 N HDR,SUB,FS,CS,MSA,ACKID,TIME
188 ;Hard-code the delimiters, the standard requires that the receiving system accept the delimiters listed in the header
189 S FS="|"
190 S CS="^"
191 S TIME=$$NOW^XLFDT
192 S HLMSTATE("MSA","DT/TM OF MESSAGE")=TIME
193 S ACKID=HLCSTATE("SYSTEM","STATION")_" "_$$NEWIEN^HLOF778A("OUT")
194 S HLMSTATE("MSA","MESSAGE CONTROL ID")=ACKID
195 ;
196 S HDR(1)="MSH"_FS_"^~\&"_FS_HLMSTATE("HDR","RECEIVING APPLICATION")_FS_HLCSTATE("SYSTEM","STATION")_CS_HLCSTATE("SYSTEM","DOMAIN")_CS_"DNS"_FS
197 S HDR(1)=HDR(1)_HLMSTATE("HDR","SENDING APPLICATION")_FS_HLMSTATE("HDR","SENDING FACILITY",1)_CS_HLMSTATE("HDR","SENDING FACILITY",2)_CS_HLMSTATE("HDR","SENDING FACILITY",3)
198 ;
199 S HDR(2)=FS_$$HLDATE^HLFNC(TIME,"TS")_FS_FS_"ACK"_FS_ACKID_FS_HLMSTATE("HDR","PROCESSING ID")_FS_"2.4"_FS_FS_FS_"NE"_FS_"NE"
200 ;
201 S MSA(1)="MSA"_FS
202 F SUB=1:1:3 S MSA(1)=MSA(1)_HLMSTATE("MSA",SUB)_FS
203 I $$WRITEHDR^HLOT(.HLCSTATE,.HDR),$$WRITESEG^HLOT(.HLCSTATE,.MSA),$$ENDMSG^HLOT(.HLCSTATE) S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1 Q 1
204 S HLMSTATE("MSA","DT/TM OF MESSAGE")=""
205 Q 0
Note: See TracBrowser for help on using the repository browser.