source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 9.3 KB
Line 
1HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;10/05/2007 15:17
2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133,122**;Oct 13, 1995;Build 14
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6NEW(X) ;process new msg. ien in 773^ien in 772
7 ;HLMTIENS=ien in #773; HLMTIEN=ien in #772
8 ;HLHDRO=original header; HLHDR=response header
9 ;set error trap
10 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
11 N HL,HLEID,HLEIDS,HLERR,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLQUIT,HLNODE,HLNEXT,HLRESLTA,HLDONE1,HLASTRSP,HLRESLT
12 S HLRESLT=""
13 D INIT^HLTP3A
14 ;error with header, return commit/app reject
15 I $G(HLRESLT) D Q
16 . ;set status & unlock record
17 . D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
18 . ;quit if no commit or app ack
19 . I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" Q
20 . S X=$S($G(HL("ACAT"))="AL":"CR",1:"AR")
21 . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4
22 . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP)
23 . ;write ack back
24 . S X=$$WRITE^HLCSTCP2(HLTCP)
25 . ;update counter to sent
26 . D LLCNT^HLCSTCP(HLDP,4)
27 . ;update status of ack
28 . D STATUS^HLTF0(HLTCP,3,,,1)
29 ;
30 ;check for duplicate msg., use rec. app and msg. id x-ref
31 ; patch HL*1.6*120
32 I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS)
33 . ;HLASTMSG=last ien received during this connection
34 . ;if no duplicate, save msg. ien and quit
35 . I X=HLMTIENS!'X S HLASTMSG=HLMTIENS Q
36 . N MSH,OIENS
37 . S (OIENS,Y)=X D S Y=HLMTIENS D
38 .. ;combine MSH into single string
39 .. S MSH(Y)="",I=0 F S I=$O(^HLMA(Y,"MSH",I)) Q:'I S MSH(Y)=MSH(Y)_$G(^(I,0))
40 .; patch 117 & 125, check if identical
41 .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q
42 .;
43 . ;msg is duplicate, set status
44 . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT
45 . ;msg was resent, ignore it.
46 . I HLASTMSG=HLMTIENS K HLMTIENS Q
47 . ;find original response and send back
48 . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS))
49 ;
50 ;Quit if this is ack to ack
51 I $G(HL("ACK")) D Q
52 . ;Update status of original ack message
53 . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1)
54 . ;unlock record
55 . D EXIT
56 ;
57 ;enhance ack., send commit, quit if not an ack, msg will be processed by filer
58 I $G(HL("ACAT"))="AL" D Q:'$G(HL("MTIENS"))
59 . ;msg is a resend, HLASTRSP=ien of original response
60 .I $G(HLASTRSP) D
61 ..S HLTCP=HLASTRSP
62 ..D LLCNT^HLCSTCP(HLDP,3)
63 . E D Q:'$G(HLTCP)
64 ..D ACK^HLTP4("CA") ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4
65 . S X=$$WRITE^HLCSTCP2(HLTCP)
66 . D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP)
67 . S HLTCP=""
68 . ;if not an ack, set status to awaiting processing **109** and put on in queue
69 . I '$G(HL("MTIENS")),'$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31
70 ;
71 ;enhance ack., no commit & no app ack
72 I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" D Q
73 . ;set status to awaiting processing, **109** and put on in queue
74 . I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31
75 ;
76 ; patch HL*1.6*120 start
77 ;resending old response, msg is a resend
78 ; do not re-send duplicate when $G(HL("ACAT"))="AL"
79 I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK
80 ; quit if duplicate
81 Q:$G(HLASTRSP)
82 ; patch HL*1.6*120 end
83 ;
84CONT ;continue processing an enhance ack msg. called from DEFACK
85 ;Set special HL variables for processing rtn
86 S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
87 ;
88 ; message is an acknowledgement, HLMSA=ack code^id^text
89 I ($G(HLMSA)]"") D Q
90 . ;X=1 if ack ok, 0=reject of error
91 . S X=$E(HLMSA,2)="A"
92 . ;Update status of original message and remove it from the queue
93 . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1)
94 . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS"))
95 . D
96 .. N HLTCP ;variable to update status in file #772.
97 ..;
98 ..;**108**
99 .. N TEMP
100 .. S TEMP=HLMTIENS
101 .. N HLMTIENS
102 .. S HLMTIENS=TEMP
103 ..;**END 108**
104 ..;
105 .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
106 . ;update status of incoming & unlock
107 . D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT
108 ;
109 ;get entry action, exit action and processing routine
110 K HLHDR,HLLD0,HLLD1,HLMSA
111 I HL("EIDS")="",$G(HLEIDS)]"" S HL("EIDS")=HLEIDS ;**CIRN**
112 D EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN)
113 S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)),HLPROU=$G(HLN(771))
114 ;quit if no processing routine,update status and quit
115 I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) D STATUS^HLTF0(HLMTIENS,3,,,1),EXIT Q
116 ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
117 N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101,"
118 ;Execute entry action of client protocol
119 X:HLENROU]"" HLENROU K HLENROU,HLDONE1
120 ;
121 ;Execute processing routine
122 X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_HLERR
123 ;update status of incoming to complete & unlock
124 D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT
125 ;HLTCPO=link open, HLTCP=ien of ack msg. from GENACK
126ACK I $G(HLTCPO),$G(HLTCP) D Q
127 . D LLCNT^HLCSTCP(HLDP,3)
128 . ;write ack back over open tcp link
129 . S X=$$WRITE^HLCSTCP2(HLTCP)
130 . ;update status of ack to complete
131 . D:'$G(HLASTRSP) STATUS^HLTF0(HLTCP,3,,,1)
132 . D LLCNT^HLCSTCP(HLDP,4)
133 Q
134 ;
135DEFACK(HLDP,X) ;process the deferred application ack, called from HLCSIN
136 ;HLDP=logical link, X=ien in file 773
137 ;
138 ; patch HL*1.6*120 start
139 ; clean non-Kernel variables
140 D
141 . ; protect variables defined in STARTIN^HLCSIN
142 . N HLFLG,HLEXIT,HLPTRFLR
143 . ; protect variables defined in DEFACK^HLCSIN
144 . N HLXX,HLD0,HLPCT
145 . ; protect input parameters of this sub-routine
146 . N HLDP,X
147 . D KILL^XUSCLEAN
148 ; patch HL*1.6*120 end
149 ;
150 ;set error trap
151 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
152 N HLERR ;patch HL*1.6*109
153 Q:'$G(HLDP)!'$G(X) Q:'$G(^HLMA(X,0))
154 Q:'$D(^HLMA("AC","I",HLDP,X))
155 ;
156 N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1
157 S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")=""""""
158 S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14)
159 S:$P(X,U,15) HL("MTP_ETP")=$P(X,U,15)
160 S:HL("SAP") HL("SAN")=$P($G(^HL(771,HL("SAP"),0)),U) S:HL("RAP") HL("RAN")=$P($G(^HL(771,HL("RAP"),0)),U)
161 S:HL("MTP") HL("MTN")=$P($G(^HL(771.2,HL("MTP"),0)),U) S:HL("ETP") HL("ETN")=$P($G(^HL(779.001,HL("ETP"),0)),U)
162 S:$G(HL("MTP_ETP")) HL("MTN_ETN")=$P($G(^HL(779.005,HL("MTP_ETP"),0)),U)
163 S HL("EID")=$P($G(^HL(772,HLMTIEN,0)),U,10)
164 M HLHDRO=^HLMA(HLMTIENS,"MSH")
165 ; if no header quit
166 Q:'$O(HLHDRO(0))
167 ;
168 S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7)
169 ;
170 ; quit if ien of #772 is not defined
171 Q:'HLMTIEN
172 ; quit if field separator is not defined
173 Q:HL("FS")=""
174 ;
175 S X=$$P^HLTPCK2(.HLHDRO,1)
176 ;
177 ; patch HL*1.6*120 start
178 I X="MSH" D
179 . S HL("PID")=$$P^HLTPCK2(.HLHDRO,11),HL("VER")=$$P^HLTPCK2(.HLHDRO,12),HL("APAT")=$$P^HLTPCK2(.HLHDRO,16),HL("CC")=$$P^HLTPCK2(.HLHDRO,17)
180 . ;
181 . ; 2nd component is Processing mode
182 . S HL("PMOD")=$P(HL("PID"),$E(HL("ECH"),1),2)
183 . ; first component is Processing id
184 . S HL("PID")=$P(HL("PID"),$E(HL("ECH"),1))
185 ;
186 I X'="MSH" D
187 . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4)
188 . ;
189 . ; original code incorrectly treats repetition separator as
190 . ; subcomponent separator
191 . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D
192 .. S HL("SUB-COMPONENT")=$E(HL("ECH"),2)
193 . ; if subcomponent separator is correctly applied
194 . I $E(HL("ECH"),4)]"",X[$E(HL("ECH"),4) D
195 .. S HL("SUB-COMPONENT")=$E(HL("ECH"),4)
196 . ;
197 . I $D(HL("SUB-COMPONENT")),HL("PID")[HL("SUB-COMPONENT") D
198 .. ; 2nd sub-component is Processing mode
199 .. S HL("PMOD")=$P(HL("PID"),HL("SUB-COMPONENT"),2)
200 .. ; first sub-component is Processing id
201 .. S HL("PID")=$P(HL("PID"),HL("SUB-COMPONENT"))
202 . ; patch HL*1.6*120 end
203 . ;
204 . Q:$$P^HLTPCK2(.HLHDRO,10)=""
205 . ;HLMSA=ack code^id^text
206 . S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2)
207 ;
208 ; quit if this is a commit ack
209 I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q
210 ;
211 ;** HL*1.6*117 **
212 K HLL("SET FOR APP ACK"),HLL("LINKS")
213 ;
214 D CONT
215 Q
216 ;
217MSA(Y) ;Y=ien in 772, returns MSA segment
218 ;ack code^msg being ack id^text
219 ; patch HL*1.6*122
220 ; for HL7 v2.5 and beyond with MSA as 3rd segment
221 N X,SUBIEN,DATA,DONE
222 S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
223 Q:X]"" X
224 ;
225 S DONE=0
226 S SUBIEN=1
227 F S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN D Q:DONE
228 . S DATA=$G(^HL(772,Y,"IN",SUBIEN,0)) I DATA="" D
229 .. S DONE=1
230 .. S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN
231 .. S X=$G(^HL(772,Y,"IN",SUBIEN,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
232 ; patch HL*1.6*122 end
233 ;
234 Q X
235 ;
236ERROR ;error trap
237 D ^%ZTER
238 I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
239 ; release locks created by inbound filer
240 L -^HLMA("AC","I",+$G(HLXX))
241 G UNWIND^%ZTER
242 ;
243 ;
244EXIT ;unlock
245 I $G(HLMTIENS) L -^HLMA(HLMTIENS)
246 Q
247 ;
248ONAC(IEN773) ;
249 ;Returns 1 if the message is on the "AC","I" xref
250 ;Returns 0 otherwise
251 ;
252 N LINK
253 S LINK=$P($G(^HLMA(IEN773,0)),"^",17)
254 Q:'LINK 0
255 Q $D(^HLMA("AC","I",LINK,IEN773))
Note: See TracBrowser for help on using the repository browser.