source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m@ 619

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

initial load of WorldVistAEHR
File size: 9.5 KB
RevLine 
[613]1HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;04/17/2007
2 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133,122**;Oct 13, 1995;Build 14
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4HEADER(IEN,CLIENT,HLERROR) ; Create an HL7 MSH segment
5 ;
6 ;Input : IEN - Pointer to entry in Message Administration file (#773)
7 ; that HL7 MSH segment is being built for
8 ; CLIENT - IEN of the receiving application
9 ; HLERROR - Variable to return possible error text in
10 ; (pass by reference - only used when needed)
11 ;
12 ;Output : HLHDR(1) - HL7 MSH segment
13 ; HLHDR(2) - Continuation of HL7 MSH segment (if needed)
14 ; HLHDR(3) - Continuation of HL7 MSH segment (if needed)
15 ;
16 ;Notes : HLERROR will only be defined [on output] if an error occurs
17 ; : HLHDR() will not be defined [on output] if an error occurs
18 ; : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes
19 ; and will only be used/defined when needed
20 ;
21 N ACKTO,ACCACK,APPACK,CHILD,CLNTAPP,CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID,MSGTYPE,PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X,MSGEVN
22 N COMFLAG ; patch HL*1.6*120
23 S HLERROR=""
24 S HLPARAM=$$PARAM^HLCS2
25 D VAR Q:$G(HLERROR)]""
26 ; The following line commented by HL*1.6*72
27 ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
28 ;Append event type
29 I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_EVNTYPE
30 ;Append message structure component
31 I $G(EVNTYPE)]"",$G(MSGEVN)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_MSGEVN
32 ;Build MSH array
33 D RESET^HLCSHDR3 ;HL*1.6*93
34 ;
35 ; patch HL*1.6*120 start
36 ; escape delimiters for SERAPP and CLNTAPP
37 ; escape component separator if the field is not consisted
38 ; of 3 components
39 S EC(1)=$E(EC,1)
40 S EC(2)=$E(EC,2)
41 S EC(3)=$E(EC,3)
42 S EC(4)=$E(EC,4)
43 S COMFLAG=1
44 I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
45 I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
46 . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
47 S COMFLAG=1
48 I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
49 I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
50 . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
51 ; patch HL*1.6*120 end
52 ;
53 S HLHDRI=1,HLHDR(1)="MSH"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
54 F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D MSH(X)
55 ;in preceeding line, "" is for sequence number - not supported
56 Q
57 ;
58MSH(X) ;add X to HLHDR
59 S:HLHDRL+$L(X)>245 HLHDRI=HLHDRI+1,HLHDR(HLHDRI)=""
60 S HLHDR(HLHDRI)=HLHDR(HLHDRI)_FS_X,HLHDRL=$L(HLHDR(HLHDRI))
61 Q
62BHSHDR(IEN,CLIENT,HLERROR) ; Create Batch Header Segment
63 ; The BHS has 12 segments, of which 4 are blank.
64 ; INPUT: IEN - IEN of entry in file #772
65 ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs.
66 ; ready for adding to a message directly.
67 N ACKTO,ACCACK,ACKMID,APPACK,BNAME,BSTATUS,BTACK,CHILD,CLNTAPP ;HL*1.6*80
68 N CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID ;HL*1.6*80 - added HLPID
69 N PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X ;HL*1.6*80
70 N COMFLAG ; patch HL*1.6*120
71 S HLERROR=""
72 ;
73 S HLPARAM=$$PARAM^HLCS2
74 D VAR Q:$G(HLERROR)]""
75 ; The following line commented by HL*1.6*72
76 ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
77 ;
78 ;Append event type
79 I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,2)_EVNTYPE,(ACKMID,BTACK)=""
80 ;batch/name/id/type(#9)=null~process ID~msg type|evnt type~version~CA~AA
81 S BNAME=$E(EC,1)_HLPID_$E(EC,1)_MSGTYPE_$E(EC,1)_$P(PROT,U,9)_$E(EC,1)_ACCACK_$E(EC,1)_APPACK ;HL*1.6*80
82 ;for batch ACK
83 I ACKTO D S BTACK=X_$E(EC,1)_$P(BSTATUS,U,3)
84 . ;get msg id and status of message that is being ACKed
85 . S ACKMID=$P($G(^HLMA(ACKTO,0)),U,2),BSTATUS=$G(^HLMA(ACKTO,"P")) ;HL*1.6*80
86 . ;set type of ACK based on status
87 . S X=$S(ACKMID="":"AR",(BSTATUS>3)&(BSTATUS<8):"AE",1:"AA")
88 ;
89 D RESET^HLCSHDR3 ;HL*1.6*93
90 ;
91 ; patch HL*1.6*120 start
92 ; escape delimiters for SERAPP and CLNTAPP
93 ; escape component separator if the field is not consisted
94 ; of 3 components
95 S EC(1)=$E(EC,1)
96 S EC(2)=$E(EC,2)
97 S EC(3)=$E(EC,3)
98 S EC(4)=$E(EC,4)
99 S COMFLAG=1
100 I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
101 I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
102 . S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
103 S COMFLAG=1
104 I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
105 I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
106 . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
107 ; patch HL*1.6*120 end
108 ;
109 S HLHDRI=1,HLHDR(1)="BHS"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
110 F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,BNAME,BTACK,HLID,ACKMID D MSH(X)
111 Q
112VAR ;Check input
113 N APPPRM,HLPROTS,HLPROT
114 S IEN=+$G(IEN)
115 I '$G(^HLMA(IEN,0)) S HLERROR="Valid pointer to Message Administration file (#772) not passed" Q
116 I '$G(CLIENT) S HLERROR="Could not determine receiving application" Q
117 ;Get child, text pointer,text entry, and sending app.
118 S CHILD=$G(^HLMA(IEN,0)),SEND=+$P($G(^(0)),U,11),TXTP=+CHILD,TXTP0=$G(^HL(772,TXTP,0))
119 I ('SEND) S HLERROR="Could not determine sending application" Q
120 ;Get info for sending & receiving applications
121 D APPPRM^HLUTIL2(CLIENT),APPPRM^HLUTIL2(SEND)
122 ;Get name of sending application, facility, and country
123 S SERAPP=$P(APPPRM(SEND,0),U),SERFAC=$P(APPPRM(SEND,0),U,2),CNTRY=$P(APPPRM(SEND,0),U,3)
124 ;Get name of receiving application and facility
125 S CLNTAPP=$P(APPPRM(CLIENT,0),U),CLNTFAC=$P(APPPRM(CLIENT,0),U,2)
126 ;
127 ; patch HL*1.6*120
128 ; for dynamic addressing, overide the receiving facility from the
129 ; 3rd component of HLL("LINKS") array
130 I $G(HLP("REC-FACILITY"))]"" S CLNTFAC=HLP("REC-FACILITY")
131 ;
132 ;Get field separator & encoding characters
133 S FS=APPPRM(SEND,"FS"),EC=APPPRM(SEND,"EC")
134 S:(EC="") EC="~|\&" S:(FS="") FS="^"
135 ;Determine if it's a response/ACK to another message
136 S ACKTO=+$P(CHILD,U,10)
137 ;subscriber protocol is from child (file 773)
138 ;If response, get MType from subscriber
139 S HLPROTS=+$P(CHILD,U,8)
140 S PROTS=$$TYPE^HLUTIL2(HLPROTS)
141 I ACKTO S MSGTYPE=$P(PROTS,U,10),EVNTYPE=$P(PROTS,U,3),MSGEVN=$P(PROTS,U,4)
142 ;Get accept ack & application ack type (based on server protocol) it
143 ; is always in file 772, TXPT0
144 ;If original message, get MT from Event Driver Protocol
145 S HLPROT=+$P(TXTP0,U,10)
146 S PROT=$$TYPE^HLUTIL2(HLPROT)
147 S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4)
148 S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8)
149 ;
150 ; patch HL*1.6*122
151 ; setting the MSH-15 and MSH-16 from subscriber protocol
152 I HLPROTS,$P($G(^ORD(101,HLPROTS,773)),"^",5) D
153 . S ACCACK=$P(PROTS,U,7)
154 . S APPACK=$P(PROTS,U,8)
155 ;
156PID ;Processing ID
157 ;I PID not 'debug' get from site params
158 ;If event driver set to 'debug' get from protocol
159 ;'production' or 'training' comes from site params
160 S HLPID=$P(PROT,U,5)
161 I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3)
162 ;
163 ; patch HL*1.6*120: to include processing mode
164 I $G(HLP("PMOD"))]"",($G(HLTYPE)="M") D
165 . S HLPID=HLPID_$E($G(EC),1)_HLP("PMOD")
166 ;
167 I $G(HLPID)="" S HLERROR="Missing processing ID Site parameter."
168 ;acknowledgements have no application ack, link open no commit ack
169 I ACKTO S:APPACK]"" APPACK="NE" S:ACCACK]""&$G(HLTCPO) ACCACK="NE"
170 ;Get date/time, Message ID, and security
171 S HLDATE=+TXTP0,HLDATE=$$FMTHL7^XLFDT(HLDATE),HLID=$P(CHILD,U,2),SECURITY=$P(CHILD,U,9)
172HDR23 ;generate extended facility field info based on 'facility required'
173 ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS'
174 ;application parameter entry overrides default
175 N HLEP773,HLS773
176 S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC)
177 S HLEP773=+$G(^ORD(101,HLPROTS,773))
178 S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2)
179 Q:'HLEP773&('HLS773)
180 D GEN^HLCSHDR2
181 I ACKTO D Q
182 .;Find original message
183 .S X=$G(^HLMA(ACKTO,"MSH",1,0)) ;Find header in TCP nodes
184 .I X["MSH" D
185 ..;
186 ..; patch HL*1.6*120 start
187 .. N HLEC
188 ..S HLFS=$E(X,4),HLEC=$E(X,5)
189 ..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg
190 ..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info
191 ..S EC("COMPONENT")=$E($G(EC),1)
192 ..I $L(EC("COMPONENT"))=1,$L(HLEC)=1,EC("COMPONENT")'=HLEC D
193 ... ; change the the component separator in the sending and
194 ... ; receiving facilities for the outgoing message
195 ... S CLNTFAC=$TR(CLNTFAC,HLEC,EC("COMPONENT"))
196 ... S SERFAC=$TR(SERFAC,HLEC,EC("COMPONENT"))
197 ; patch HL*1.6*120 end
198 ;
199 I HLEP773,SERFAC="" D EP^HLCSHDR2
200 I HLS773,CLNTFAC="" D S^HLCSHDR2
201 Q
202 ;
203ESCAPE(INPUT,COMPONET) ;
204 ; patch HL*1.6*120 - escape delimiters:
205 ; - field separator
206 ; - component separator
207 ; - repetition separator
208 ; - escape character
209 ; - subcomponent separator
210 ;
211 ; input:
212 ; INPUT - string data to be escaped
213 ; COMPONET - if 1, escape component separator
214 ; if 0, do not escape component separator
215 ; FS - field separator character
216 ; EC - encoding characters
217 ; result: return the escaped string
218 ;
219 N HLDATA,HLESCAPE,HLI,HLCHAR,HLEN,HLOUT,COMFLAG
220 S HLDATA=$G(INPUT)
221 S COMFLAG=$G(COMPONET)
222 Q:$L($G(FS))'=1 HLDATA
223 ;
224 ; patch HL*1.6*133
225 ; Q:$L($G(EC))'=4 HLDATA
226 Q:($L($G(EC))<3) HLDATA
227 Q:HLDATA']"" HLDATA
228 ;
229 S HLESCAPE=FS_EC
230 S HLESCAPE("F")=FS
231 S HLESCAPE("S")=$E(EC,1)
232 S HLESCAPE("R")=$E(EC,2)
233 S HLESCAPE("E")=$E(EC,3)
234 S HLESCAPE("T")=$E(EC,4)
235 S HLEN=$L(HLDATA)
236 S HLOUT=""
237 F HLI=1:1:HLEN D
238 . S HLCHAR=$E(HLDATA,HLI)
239 . I HLESCAPE[HLCHAR D Q
240 .. I HLCHAR=HLESCAPE("F") S HLOUT=HLOUT_HLESCAPE("E")_"F"_HLESCAPE("E") Q
241 .. I HLCHAR=HLESCAPE("S") D Q
242 ... I COMFLAG=1 S HLOUT=HLOUT_HLESCAPE("E")_"S"_HLESCAPE("E") Q
243 ... S HLOUT=HLOUT_HLCHAR
244 .. I HLCHAR=HLESCAPE("R") S HLOUT=HLOUT_HLESCAPE("E")_"R"_HLESCAPE("E") Q
245 .. I HLCHAR=HLESCAPE("E") S HLOUT=HLOUT_HLESCAPE("E")_"E"_HLESCAPE("E") Q
246 .. I HLCHAR=HLESCAPE("T") S HLOUT=HLOUT_HLESCAPE("E")_"T"_HLESCAPE("E") Q
247 . ;
248 . S HLOUT=HLOUT_HLCHAR
249 Q HLOUT
Note: See TracBrowser for help on using the repository browser.