HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;04/17/2007
;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133,122**;Oct 13, 1995;Build 14
;Per VHA Directive 2004-038, this routine should not be modified.
;
;Input : IEN - Pointer to entry in Message Administration file (#773)
; that HL7 MSH segment is being built for
; CLIENT - IEN of the receiving application
; HLERROR - Variable to return possible error text in
; (pass by reference - only used when needed)
;
;Output : HLHDR(1) - HL7 MSH segment
; HLHDR(2) - Continuation of HL7 MSH segment (if needed)
; HLHDR(3) - Continuation of HL7 MSH segment (if needed)
;
;Notes : HLERROR will only be defined [on output] if an error occurs
; : HLHDR() will not be defined [on output] if an error occurs
; : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes
; and will only be used/defined when needed
;
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
N COMFLAG ; patch HL*1.6*120
S HLERROR=""
S HLPARAM=$$PARAM^HLCS2
D VAR Q:$G(HLERROR)]""
; The following line commented by HL*1.6*72
;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
;Append event type
I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_EVNTYPE
;Append message structure component
I $G(EVNTYPE)]"",$G(MSGEVN)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_MSGEVN
;Build MSH array
D RESET^HLCSHDR3 ;HL*1.6*93
;
; patch HL*1.6*120 start
; escape delimiters for SERAPP and CLNTAPP
; escape component separator if the field is not consisted
; of 3 components
S EC(1)=$E(EC,1)
S EC(2)=$E(EC,2)
S EC(3)=$E(EC,3)
S EC(4)=$E(EC,4)
S COMFLAG=1
I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
. S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
S COMFLAG=1
I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
. S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
; patch HL*1.6*120 end
;
S HLHDRI=1,HLHDR(1)="MSH"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
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)
;in preceeding line, "" is for sequence number - not supported
Q
;
MSH(X) ;add X to HLHDR
S:HLHDRL+$L(X)>245 HLHDRI=HLHDRI+1,HLHDR(HLHDRI)=""
S HLHDR(HLHDRI)=HLHDR(HLHDRI)_FS_X,HLHDRL=$L(HLHDR(HLHDRI))
Q
BHSHDR(IEN,CLIENT,HLERROR) ; Create Batch Header Segment
; The BHS has 12 segments, of which 4 are blank.
; INPUT: IEN - IEN of entry in file #772
; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs.
; ready for adding to a message directly.
N ACKTO,ACCACK,ACKMID,APPACK,BNAME,BSTATUS,BTACK,CHILD,CLNTAPP ;HL*1.6*80
N CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID ;HL*1.6*80 - added HLPID
N PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X ;HL*1.6*80
N COMFLAG ; patch HL*1.6*120
S HLERROR=""
;
S HLPARAM=$$PARAM^HLCS2
D VAR Q:$G(HLERROR)]""
; The following line commented by HL*1.6*72
;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
;
;Append event type
I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,2)_EVNTYPE,(ACKMID,BTACK)=""
;batch/name/id/type(#9)=null~process ID~msg type|evnt type~version~CA~AA
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
;for batch ACK
I ACKTO D S BTACK=X_$E(EC,1)_$P(BSTATUS,U,3)
. ;get msg id and status of message that is being ACKed
. S ACKMID=$P($G(^HLMA(ACKTO,0)),U,2),BSTATUS=$G(^HLMA(ACKTO,"P")) ;HL*1.6*80
. ;set type of ACK based on status
. S X=$S(ACKMID="":"AR",(BSTATUS>3)&(BSTATUS<8):"AE",1:"AA")
;
D RESET^HLCSHDR3 ;HL*1.6*93
;
; patch HL*1.6*120 start
; escape delimiters for SERAPP and CLNTAPP
; escape component separator if the field is not consisted
; of 3 components
S EC(1)=$E(EC,1)
S EC(2)=$E(EC,2)
S EC(3)=$E(EC,3)
S EC(4)=$E(EC,4)
S COMFLAG=1
I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0
I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D
. S SERAPP=$$ESCAPE(SERAPP,COMFLAG)
S COMFLAG=1
I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0
I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D
. S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
; patch HL*1.6*120 end
;
S HLHDRI=1,HLHDR(1)="BHS"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1))
F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,BNAME,BTACK,HLID,ACKMID D MSH(X)
Q
VAR ;Check input
N APPPRM,HLPROTS,HLPROT
S IEN=+$G(IEN)
I '$G(^HLMA(IEN,0)) S HLERROR="Valid pointer to Message Administration file (#772) not passed" Q
I '$G(CLIENT) S HLERROR="Could not determine receiving application" Q
;Get child, text pointer,text entry, and sending app.
S CHILD=$G(^HLMA(IEN,0)),SEND=+$P($G(^(0)),U,11),TXTP=+CHILD,TXTP0=$G(^HL(772,TXTP,0))
I ('SEND) S HLERROR="Could not determine sending application" Q
;Get info for sending & receiving applications
D APPPRM^HLUTIL2(CLIENT),APPPRM^HLUTIL2(SEND)
;Get name of sending application, facility, and country
S SERAPP=$P(APPPRM(SEND,0),U),SERFAC=$P(APPPRM(SEND,0),U,2),CNTRY=$P(APPPRM(SEND,0),U,3)
;Get name of receiving application and facility
S CLNTAPP=$P(APPPRM(CLIENT,0),U),CLNTFAC=$P(APPPRM(CLIENT,0),U,2)
;
; patch HL*1.6*120
; for dynamic addressing, overide the receiving facility from the
; 3rd component of HLL("LINKS") array
I $G(HLP("REC-FACILITY"))]"" S CLNTFAC=HLP("REC-FACILITY")
;
;Get field separator & encoding characters
S FS=APPPRM(SEND,"FS"),EC=APPPRM(SEND,"EC")
S:(EC="") EC="~|\&" S:(FS="") FS="^"
;Determine if it's a response/ACK to another message
S ACKTO=+$P(CHILD,U,10)
;subscriber protocol is from child (file 773)
;If response, get MType from subscriber
S HLPROTS=+$P(CHILD,U,8)
S PROTS=$$TYPE^HLUTIL2(HLPROTS)
I ACKTO S MSGTYPE=$P(PROTS,U,10),EVNTYPE=$P(PROTS,U,3),MSGEVN=$P(PROTS,U,4)
;Get accept ack & application ack type (based on server protocol) it
; is always in file 772, TXPT0
;If original message, get MT from Event Driver Protocol
S HLPROT=+$P(TXTP0,U,10)
S PROT=$$TYPE^HLUTIL2(HLPROT)
S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4)
S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8)
;
; patch HL*1.6*122
; setting the MSH-15 and MSH-16 from subscriber protocol
I HLPROTS,$P($G(^ORD(101,HLPROTS,773)),"^",5) D
. S ACCACK=$P(PROTS,U,7)
. S APPACK=$P(PROTS,U,8)
;
PID ;Processing ID
;I PID not 'debug' get from site params
;If event driver set to 'debug' get from protocol
;'production' or 'training' comes from site params
S HLPID=$P(PROT,U,5)
I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3)
;
; patch HL*1.6*120: to include processing mode
I $G(HLP("PMOD"))]"",($G(HLTYPE)="M") D
. S HLPID=HLPID_$E($G(EC),1)_HLP("PMOD")
;
I $G(HLPID)="" S HLERROR="Missing processing ID Site parameter."
;acknowledgements have no application ack, link open no commit ack
I ACKTO S:APPACK]"" APPACK="NE" S:ACCACK]""&$G(HLTCPO) ACCACK="NE"
;Get date/time, Message ID, and security
S HLDATE=+TXTP0,HLDATE=$$FMTHL7^XLFDT(HLDATE),HLID=$P(CHILD,U,2),SECURITY=$P(CHILD,U,9)
HDR23 ;generate extended facility field info based on 'facility required'
;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS'
;application parameter entry overrides default
N HLEP773,HLS773
S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC)
S HLEP773=+$G(^ORD(101,HLPROTS,773))
S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2)
Q:'HLEP773&('HLS773)
D GEN^HLCSHDR2
I ACKTO D Q
.;Find original message
.S X=$G(^HLMA(ACKTO,"MSH",1,0)) ;Find header in TCP nodes
.I X["MSH" D
..;
..; patch HL*1.6*120 start
.. N HLEC
..S HLFS=$E(X,4),HLEC=$E(X,5)
..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg
..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info
..S EC("COMPONENT")=$E($G(EC),1)
..I $L(EC("COMPONENT"))=1,$L(HLEC)=1,EC("COMPONENT")'=HLEC D
... ; change the the component separator in the sending and
... ; receiving facilities for the outgoing message
... S CLNTFAC=$TR(CLNTFAC,HLEC,EC("COMPONENT"))
... S SERFAC=$TR(SERFAC,HLEC,EC("COMPONENT"))
; patch HL*1.6*120 end
;
I HLEP773,SERFAC="" D EP^HLCSHDR2
I HLS773,CLNTFAC="" D S^HLCSHDR2
Q
;
ESCAPE(INPUT,COMPONET) ;
; patch HL*1.6*120 - escape delimiters:
; - field separator
; - component separator
; - repetition separator
; - escape character
; - subcomponent separator
;
; input:
; INPUT - string data to be escaped
; COMPONET - if 1, escape component separator
; if 0, do not escape component separator
; FS - field separator character
; EC - encoding characters
; result: return the escaped string
;
N HLDATA,HLESCAPE,HLI,HLCHAR,HLEN,HLOUT,COMFLAG
S HLDATA=$G(INPUT)
S COMFLAG=$G(COMPONET)
Q:$L($G(FS))'=1 HLDATA
;
; patch HL*1.6*133
; Q:$L($G(EC))'=4 HLDATA
Q:($L($G(EC))<3) HLDATA
Q:HLDATA']"" HLDATA
;
S HLESCAPE=FS_EC
S HLESCAPE("F")=FS
S HLESCAPE("S")=$E(EC,1)
S HLESCAPE("R")=$E(EC,2)
S HLESCAPE("E")=$E(EC,3)
S HLESCAPE("T")=$E(EC,4)
S HLEN=$L(HLDATA)
S HLOUT=""
F HLI=1:1:HLEN D
. S HLCHAR=$E(HLDATA,HLI)
. I HLESCAPE[HLCHAR D Q
.. I HLCHAR=HLESCAPE("F") S HLOUT=HLOUT_HLESCAPE("E")_"F"_HLESCAPE("E") Q
.. I HLCHAR=HLESCAPE("S") D Q
... I COMFLAG=1 S HLOUT=HLOUT_HLESCAPE("E")_"S"_HLESCAPE("E") Q
... S HLOUT=HLOUT_HLCHAR
.. I HLCHAR=HLESCAPE("R") S HLOUT=HLOUT_HLESCAPE("E")_"R"_HLESCAPE("E") Q
.. I HLCHAR=HLESCAPE("E") S HLOUT=HLOUT_HLESCAPE("E")_"E"_HLESCAPE("E") Q
.. I HLCHAR=HLESCAPE("T") S HLOUT=HLOUT_HLESCAPE("E")_"T"_HLESCAPE("E") Q
. ;
. S HLOUT=HLOUT_HLCHAR
Q HLOUT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSHDR1 10001 printed Sep 23, 2025@19:32:39 Page 2
HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;04/17/2007
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133,122**;Oct 13, 1995;Build 14
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+1 ;
+2 ;Input : IEN - Pointer to entry in Message Administration file (#773)
+3 ; that HL7 MSH segment is being built for
+4 ; CLIENT - IEN of the receiving application
+5 ; HLERROR - Variable to return possible error text in
+6 ; (pass by reference - only used when needed)
+7 ;
+8 ;Output : HLHDR(1) - HL7 MSH segment
+9 ; HLHDR(2) - Continuation of HL7 MSH segment (if needed)
+10 ; HLHDR(3) - Continuation of HL7 MSH segment (if needed)
+11 ;
+12 ;Notes : HLERROR will only be defined [on output] if an error occurs
+13 ; : HLHDR() will not be defined [on output] if an error occurs
+14 ; : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes
+15 ; and will only be used/defined when needed
+16 ;
+17 NEW 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
+18 ; patch HL*1.6*120
NEW COMFLAG
+19 SET HLERROR=""
+20 SET HLPARAM=$$PARAM^HLCS2
+21 DO VAR
if $GET(HLERROR)]""
QUIT
+22 ; The following line commented by HL*1.6*72
+23 ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
+24 ;Append event type
+25 IF $GET(EVNTYPE)]""
SET MSGTYPE=MSGTYPE_$EXTRACT(EC,1)_EVNTYPE
+26 ;Append message structure component
+27 IF $GET(EVNTYPE)]""
IF $GET(MSGEVN)]""
SET MSGTYPE=MSGTYPE_$EXTRACT(EC,1)_MSGEVN
+28 ;Build MSH array
+29 ;HL*1.6*93
DO RESET^HLCSHDR3
+30 ;
+31 ; patch HL*1.6*120 start
+32 ; escape delimiters for SERAPP and CLNTAPP
+33 ; escape component separator if the field is not consisted
+34 ; of 3 components
+35 SET EC(1)=$EXTRACT(EC,1)
+36 SET EC(2)=$EXTRACT(EC,2)
+37 SET EC(3)=$EXTRACT(EC,3)
+38 SET EC(4)=$EXTRACT(EC,4)
+39 SET COMFLAG=1
+40 IF $LENGTH(SERAPP,$EXTRACT(EC,1))=3
SET COMFLAG=0
+41 IF (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4))
Begin DoDot:1
+42 SET SERAPP=$$ESCAPE(SERAPP,COMFLAG)
End DoDot:1
+43 SET COMFLAG=1
+44 IF $LENGTH(CLNTAPP,$EXTRACT(EC,1))=3
SET COMFLAG=0
+45 IF (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4))
Begin DoDot:1
+46 SET CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
End DoDot:1
+47 ; patch HL*1.6*120 end
+48 ;
+49 SET HLHDRI=1
SET HLHDR(1)="MSH"_FS_EC_FS_SERAPP
SET HLHDRL=$LENGTH(HLHDR(1))
+50 FOR X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$PIECE(PROT,U,9),"",$GET(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY
DO MSH(X)
+51 ;in preceeding line, "" is for sequence number - not supported
+52 QUIT
+53 ;
MSH(X) ;add X to HLHDR
+1 if HLHDRL+$LENGTH(X)>245
SET HLHDRI=HLHDRI+1
SET HLHDR(HLHDRI)=""
+2 SET HLHDR(HLHDRI)=HLHDR(HLHDRI)_FS_X
SET HLHDRL=$LENGTH(HLHDR(HLHDRI))
+3 QUIT
BHSHDR(IEN,CLIENT,HLERROR) ; Create Batch Header Segment
+1 ; The BHS has 12 segments, of which 4 are blank.
+2 ; INPUT: IEN - IEN of entry in file #772
+3 ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs.
+4 ; ready for adding to a message directly.
+5 ;HL*1.6*80
NEW ACKTO,ACCACK,ACKMID,APPACK,BNAME,BSTATUS,BTACK,CHILD,CLNTAPP
+6 ;HL*1.6*80 - added HLPID
NEW CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID
+7 ;HL*1.6*80
NEW PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X
+8 ; patch HL*1.6*120
NEW COMFLAG
+9 SET HLERROR=""
+10 ;
+11 SET HLPARAM=$$PARAM^HLCS2
+12 DO VAR
if $GET(HLERROR)]""
QUIT
+13 ; The following line commented by HL*1.6*72
+14 ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE)
+15 ;
+16 ;Append event type
+17 IF $GET(EVNTYPE)]""
SET MSGTYPE=MSGTYPE_$EXTRACT(EC,2)_EVNTYPE
SET (ACKMID,BTACK)=""
+18 ;batch/name/id/type(#9)=null~process ID~msg type|evnt type~version~CA~AA
+19 ;HL*1.6*80
SET BNAME=$EXTRACT(EC,1)_HLPID_$EXTRACT(EC,1)_MSGTYPE_$EXTRACT(EC,1)_$PIECE(PROT,U,9)_$EXTRACT(EC,1)_ACCACK_$EXTRACT(EC,1)_APPACK
+20 ;for batch ACK
+21 IF ACKTO
Begin DoDot:1
+22 ;get msg id and status of message that is being ACKed
+23 ;HL*1.6*80
SET ACKMID=$PIECE($GET(^HLMA(ACKTO,0)),U,2)
SET BSTATUS=$GET(^HLMA(ACKTO,"P"))
+24 ;set type of ACK based on status
+25 SET X=$SELECT(ACKMID="":"AR",(BSTATUS>3)&(BSTATUS<8):"AE",1:"AA")
End DoDot:1
SET BTACK=X_$EXTRACT(EC,1)_$PIECE(BSTATUS,U,3)
+26 ;
+27 ;HL*1.6*93
DO RESET^HLCSHDR3
+28 ;
+29 ; patch HL*1.6*120 start
+30 ; escape delimiters for SERAPP and CLNTAPP
+31 ; escape component separator if the field is not consisted
+32 ; of 3 components
+33 SET EC(1)=$EXTRACT(EC,1)
+34 SET EC(2)=$EXTRACT(EC,2)
+35 SET EC(3)=$EXTRACT(EC,3)
+36 SET EC(4)=$EXTRACT(EC,4)
+37 SET COMFLAG=1
+38 IF $LENGTH(SERAPP,$EXTRACT(EC,1))=3
SET COMFLAG=0
+39 IF (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4))
Begin DoDot:1
+40 SET SERAPP=$$ESCAPE(SERAPP,COMFLAG)
End DoDot:1
+41 SET COMFLAG=1
+42 IF $LENGTH(CLNTAPP,$EXTRACT(EC,1))=3
SET COMFLAG=0
+43 IF (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4))
Begin DoDot:1
+44 SET CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG)
End DoDot:1
+45 ; patch HL*1.6*120 end
+46 ;
+47 SET HLHDRI=1
SET HLHDR(1)="BHS"_FS_EC_FS_SERAPP
SET HLHDRL=$LENGTH(HLHDR(1))
+48 FOR X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,BNAME,BTACK,HLID,ACKMID
DO MSH(X)
+49 QUIT
VAR ;Check input
+1 NEW APPPRM,HLPROTS,HLPROT
+2 SET IEN=+$GET(IEN)
+3 IF '$GET(^HLMA(IEN,0))
SET HLERROR="Valid pointer to Message Administration file (#772) not passed"
QUIT
+4 IF '$GET(CLIENT)
SET HLERROR="Could not determine receiving application"
QUIT
+5 ;Get child, text pointer,text entry, and sending app.
+6 SET CHILD=$GET(^HLMA(IEN,0))
SET SEND=+$PIECE($GET(^(0)),U,11)
SET TXTP=+CHILD
SET TXTP0=$GET(^HL(772,TXTP,0))
+7 IF ('SEND)
SET HLERROR="Could not determine sending application"
QUIT
+8 ;Get info for sending & receiving applications
+9 DO APPPRM^HLUTIL2(CLIENT)
DO APPPRM^HLUTIL2(SEND)
+10 ;Get name of sending application, facility, and country
+11 SET SERAPP=$PIECE(APPPRM(SEND,0),U)
SET SERFAC=$PIECE(APPPRM(SEND,0),U,2)
SET CNTRY=$PIECE(APPPRM(SEND,0),U,3)
+12 ;Get name of receiving application and facility
+13 SET CLNTAPP=$PIECE(APPPRM(CLIENT,0),U)
SET CLNTFAC=$PIECE(APPPRM(CLIENT,0),U,2)
+14 ;
+15 ; patch HL*1.6*120
+16 ; for dynamic addressing, overide the receiving facility from the
+17 ; 3rd component of HLL("LINKS") array
+18 IF $GET(HLP("REC-FACILITY"))]""
SET CLNTFAC=HLP("REC-FACILITY")
+19 ;
+20 ;Get field separator & encoding characters
+21 SET FS=APPPRM(SEND,"FS")
SET EC=APPPRM(SEND,"EC")
+22 if (EC="")
SET EC="~|\&"
if (FS="")
SET FS="^"
+23 ;Determine if it's a response/ACK to another message
+24 SET ACKTO=+$PIECE(CHILD,U,10)
+25 ;subscriber protocol is from child (file 773)
+26 ;If response, get MType from subscriber
+27 SET HLPROTS=+$PIECE(CHILD,U,8)
+28 SET PROTS=$$TYPE^HLUTIL2(HLPROTS)
+29 IF ACKTO
SET MSGTYPE=$PIECE(PROTS,U,10)
SET EVNTYPE=$PIECE(PROTS,U,3)
SET MSGEVN=$PIECE(PROTS,U,4)
+30 ;Get accept ack & application ack type (based on server protocol) it
+31 ; is always in file 772, TXPT0
+32 ;If original message, get MT from Event Driver Protocol
+33 SET HLPROT=+$PIECE(TXTP0,U,10)
+34 SET PROT=$$TYPE^HLUTIL2(HLPROT)
+35 if 'ACKTO
SET MSGTYPE=$PIECE(PROT,U,2)
SET EVNTYPE=$PIECE(PROT,U,3)
SET MSGEVN=$PIECE(PROT,U,4)
+36 SET ACCACK=$PIECE(PROT,U,7)
SET APPACK=$PIECE(PROT,U,8)
+37 ;
+38 ; patch HL*1.6*122
+39 ; setting the MSH-15 and MSH-16 from subscriber protocol
+40 IF HLPROTS
IF $PIECE($GET(^ORD(101,HLPROTS,773)),"^",5)
Begin DoDot:1
+41 SET ACCACK=$PIECE(PROTS,U,7)
+42 SET APPACK=$PIECE(PROTS,U,8)
End DoDot:1
+43 ;
PID ;Processing ID
+1 ;I PID not 'debug' get from site params
+2 ;If event driver set to 'debug' get from protocol
+3 ;'production' or 'training' comes from site params
+4 SET HLPID=$PIECE(PROT,U,5)
+5 IF $GET(HLPID)'="D"
SET HLPID=$PIECE(HLPARAM,U,3)
+6 ;
+7 ; patch HL*1.6*120: to include processing mode
+8 IF $GET(HLP("PMOD"))]""
IF ($GET(HLTYPE)="M")
Begin DoDot:1
+9 SET HLPID=HLPID_$EXTRACT($GET(EC),1)_HLP("PMOD")
End DoDot:1
+10 ;
+11 IF $GET(HLPID)=""
SET HLERROR="Missing processing ID Site parameter."
+12 ;acknowledgements have no application ack, link open no commit ack
+13 IF ACKTO
if APPACK]""
SET APPACK="NE"
if ACCACK]""&$GET(HLTCPO)
SET ACCACK="NE"
+14 ;Get date/time, Message ID, and security
+15 SET HLDATE=+TXTP0
SET HLDATE=$$FMTHL7^XLFDT(HLDATE)
SET HLID=$PIECE(CHILD,U,2)
SET SECURITY=$PIECE(CHILD,U,9)
HDR23 ;generate extended facility field info based on 'facility required'
+1 ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS'
+2 ;application parameter entry overrides default
+3 NEW HLEP773,HLS773
+4 SET SERFAC=$GET(SERFAC)
SET CLNTFAC=$GET(CLNTFAC)
+5 SET HLEP773=+$GET(^ORD(101,HLPROTS,773))
+6 SET HLS773=+$PIECE($GET(^ORD(101,HLPROTS,773)),U,2)
+7 if 'HLEP773&('HLS773)
QUIT
+8 DO GEN^HLCSHDR2
+9 IF ACKTO
Begin DoDot:1
+10 ;Find original message
+11 ;Find header in TCP nodes
SET X=$GET(^HLMA(ACKTO,"MSH",1,0))
+12 IF X["MSH"
Begin DoDot:2
+13 ;
+14 ; patch HL*1.6*120 start
+15 NEW HLEC
+16 SET HLFS=$EXTRACT(X,4)
SET HLEC=$EXTRACT(X,5)
+17 ;from original msg
SET SENDFAC=$PIECE(X,HLFS,4)
SET RECFAC=$PIECE(X,HLFS,6)
+18 ;reverse facility info
SET CLNTFAC=SENDFAC
SET SERFAC=RECFAC
+19 SET EC("COMPONENT")=$EXTRACT($GET(EC),1)
+20 IF $LENGTH(EC("COMPONENT"))=1
IF $LENGTH(HLEC)=1
IF EC("COMPONENT")'=HLEC
Begin DoDot:3
+21 ; change the the component separator in the sending and
+22 ; receiving facilities for the outgoing message
+23 SET CLNTFAC=$TRANSLATE(CLNTFAC,HLEC,EC("COMPONENT"))
+24 SET SERFAC=$TRANSLATE(SERFAC,HLEC,EC("COMPONENT"))
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+25 ; patch HL*1.6*120 end
+26 ;
+27 IF HLEP773
IF SERFAC=""
DO EP^HLCSHDR2
+28 IF HLS773
IF CLNTFAC=""
DO S^HLCSHDR2
+29 QUIT
+30 ;
ESCAPE(INPUT,COMPONET) ;
+1 ; patch HL*1.6*120 - escape delimiters:
+2 ; - field separator
+3 ; - component separator
+4 ; - repetition separator
+5 ; - escape character
+6 ; - subcomponent separator
+7 ;
+8 ; input:
+9 ; INPUT - string data to be escaped
+10 ; COMPONET - if 1, escape component separator
+11 ; if 0, do not escape component separator
+12 ; FS - field separator character
+13 ; EC - encoding characters
+14 ; result: return the escaped string
+15 ;
+16 NEW HLDATA,HLESCAPE,HLI,HLCHAR,HLEN,HLOUT,COMFLAG
+17 SET HLDATA=$GET(INPUT)
+18 SET COMFLAG=$GET(COMPONET)
+19 if $LENGTH($GET(FS))'=1
QUIT HLDATA
+20 ;
+21 ; patch HL*1.6*133
+22 ; Q:$L($G(EC))'=4 HLDATA
+23 if ($LENGTH($GET(EC))<3)
QUIT HLDATA
+24 if HLDATA']""
QUIT HLDATA
+25 ;
+26 SET HLESCAPE=FS_EC
+27 SET HLESCAPE("F")=FS
+28 SET HLESCAPE("S")=$EXTRACT(EC,1)
+29 SET HLESCAPE("R")=$EXTRACT(EC,2)
+30 SET HLESCAPE("E")=$EXTRACT(EC,3)
+31 SET HLESCAPE("T")=$EXTRACT(EC,4)
+32 SET HLEN=$LENGTH(HLDATA)
+33 SET HLOUT=""
+34 FOR HLI=1:1:HLEN
Begin DoDot:1
+35 SET HLCHAR=$EXTRACT(HLDATA,HLI)
+36 IF HLESCAPE[HLCHAR
Begin DoDot:2
+37 IF HLCHAR=HLESCAPE("F")
SET HLOUT=HLOUT_HLESCAPE("E")_"F"_HLESCAPE("E")
QUIT
+38 IF HLCHAR=HLESCAPE("S")
Begin DoDot:3
+39 IF COMFLAG=1
SET HLOUT=HLOUT_HLESCAPE("E")_"S"_HLESCAPE("E")
QUIT
+40 SET HLOUT=HLOUT_HLCHAR
End DoDot:3
QUIT
+41 IF HLCHAR=HLESCAPE("R")
SET HLOUT=HLOUT_HLESCAPE("E")_"R"_HLESCAPE("E")
QUIT
+42 IF HLCHAR=HLESCAPE("E")
SET HLOUT=HLOUT_HLESCAPE("E")_"E"_HLESCAPE("E")
QUIT
+43 IF HLCHAR=HLESCAPE("T")
SET HLOUT=HLOUT_HLESCAPE("E")_"T"_HLESCAPE("E")
QUIT
End DoDot:2
QUIT
+44 ;
+45 SET HLOUT=HLOUT_HLCHAR
End DoDot:1
+46 QUIT HLOUT
