source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m@ 1008

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

initial load of FOIAVistA 6/30/08 version

File size: 9.4 KB
Line 
1HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004 14:43 ;07/17/2007
2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21
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:"ER")
55 ....I $G(IEN) D
56 .....S HLMSTATE("ACK TO","IEN")=IEN
57 .....S HLMSTATE("ACK TO","SEQUENCE QUEUE")=$P($G(^HLB(+IEN,5)),"^")
58 ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT
59 ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
60 ..E D ;batch
61 ...I SEGTYPE="MSH" D
62 ....D SPLITHDR(.SEG)
63 ....S NEWMSGID=$P(SEG(2),FS,5)
64 ....D ADDMSG2^HLOMSG(.HLMSTATE,.SEG)
65 ...E D ;not MSH
66 ....D:SEGTYPE="MSA"
67 .....N SUBIEN S SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE")
68 .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
69 .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
70 .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"ER")
71 .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
72 ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
73 .I HLMSTATE("UNSTORED LINES"),HLCSTATE("MESSAGE ENDED"),$$SAVEMSG^HLOF778(.HLMSTATE)
74 ;
75 I STORE,'HLCSTATE("MESSAGE ENDED") D
76 .;reading failed, don't store
77 .D:HLMSTATE("IEN") DEL778(HLMSTATE("IEN")) D:HLMSTATE("BODY") DEL777(HLMSTATE("BODY"))
78 .S HLMSTATE("IEN")="",HLMSTATE("BODY")=""
79 E D:STORE
80 .D CHECKMSG(.HLMSTATE)
81 .D ADDAC(.HLMSTATE) ;so future duplicates are detected
82 .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
83 ;
84 D:'HLCSTATE("MESSAGE ENDED") CLOSE^HLOT(.HLCSTATE)
85 Q HLCSTATE("MESSAGE ENDED")
86 ;
87ADDAC(HLMSTATE) ;adds the AC xref for duplicates detection
88 ;
89 N FROM
90 S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
91 S ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))=""
92 Q
93 ;
94DUP(HLMSTATE) ;
95 ;Returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise
96 ;Input:
97 ; HLMSTATE (pass by reference) the message being read
98 ;Output:
99 ; Function returns 1 if the message is a duplicate, 0 otherwise
100 ; HLMSTATE (pass by reference) IF the message is a duplicate:
101 ; returns the prior MSA segment in HLMSTATE("MSA")
102 ;
103 N IEN,FROM,DUP
104 S (IEN,DUP)=0
105 ;
106 ;no way to determine! Bad header will be rejected
107 Q:(HLMSTATE("ID")="") 0
108 ;
109 S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1))
110 F S IEN=$O(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN)) Q:'IEN D Q:DUP
111 .I HLMSTATE("HDR","ACCEPT ACK TYPE")="NE" S DUP=1 Q
112 .;need the MSA to return
113 .D Q
114 ..N NODE
115 ..S NODE=$P($G(^HLB(IEN,4)),"^",3,10)
116 ..S HLMSTATE("MSA",1)=$P(NODE,"|",2)
117 ..Q:$L(HLMSTATE("MSA",1))'=2
118 ..S HLMSTATE("MSA",2)=$P(NODE,"|",3)
119 ..S HLMSTATE("MSA",3)=$P(NODE,"|",4,10)
120 ..S DUP=1
121 ;
122 Q DUP
123 ;
124CHECKMSG(HLMSTATE) ;
125 ;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set
126 ;Input:
127 ; HLMSTATE("HDR") - the parsed header segment
128 ;Output:
129 ; HLMSTATE("STATUS")="ER" if an error is detected
130 ; HLMSTATE("STATUS","QUEUE") queue to put the message on
131 ; HLMSTATE("STATUS","ACTION") <tag^rtn> that is the processing routine for the receiving application
132 ; HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt
133 ;
134 N WANTACK,PASS,ACTION,QUEUE,ERROR
135 M HDR=HLMSTATE("HDR")
136 S ERROR=0
137 I HDR("ACCEPT ACK TYPE")="NE",'HLMSTATE("ORIGINAL MODE") D
138 .S WANTACK=0
139 E D
140 .S WANTACK=1
141 I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="ER" Q
142 I $G(HLMSTATE("ACK TO"))="" D Q:ERROR
143 .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")="ER" Q
144 .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
145 E D Q:ERROR ;this is an app ack
146 .;does the original message exist?
147 .N NODE
148 .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0))
149 .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
150 .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
151 .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
152 .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
153 .I HLMSTATE("HDR","MESSAGE TYPE")="ACK",HLMSTATE("HDR","EVENT")="" S HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO","IEN"))
154 .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
155 ;
156 I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
157 ;
158 ;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.
159 S PASS=0
160 D
161 .;if its an ack to an existing message, don't check the receiving facility
162 .I $G(HLMSTATE("ACK TO"))]"" S PASS=1 Q
163 .I HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION") S PASS=1 Q
164 .I HDR("RECEIVING FACILITY",3)'="DNS" S PASS=1 Q
165 .I HDR("RECEIVING FACILITY",2)="" S PASS=1 Q
166 .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q
167 .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q
168 I 'PASS S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
169 I PASS,WANTACK S HLMSTATE("MSA",1)="CA"
170 Q
171 ;
172DEL777(IEN777) ;delete a record from file 777 where the read did not complete
173 ;
174 K ^HLA(IEN777,0)
175 Q
176DEL778(IEN778) ;delete a record from file 778 where the read did not complete
177 ;
178 K ^HLB(IEN778,0)
179 Q
180 ;
181SPLITHDR(HDR) ;
182 ;splits hdr segment into two lines, first being just components 1-6
183 ;
184 N TEMP,FS
185 D SQUISH(.HDR)
186 S FS=$E($G(HDR(1)),4)
187 S TEMP(1)=$P($G(HDR(1)),FS,1,6)
188 S TEMP(2)=""
189 I $L(TEMP(1))<$L($G(HDR(1))) S TEMP(2)=FS_$P($G(HDR(1)),FS,7,20)
190 S HDR(2)=TEMP(2)_$G(HDR(2))
191 S HDR(1)=TEMP(1)
192 Q
193 ;
194SQUISH(SEG) ;
195 ;reformat the segment array into full lines
196 ;
197 ;nothing to do if less than 2 lines
198 Q:'$O(SEG(1))
199 ;
200 N A,I,J,K,MAX,COUNT,LEN
201 S MAX=$S($G(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256)
202 S (COUNT,I)=0,J=1
203 F S I=$O(SEG(I)) Q:'I D
204 .S LEN=$L(SEG(I))
205 .F K=1:1:LEN D
206 ..S A(J)=$G(A(J))_$E(SEG(I),K)
207 ..S COUNT=COUNT+1
208 ..I (COUNT>(MAX-1)) S COUNT=0,J=J+1
209 K SEG
210 M SEG=A
211 Q
212 ;
213ERROR ;error trap
214 S $ETRAP="Q:$QUIT """" Q"
215 D END^HLOSRVR
216 ;
217 ;multi-listener should stop execution, only a single server may continue
218 I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D Q:$QUIT "" Q
219 .;don't log these errors
220 .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
221 ..;
222 .E D
223 ..D ^%ZTER
224 ;
225 ;debugging?
226 I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q
227 ;
228 ;possibly an endless loop?
229 N HOUR
230 S HOUR=$E($$NOW^XLFDT,1,10)
231 I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
232 ;
233 ;resume execution for the single listener
234 S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
235 D UNWIND^%ZTER
236 Q
Note: See TracBrowser for help on using the repository browser.