source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1HLCSHDR ; ALB/MFK,JRP - Make HL7 header from a #772 IEN ;05/31/2000 08:59
2 ;;1.6;HEALTH LEVEL SEVEN;**37,19,57,59,65,80**;Oct 13, 1995
3HEADER(IEN,HLERROR) ; Create an HL7 MSH segment
4 ;
5 ;Input : IEN - Pointer to entry in Message Text file (#772) that
6 ; HL7 MSH segment is being built for
7 ; HLERROR - Variable to return possible error text in
8 ; (pass by reference - only used when needed)
9 ;
10 ;Output : HLHDR(1) - HL7 MSH segment
11 ; HLHDR(2) - Continuation of HL7 MSH segment (if needed)
12 ; HLHDR(3) - Continuation of HL7 MSH segment (if needed)
13 ;
14 ;Notes : HLERROR will only be defined [on output] if an error occurs
15 ; : HLHDR() will not be defined [on output] if an error occurs
16 ; : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes
17 ; and will only be used/defined when needed
18 ;
19 ;Check input
20 S IEN=+$G(IEN)
21 I ('$D(^HL(772,IEN,0))) S HLERROR="Valid pointer to Message Text file (#772) not passed" Q
22 ;Declare variables
23 N PROTOCOL,PARENTP,PARENT,SERVERP,CLIENTP,FS,PROT,MSGTYPE,APPPRM
24 N HLDTID,HLID,HLDATE,SECURITY,ID,SERAPP,SERFAC,EC,ACCACK,APPACK
25 N CHILD,CLNTAPP,CLNTFAC,ACKTO,CNTRY,HLPROT,HLPROTS,HLPARAM
26 ;Get Site Parameters
27 S HLPARAM=$$PARAM^HLCS2
28 ;Get parent message (NOTE: Original message is it's own parent)
29 S CHILD=$G(^HL(772,IEN,0))
30 I CHILD="" S HLERROR="Valid pointer to Message Text file (#772) not passed" Q
31 S PARENTP=+$P(CHILD,"^",8)
32 I ('PARENTP) S HLERROR="Could not determine parent message" Q
33 S PARENT=$G(^HL(772,PARENTP,0))
34 ;Get server [sending] & client [receiving] applications
35 S SERVERP=+$P(PARENT,"^",2)
36 I ('SERVERP) S HLERROR="Could not determine sending application" Q
37 S CLIENTP=+$P(CHILD,"^",3)
38 I ('CLIENTP) S HLERROR="Could not determine receiving application" Q
39 ;Get info for sending & receiving applications
40 D APPPRM^HLUTIL2(CLIENTP)
41 D APPPRM^HLUTIL2(SERVERP)
42 ;Get name of sending application and facility
43 S SERAPP=$P(APPPRM(SERVERP,0),"^",1)
44 S SERFAC=$P(APPPRM(SERVERP,0),"^",2)
45 ;Get name of receiving application and facility
46 S CLNTAPP=$P(APPPRM(CLIENTP,0),"^",1)
47 S CLNTFAC=$P(APPPRM(CLIENTP,0),"^",2)
48 ;Get country
49 S CNTRY=$P(APPPRM(SERVERP,0),"^",3)
50 ;Get field seperator & encoding characters
51 S FS=APPPRM(SERVERP,"FS")
52 S EC=APPPRM(SERVERP,"EC")
53 S:(EC="") EC="~|\&"
54 S:(FS="") FS="^"
55 ;
56 ;Determine if it's a response/ACK to another message
57 ;
58 S ACKTO=+$P(PARENT,"^",7)
59 ;
60 ;Get message type
61 ;Message type/Event Type of Initiator found on Event Driver
62 ;Message type/Event Type of Responder found on Subscriber
63 ;
64 S PROT=+$P(PARENT,"^",10),HLPROT=PROT
65 ;commented the next line to get ack message to have the correct header
66 ;S:ACKTO&($G(HLOGLINK)) PROT=+$P(CHILD,"^",10)
67 S PROTOCOL=$$TYPE^HLUTIL2(PROT)
68 ;if initiating a new transaction, get MsgType from Event Driver, field 770.3
69 ;if generating a response, get MsgType from subscriber, field 770.11
70 S MSGTYPE=$S(ACKTO:$P(PROTOCOL,"^",10),1:$P(PROTOCOL,"^",2))
71 ;Append event type
72 I MSGTYPE']"" S HLERROR="Message Type Undefined for protocol "_$P(PROTOCOL,"^",1) Q
73 I $P(PROTOCOL,"^",3)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_$P(PROTOCOL,"^",3)
74 ;Append mesaage structure component
75 I $P(PROTOCOL,"^",3)]"",$P(PROTOCOL,"^",4)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_$P(PROTOCOL,"^",4)
76 ;Get accept ack & application ack type (based on server protocol)
77 ; Originating messages have it listed in the parent message
78 ; Responses/ACKs have it listed in the child message
79 S PROT=+$P(PARENT,"^",10),HLPROT=PROT
80 S:(ACKTO) PROT=+$P(CHILD,"^",10)
81 S HLPROTS=+$P(CHILD,"^",10)
82 S PROTOCOL=$$TYPE^HLUTIL2(PROT)
83 S ACCACK=$P(PROTOCOL,"^",7)
84 S APPACK=$P(PROTOCOL,"^",8)
85 ;Get date/time & message ID
86 S HLDATE=+PARENT
87 S HLDATE=$$FMTHL7^XLFDT(HLDATE)
88MID ;Message ID
89 S HLID=$P(PARENT,"^",6)
90PID ;Processing ID
91 ;If event driver set to 'debug' get from protocol
92 ;'production' or 'training' comes from site params
93 S HLPID=$P(PROTOCOL,"^",5)
94 I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3)
95 I $G(HLPID)="" S HLERROR="Missing Processing ID Site Parameter."
96 ;Get security info
97 S SECURITY=$P(PARENT,"^",12)
98 D HDR23
99 ;Build MSH array
100 S HLHDR(1)="MSH"_FS_EC_FS_SERAPP_FS_SERFAC_FS_CLNTAPP_FS_CLNTFAC_FS
101 S HLHDR(1)=HLHDR(1)_HLDATE_FS_SECURITY_FS_MSGTYPE_FS_HLID_FS
102 S HLHDR(1)=HLHDR(1)_HLPID_FS_$P(PROTOCOL,"^",9)_FS_FS
103 S HLHDR(2)=$G(^HL(772,PARENT,1))_FS
104 S HLHDR(3)=ACCACK_FS_APPACK_FS_CNTRY
105 ;Combine line 1 & 2 (if possible)
106 I (($L(HLHDR(1))+$L(HLHDR(2)))'>245) D
107 .S HLHDR(1)=HLHDR(1)_HLHDR(2)
108 .S HLHDR(2)=HLHDR(3)
109 .S HLHDR(3)=""
110 .;Add original line 3 (if possible)
111 .I (($L(HLHDR(1))+$L(HLHDR(2)))'>245) D
112 ..S HLHDR(1)=HLHDR(1)_HLHDR(2)
113 ..S HLHDR(2)=""
114 ;Combine line 2 & 3 (if possible)
115 I (($L(HLHDR(2))+$L(HLHDR(3)))'>245) D
116 .S HLHDR(2)=HLHDR(2)_HLHDR(3)
117 .S HLHDR(3)=""
118 ;Delete unused lines
119 K:(HLHDR(2)="") HLHDR(2)
120 K:(HLHDR(3)="") HLHDR(3)
121 Q
122BHSHDR(IEN) ; Create Batch Header Segment
123 ; The BHS has 12 segments, of which 4 are blank.
124 ; INPUT: IEN - IEN of entry in file #772
125 ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs.
126 ; ready for adding to a message directly.
127 N ACKMID,ACKTO,APPPRM,BC,BCD,BCI,BEC,BFS,BN,BRA,BRF,BS,BSA,BSF ;HL*1.6*80
128 N BSTATUS,BTACK,CHILD,CLIENTP,HLDATE,HLDTID,HLPID,ID,PARENT,PARENTP ;HL*1.6*80
129 N RBCI,SERVERP ;HL*1.6*80
130 S CHILD=$G(^HL(772,IEN,0))
131 S PARENTP=$P(CHILD,"^",8)
132 I (PARENTP="") S HLHDR(1)="-1^No parent" Q
133 S PARENT=$G(^HL(772,PARENTP,0))
134 S SERVERP=$P(PARENT,"^",2)
135 I (SERVERP="") S HLHDR(1)="-1^No server for this node" Q
136 S CLIENTP=$P(CHILD,"^",3)
137 I (CLIENTP="") S HLHDR(1)="-1^No client for this node" Q
138 ;-- get server and application parameters
139 D APPPRM^HLUTIL2(SERVERP)
140 D APPPRM^HLUTIL2(CLIENTP)
141 S BFS=APPPRM(SERVERP,"FS")
142 S BEC=APPPRM(SERVERP,"EC")
143 ;-- sending application
144 S BSA=$P(APPPRM(SERVERP,0),"^",1)
145 ;-- sending facility
146 S BSF=$P(APPPRM(SERVERP,0),"^",2)
147 ;-- receiving application
148 S BRA=$P(APPPRM(CLIENTP,0),"^",1)
149 ;-- receiving facility
150 S BRF=$P(APPPRM(CLIENTP,0),"^",2)
151 S HLDATE=+PARENT
152 S HLID=$P(PARENT,"^",6)
153 S BCD=$$HLDATE^HLFNC(HLDATE,"TS")
154 ;-- batch security
155 S BS=$P(PARENT,"^",12)
156 ;-- build batch field #9 NULL~Process ID~Message Type|Event Type~version
157 S ACKTO=$P(PARENT,"^",7)
158 S PROT=$S((ACKTO&$G(HLOGLINK)):$P(CHILD,"^",10),1:$P(PARENT,"^",10))
159 ;S X=$$TYPE^HLUTIL2($P(CHILD,U,10))
160 ; for batch ACK message, client protocol pointer is stored in parent message
161 ;I ACKTO S X=$$TYPE^HLUTIL2($P(PARENT,U,10))
162 S X=$$TYPE^HLUTIL2(PROT)
163 S MSGTYPE=$S(ACKTO:$P(X,"^",10),1:$P(X,"^",2))
164 I MSGTYPE']"" S HLERROR="MType undefined for protocol "_$P(X,U) Q
165 I $P(X,U,3)]"" S MSGTYPE=MSGTYPE_$E(BEC,2)_$P(X,U,3)
166 ;S BN=$E(BEC,1)_$P(X,U,5)_$E(BEC,1)_$S('$P(CHILD,"^",11)&('ACKTO):$P(X,U,2),1:$P(X,U,10))_$E(BEC,2)_$P(X,U,3)_$E(BEC,1)_$P(X,U,9)
167 S HLPID=$$PIDCK($P($G(^HL(772,+PROT,0)),U,10)) QUIT:$G(HLERROR)]"" ;HL*1.6*80
168 S BN=$E(BEC,1)_HLPID_$E(BEC,1)_MSGTYPE_$E(BEC,1)_$P(X,U,9) ;HL*1.6*80
169 ;
170 ; for batch ACK message
171 S ACKMID="",BTACK=""
172 I ACKTO D
173 . S ACKMID=$P($G(^HL(772,ACKTO,0)),"^",6)
174 . S BSTATUS=$P($G(^HL(772,ACKTO,"P")),"^")
175 . S BTACK="AR"
176 . I ACKMID]"" D
177 .. S BTACK="AA"
178 .. I (BSTATUS>3)&(BSTATUS<8) S BTACK="AE"_$E(BEC,1)_$P($G(^HL(772,ACKTO,"P")),"^",3)
179 ;
180 S HLHDR(1)="BHS"_BFS_BEC_BFS_BSA_BFS_BSF_BFS_BRA_BFS_BRF_BFS_BCD_BFS_BS_BFS_BN_BFS_BTACK_BFS_HLID_BFS_ACKMID
181 Q
182HDR23 ;generate extended facility field info based on 'facility required'
183 ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS'
184 ;application parameter entry overrides default
185 N HLEP773,HLS773
186 S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC)
187 S HLEP773=+$G(^ORD(101,HLPROTS,773))
188 S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2)
189 Q:'HLEP773&('HLS773)
190 D GEN^HLCSHDR2
191 I ACKTO D Q
192 .;Find original message
193 .S X=$G(^HL(772,ACKTO,"IN",1,0))
194 .I X["MSH" D
195 ..S HLFS=$E(X,4)
196 ..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg
197 ..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info
198 I HLEP773,SERFAC="" D EP^HLCSHDR2
199 I HLS773,CLNTFAC="" D S^HLCSHDR2
200 Q
201 ;
202PIDCK(IEN101) ; This subroutine added by HL*1.6*80
203 ; Given 101's IEN, return the PROCESSING ID. (See PID^HLCSHDR
204 ; and PID^HLCSHDR1 for other locations where HLPID is set.)
205 ; HLPARAM -- req
206 S HLPID=$P($G(^ORD(101,+IEN101,0)),U,6)
207 I HLPID'="D" D
208 . I $G(HLPARAM)']"" N HLPARAM S HLPARAM=$$PARAM^HLCS2
209 . S HLPID=$P($G(HLPARAM),U,3)
210 I HLPID="" S HLERROR="Missing Processing ID Site Parameter."
211 QUIT HLPID
Note: See TracBrowser for help on using the repository browser.