source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.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: 9.5 KB
Line 
1HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004 14:43 ;03/26/2007
2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5READMSG(HLCSTATE,HLMSTATE) ;
6 ;Reads a message. The header is parsed. Does these checks:
7 ; 1) Duplicate?
8 ; 2) Wrong Receiving Facility?
9 ; 3) Can the Receiving App accept this message, based message type & event?
10 ; 4) Processing ID must match the receiving system
11 ; 5) Must have an ID
12 ; 6) Header must be BHS or MSH
13 ;
14 ;Output:
15 ; Function returns 1 if the message was read fully, 0 otherwise
16 ; HLMSTATE (pass by reference) the message. It will include the fields for the return ack in HLMSTATE("MSA")
17 ;
18 N ACK,SEG,STORE,I
19 ;
20 S STORE=1
21 Q:'$$READHDR^HLOT(.HLCSTATE,.SEG) 0
22 D SPLITHDR(.SEG)
23 ;
24 ;parse the header, stop if unsuccessful because the server cannot know what to do next
25 I '$$PARSEHDR^HLOPRS(.SEG) D Q 0
26 .S HLCSTATE("MESSAGE ENDED")=0
27 .D CLOSE^HLOT(.HLCSTATE)
28 D NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG)
29 I HLMSTATE("ID")="" D
30 .S STORE=0
31 .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" S HLMSTATE("MSA",1)="CE",HLMSTATE("MSA",3)="CONTROL ID MISSING"
32 I STORE,$$DUP(.HLMSTATE) S STORE=0
33 ;
34 ;if the message is not to be stored, just read it and discard the segments
35 I 'STORE D
36 .F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG)
37 ;
38 E D
39 .N FS
40 .S FS=HLMSTATE("HDR","FIELD SEPARATOR")
41 .F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG) D
42 ..N MSA,SEGTYPE,OLDMSGID,CODE,IEN,NEWMSGID,TEXT
43 ..S SEGTYPE=$E($E(SEG(1),1,3)_$E($G(SEG(2)),1,2),1,3)
44 ..I SEGTYPE="MSA" D
45 ...S MSA=SEG(1)_$G(SEG(2))_$G(SEG(3))
46 ...S OLDMSGID=$P(MSA,FS,3),CODE=$P(MSA,FS,2),TEXT=$E($P(MSA,FS,4),1,30)
47 ...I $E(CODE,1)'="A" S SEGTYPE="" Q
48 ...S:$P(OLDMSGID,"-")]"" IEN=$O(^HLB("B",$P(OLDMSGID,"-"),0))
49 ...S:$G(IEN) IEN=IEN_"^"_$P(OLDMSGID,"-",2)
50 ..I 'HLMSTATE("BATCH") D
51 ...D:SEGTYPE="MSA"
52 ....S HLMSTATE("ACK TO")=OLDMSGID
53 ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
54 ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"AE")
55 ....S:$D(IEN) HLMSTATE("ACK TO","IEN")=IEN
56 ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT
57 ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
58 ..E D ;batch
59 ...I SEGTYPE="MSH" D
60 ....D SPLITHDR(.SEG)
61 ....S NEWMSGID=$P(SEG(2),FS,5)
62 ....D ADDMSG2^HLOMSG(.HLMSTATE,.SEG)
63 ...E D ;not MSH
64 ....D:SEGTYPE="MSA"
65 .....N SUBIEN S SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE")
66 .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
67 .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
68 .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"AE")
69 .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
70 ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
71 .I HLMSTATE("UNSTORED LINES"),HLCSTATE("MESSAGE ENDED"),$$SAVEMSG^HLOF778(.HLMSTATE)
72 ;
73 I STORE,'HLCSTATE("MESSAGE ENDED") D
74 .;reading failed, don't store
75 .D:HLMSTATE("IEN") DEL778(HLMSTATE("IEN")) D:HLMSTATE("BODY") DEL777(HLMSTATE("BODY"))
76 .S HLMSTATE("IEN")="",HLMSTATE("BODY")=""
77 E D:STORE
78 .D CHECKMSG(.HLMSTATE)
79 .D ADDAC(.HLMSTATE) ;so future duplicates are detected
80 .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
81 ;
82 D:'HLCSTATE("MESSAGE ENDED") CLOSE^HLOT(.HLCSTATE)
83 Q HLCSTATE("MESSAGE ENDED")
84 ;
85ADDAC(HLMSTATE) ;adds the AC xref for duplicates detection
86 ;
87 N FROM
88 S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
89 S ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))=""
90 Q
91 ;
92DUP(HLMSTATE) ;
93 ;Returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise
94 ;Input:
95 ; HLMSTATE (pass by reference) the message being read
96 ;Output:
97 ; Function returns 1 if the message is a duplicate, 0 otherwise
98 ; HLMSTATE (pass by reference) IF the message is a duplicate:
99 ; returns the prior MSA segment in HLMSTATE("MSA")
100 ;
101 N IEN,FROM,DUP
102 S (IEN,DUP)=0
103 ;
104 ;no way to determine! Bad header will be rejected
105 Q:(HLMSTATE("ID")="") 0
106 ;
107 S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
108 F S IEN=$O(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN)) Q:'IEN D Q:DUP
109 .I HLMSTATE("HDR","ACCEPT ACK TYPE")="NE" S DUP=1 Q
110 .;need the MSA to return
111 .D Q
112 ..N NODE
113 ..S NODE=$P($G(^HLB(IEN,4)),"^",3,10)
114 ..S HLMSTATE("MSA",1)=$P(NODE,"|",2)
115 ..Q:$L(HLMSTATE("MSA",1))'=2
116 ..S HLMSTATE("MSA",2)=$P(NODE,"|",3)
117 ..S HLMSTATE("MSA",3)=$P(NODE,"|",4,10)
118 ..S DUP=1
119 ;
120 Q DUP
121 ;
122CHECKMSG(HLMSTATE) ;
123 ;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set
124 ;Input:
125 ; HLMSTATE("HDR") - the parsed header segment
126 ;Output:
127 ; HLMSTATE("STATUS")="SE" if an error is detected
128 ; HLMSTATE("STATUS","QUEUE") queue to put the message on
129 ; HLMSTATE("STATUS","ACTION") <tag^rtn> that is the processing routine for the receiving application
130 ; HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt
131 ;
132 N WANTACK,PASS,ACTION,QUEUE,ERROR
133 M HDR=HLMSTATE("HDR")
134 S ERROR=0
135 I HDR("ACCEPT ACK TYPE")="NE",'HLMSTATE("ORIGINAL MODE") D
136 .S WANTACK=0
137 E D
138 .S WANTACK=1
139 I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="SE" Q
140 I $G(HLMSTATE("ACK TO"))="" D Q:ERROR
141 .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="SE" Q
142 .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
143 E D Q:ERROR ;this is an app ack
144 .;does the original message exist?
145 .N NODE
146 .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0))
147 .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
148 .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
149 .I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT") Q
150 .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
151 .I HLMSTATE("HDR","MESSAGE TYPE")="ACK",HLMSTATE("HDR","EVENT")="" S HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO","IEN"))
152 .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
153 ;
154 I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
155 ;
156 ;wrong receiving facility? This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number.
157 S PASS=0
158 D
159 .;if its an ack to an existing message, don't check the receiving facility
160 .I $G(HLMSTATE("ACK TO"))]"" S PASS=1 Q
161 .I HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION") S PASS=1 Q
162 .I HDR("RECEIVING FACILITY",3)'="DNS" S PASS=1 Q
163 .I HDR("RECEIVING FACILITY",2)="" S PASS=1 Q
164 .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q
165 .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q
166 I 'PASS S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
167 I PASS,WANTACK S HLMSTATE("MSA",1)="CA"
168 Q
169 ;
170DEL777(IEN777) ;delete a record from file 777 where the read did not complete
171 ;
172 K ^HLA(IEN777,0)
173 Q
174DEL778(IEN778) ;delete a record from file 778 where the read did not complete
175 ;
176 K ^HLB(IEN778,0)
177 Q
178 ;
179SPLITHDR(HDR) ;
180 ;splits hdr segment into two lines, first being just components 1-6
181 ;
182 N TEMP,FS
183 D SQUISH(.HDR)
184 S FS=$E($G(HDR(1)),4)
185 S TEMP(1)=$P($G(HDR(1)),FS,1,6)
186 S TEMP(2)=""
187 I $L(TEMP(1))<$L($G(HDR(1))) S TEMP(2)=FS_$P($G(HDR(1)),FS,7,20)
188 S HDR(2)=TEMP(2)_$G(HDR(2))
189 S HDR(1)=TEMP(1)
190 Q
191 ;
192SQUISH(SEG) ;
193 ;reformat the segment array into full lines
194 ;
195 ;nothing to do if less than 2 lines
196 Q:'$O(SEG(1))
197 ;
198 N A,I,J,K,MAX,COUNT,LEN
199 S MAX=$S($G(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256)
200 S (COUNT,I)=0,J=1
201 F S I=$O(SEG(I)) Q:'I D
202 .S LEN=$L(SEG(I))
203 .F K=1:1:LEN D
204 ..S A(J)=$G(A(J))_$E(SEG(I),K)
205 ..S COUNT=COUNT+1
206 ..I (COUNT>(MAX-1)) S COUNT=0,J=J+1
207 K SEG
208 M SEG=A
209 Q
210 ;
211ERROR ;error trap
212 S $ETRAP="Q:$QUIT """" Q"
213 D END^HLOSRVR
214 ;
215 ;concurrent server connections (multi-listener) should stop execution, only a single server may continue
216 I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D Q:$QUIT "" Q
217 .;don't log these common errors
218 .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
219 ..;
220 .E D
221 ..D ^%ZTER
222 ;
223 ;while debugging quit on all errors
224 I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q
225 ;
226 ;a lot of errors of the same time may indicate an endless loop, so keep a count and quit if large count
227 N HOUR
228 S HOUR=$E($$NOW^XLFDT,1,10)
229 ;
230 I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
231 ;
232 ;resume execution for the single listener
233 S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
234 D UNWIND^%ZTER
235 Q
Note: See TracBrowser for help on using the repository browser.