| 1 | HLCSHDR ; 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
|
|---|
| 3 | HEADER(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)
|
|---|
| 88 | MID ;Message ID
|
|---|
| 89 | S HLID=$P(PARENT,"^",6)
|
|---|
| 90 | PID ;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
|
|---|
| 122 | BHSHDR(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
|
|---|
| 182 | HDR23 ;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 | ;
|
|---|
| 202 | PIDCK(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
|
|---|
