HLTPCK2 ;SF/RSD - Message Header Validation (TCP Link) ;09/13/2006
;;1.6;HEALTH LEVEL SEVEN;**19,59,120,133**;Oct 13, 1995;Build 13
;Per VHA Directive 2004-038, this routine should not be modified.
CHK(HDR,ARY,MSA) ;
;Validate Data in Header Segment (MSH, BHS or FHS) of an HL7 Message
; through TCP link.
;
;This entry point is a subroutine call with parameter passing that
;will return an array (ARY()) consisting of values extracted from
;the message header segment subscripted by the mnemonics for each of
;the message header fields and components.
;The message header can be multiple line longer than 255 characters.
;HDR is an array that is passed by reference.
;If an error is encountered during validation, the array parameter
;(ARY) will be set equal to two pieces, error #^error text.
;
;Required input parameters
; HDR = Message header array, HDR(1,0)=segment (passed by reference)
;
; ARY = The array in which the message header values will be
; returned (passed by reference)
;
;Optional input parameter
; MSA = A variable which contains the message acknowledgement values:
; acknowledgement code^message control ID^text message. Passed
; by reference so that Batch msg. can set this here.
;
;Check for required parameters
N ERR S ERR=""
I $D(HDR)<10 S ERR="7^"_$G(^HL(771.7,7,0))_" at CHK^HLTPCK2" G EXIT
N ECH,HLN,FS,X,X1,X2
S ARY="",ARY("Q")=""""""
;
;Validate field separator and encoding characters
S (ARY("FS"),FS)=$E(HDR(1,0),4)
I FS']"" S ERR="Field Separator Missing" G EXIT
I FS?.C S ERR="Invalid Field Separator" G EXIT
S (ARY("ECH"),ECH)=$$P(.HDR,2)
I ECH']"" S ERR="Encoding Characters Missing" G EXIT
I ECH?.C S ERR="Invalid Encoding Characters" G EXIT
;
; patch HL*1.6*120 start
; patch HL*1.6*133
; escape and sub-component characters are optional
; I $L(ECH)'=4 S ERR="Invalid Encoding Characters" G EXIT
I $L(ECH)<1 S ERR="Invalid Encoding Characters" G EXIT
S ECH(1)=$E(ECH)
S ECH(2)=$E(ECH,2)
S ECH(3)=$E(ECH,3)
S ECH(4)=$E(ECH,4)
M ARY("HDR")=HDR
;
;Validate Message Header Type
S (ARY("TYPE"),X)=$$P(.HDR,1)
S ARY("HDR-1")=X
I X=""!("FHS,BHS,MSH"'[X) S ERR="Invalid Message Header" G EXIT
;
;Extract data from message header segment
; S ARY("SAN")=$$P(.HDR,3),ARY("SFN")=$$P(.HDR,4),ARY("RAN")=$$P(.HDR,5),ARY("RFN")=$$P(.HDR,6),ARY("DTM")=$$P(.HDR,7)
S ARY("SAN")=$$P(.HDR,3)
S ARY("SFN")=$$P(.HDR,4)
S ARY("RAN")=$$P(.HDR,5)
S ARY("RFN")=$$P(.HDR,6)
S ARY("DTM")=$$P(.HDR,7)
;
I X="BHS"!(X="FHS") D
. ; S ARY("MID")=$$P(.HDR,11),X=$$P(.HDR,9),ARY("PID")=$P(X,$E(ECH),2)
. ;
. S ARY("MID")=$$P(.HDR,11)
. ;
. ; BHS-9, Batch name/ID/Type:
. ; 2nd component: Processing ID <sub> Processing Mode
. ; 3rd component: Message Type <sub> Event Type
. ; 4th component: Version ID
. ; 5th component: Accept Acknowledgment Type
. ; 6th component: Application Acknowledgment Type
. S X=$$P(.HDR,9)
. S:X]"" ARY("HDR-9")=X
. ; original implementation incorrectly treats repetition separator as
. ; subcomponent separator
. S ECH("SUB-COMPONENT")=ECH(2)
. ; if subcomponent separator is correctly applied
. ; patch HL*1.6*133
. ; I X[ECH(4) S ECH("SUB-COMPONENT")=ECH(4)
. I ECH(4)]"",X[ECH(4) S ECH("SUB-COMPONENT")=ECH(4)
. ;
. S ARY("PID")=$P(X,ECH(1),2)
. ; patch HL*1.6*133
. ; I ARY("PID")[ECH("SUB-COMPONENT") D
. I ECH("SUB-COMPONENT")]"",ARY("PID")[ECH("SUB-COMPONENT") D
.. ; 2nd sub-component is Processing mode
.. S ARY("PMOD")=$P(ARY("PID"),ECH("SUB-COMPONENT"),2)
.. ; first sub-component is Processing id
.. S ARY("PID")=$P(ARY("PID"),ECH("SUB-COMPONENT"))
. ;
. ; S ARY("MTN")=$P($P(X,$E(ECH),3),$E(ECH,2)),ARY("ETN")=$P($P(X,$E(ECH),3),$E(ECH,2),2)
. ;
. S ARY("MTN")=$P(X,ECH(1),3)
. ; 2nd sub-component is event type
. ;
. ; patch HL*1.6*133 start
. S ARY("ETN")=""
. ; S ARY("ETN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"),2)
. I ECH("SUB-COMPONENT")]"" D
.. S ARY("ETN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"),2)
. ; 1st sub-component is message type
. ; S ARY("MTN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"))
. I ECH("SUB-COMPONENT")]"" D
.. S ARY("MTN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"))
. ; patch HL*1.6*133 end
. ;
. ; S ARY("VER")=$P(X,$E(ECH),4),ARY("ACAT")=$P(X,$E(ECH),5),ARY("APAT")=$P(X,$E(ECH),6)
. S ARY("VER")=$P(X,ECH(1),4)
. S:$P(X,ECH(1),5)]"" ARY("ACAT")=$P(X,ECH(1),5)
. S:$P(X,ECH(1),6)]"" ARY("APAT")=$P(X,ECH(1),6)
. ;
. ; BHS-10, batch comment
. ; first component: MSA-1, acknowledgment code
. ; 2nd component: MSA-3, text message
. ; S:$$P(.HDR,10)]"" MSA=$P($$P(.HDR,10),$E(ECH),1),$P(MSA,FS,2)=$$P(.HDR,12),$P(MSA,FS,3)=$P($$P(.HDR,10),$E(ECH),2)
. ;
. S X=$$P(.HDR,10)
. I X]"" D
.. S ARY("HDR-10")=X
.. ; MSA-1, acknowledgment code: AA,AE,AR,CA,CE,or CR
.. S MSA=$P(X,ECH(1),1)
.. ; MSA-2 and BHS-12, reference batch control id
.. S $P(MSA,FS,2)=$$P(.HDR,12)
.. ; MSA-3, text message
.. S $P(MSA,FS,3)=$P(X,ECH(1),2)
. ;
. ; Reference Batch Control ID
. S:$$P(.HDR,12)]"" ARY("HDR-12")=$$P(.HDR,12)
;
; I $$P(.HDR,1)="MSH" D
I ARY("HDR-1")="MSH" D
. ; S ARY("MID")=$$P(.HDR,10),ARY("PID")=$$P(.HDR,11),ARY("MTN")=$P($$P(.HDR,9),$E(ECH)),ARY("ETN")=$P($$P(.HDR,9),$E(ECH),2),ARY("VER")=$$P(.HDR,12)
. S ARY("MID")=$$P(.HDR,10)
. S ARY("PID")=$$P(.HDR,11)
. S X=$$P(.HDR,9)
. S ARY("MTN")=$P(X,ECH(1))
. S ARY("ETN")=$P(X,ECH(1),2)
. ;
. ; S:$P($$P(.HDR,9),$E(ECH),3)'="" ARY("MTN_ETN")=$P($$P(.HDR,9),$E(ECH),3)
. S:$P(X,ECH(1),3)]"" ARY("MTN_ETN")=$P(X,ECH(1),3)
. ;
. I ARY("PID")[ECH(1) D
.. ; 2nd component is Processing mode
.. S ARY("PMOD")=$P(ARY("PID"),ECH(1),2)
.. ; first component is Processing id
.. S ARY("PID")=$P(ARY("PID"),ECH(1))
. ;
. S ARY("VER")=$$P(.HDR,12)
. ;
. ; fields 13 and 14
. S:$$P(.HDR,13)]"" ARY("MSH-13")=$$P(.HDR,13)
. S:$$P(.HDR,14)]"" ARY("MSH-14")=$$P(.HDR,14)
. ;
. ; S:$$P(.HDR,15)]"" ARY("ACAT")=$$P(.HDR,15) S:$$P(.HDR,16)]"" ARY("APAT")=$$P(.HDR,16) S:$$P(.HDR,17)]"" ARY("CC")=$$P(.HDR,17)
. S:$$P(.HDR,15)]"" ARY("ACAT")=$$P(.HDR,15)
. S:$$P(.HDR,16)]"" ARY("APAT")=$$P(.HDR,16)
. S:$$P(.HDR,17)]"" ARY("CC")=$$P(.HDR,17)
. ;
. ; fields 18,19,20 and 21
. S:$$P(.HDR,18)]"" ARY("MSH-18")=$$P(.HDR,18)
. S:$$P(.HDR,19)]"" ARY("MSH-19")=$$P(.HDR,19)
. S:$$P(.HDR,20)]"" ARY("MSH-20")=$$P(.HDR,20)
. S:$$P(.HDR,21)]"" ARY("MSH-21")=$$P(.HDR,21)
;
;Invoke continuation routine to perform remaining validation checks
D ^HLTPCK2A
EXIT ;
; patch HL*1.6*120
; the maximum length of field #773,22 (Error Message) is 200
I ERR]"" D
. S ERR=$E(ERR,1,200)
. S ARY=$S('ERR:"13^"_ERR,1:ERR)
; patch HL*1.6*120 end
Q
;
P(MSH,P) ;get piece P from MSH array (passed by ref.)
N FS,I,L,L1,L2,X,Y
S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0))
. S:L1=1 L=L+1
. S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
. S L2=Y,Y=L
Q X
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLTPCK2 7079 printed Sep 23, 2025@19:36:13 Page 2
HLTPCK2 ;SF/RSD - Message Header Validation (TCP Link) ;09/13/2006
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,59,120,133**;Oct 13, 1995;Build 13
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
CHK(HDR,ARY,MSA) ;
+1 ;Validate Data in Header Segment (MSH, BHS or FHS) of an HL7 Message
+2 ; through TCP link.
+3 ;
+4 ;This entry point is a subroutine call with parameter passing that
+5 ;will return an array (ARY()) consisting of values extracted from
+6 ;the message header segment subscripted by the mnemonics for each of
+7 ;the message header fields and components.
+8 ;The message header can be multiple line longer than 255 characters.
+9 ;HDR is an array that is passed by reference.
+10 ;If an error is encountered during validation, the array parameter
+11 ;(ARY) will be set equal to two pieces, error #^error text.
+12 ;
+13 ;Required input parameters
+14 ; HDR = Message header array, HDR(1,0)=segment (passed by reference)
+15 ;
+16 ; ARY = The array in which the message header values will be
+17 ; returned (passed by reference)
+18 ;
+19 ;Optional input parameter
+20 ; MSA = A variable which contains the message acknowledgement values:
+21 ; acknowledgement code^message control ID^text message. Passed
+22 ; by reference so that Batch msg. can set this here.
+23 ;
+24 ;Check for required parameters
+25 NEW ERR
SET ERR=""
+26 IF $DATA(HDR)<10
SET ERR="7^"_$GET(^HL(771.7,7,0))_" at CHK^HLTPCK2"
GOTO EXIT
+27 NEW ECH,HLN,FS,X,X1,X2
+28 SET ARY=""
SET ARY("Q")=""""""
+29 ;
+30 ;Validate field separator and encoding characters
+31 SET (ARY("FS"),FS)=$EXTRACT(HDR(1,0),4)
+32 IF FS']""
SET ERR="Field Separator Missing"
GOTO EXIT
+33 IF FS?.C
SET ERR="Invalid Field Separator"
GOTO EXIT
+34 SET (ARY("ECH"),ECH)=$$P(.HDR,2)
+35 IF ECH']""
SET ERR="Encoding Characters Missing"
GOTO EXIT
+36 IF ECH?.C
SET ERR="Invalid Encoding Characters"
GOTO EXIT
+37 ;
+38 ; patch HL*1.6*120 start
+39 ; patch HL*1.6*133
+40 ; escape and sub-component characters are optional
+41 ; I $L(ECH)'=4 S ERR="Invalid Encoding Characters" G EXIT
+42 IF $LENGTH(ECH)<1
SET ERR="Invalid Encoding Characters"
GOTO EXIT
+43 SET ECH(1)=$EXTRACT(ECH)
+44 SET ECH(2)=$EXTRACT(ECH,2)
+45 SET ECH(3)=$EXTRACT(ECH,3)
+46 SET ECH(4)=$EXTRACT(ECH,4)
+47 MERGE ARY("HDR")=HDR
+48 ;
+49 ;Validate Message Header Type
+50 SET (ARY("TYPE"),X)=$$P(.HDR,1)
+51 SET ARY("HDR-1")=X
+52 IF X=""!("FHS,BHS,MSH"'[X)
SET ERR="Invalid Message Header"
GOTO EXIT
+53 ;
+54 ;Extract data from message header segment
+55 ; S ARY("SAN")=$$P(.HDR,3),ARY("SFN")=$$P(.HDR,4),ARY("RAN")=$$P(.HDR,5),ARY("RFN")=$$P(.HDR,6),ARY("DTM")=$$P(.HDR,7)
+56 SET ARY("SAN")=$$P(.HDR,3)
+57 SET ARY("SFN")=$$P(.HDR,4)
+58 SET ARY("RAN")=$$P(.HDR,5)
+59 SET ARY("RFN")=$$P(.HDR,6)
+60 SET ARY("DTM")=$$P(.HDR,7)
+61 ;
+62 IF X="BHS"!(X="FHS")
Begin DoDot:1
+63 ; S ARY("MID")=$$P(.HDR,11),X=$$P(.HDR,9),ARY("PID")=$P(X,$E(ECH),2)
+64 ;
+65 SET ARY("MID")=$$P(.HDR,11)
+66 ;
+67 ; BHS-9, Batch name/ID/Type:
+68 ; 2nd component: Processing ID <sub> Processing Mode
+69 ; 3rd component: Message Type <sub> Event Type
+70 ; 4th component: Version ID
+71 ; 5th component: Accept Acknowledgment Type
+72 ; 6th component: Application Acknowledgment Type
+73 SET X=$$P(.HDR,9)
+74 if X]""
SET ARY("HDR-9")=X
+75 ; original implementation incorrectly treats repetition separator as
+76 ; subcomponent separator
+77 SET ECH("SUB-COMPONENT")=ECH(2)
+78 ; if subcomponent separator is correctly applied
+79 ; patch HL*1.6*133
+80 ; I X[ECH(4) S ECH("SUB-COMPONENT")=ECH(4)
+81 IF ECH(4)]""
IF X[ECH(4)
SET ECH("SUB-COMPONENT")=ECH(4)
+82 ;
+83 SET ARY("PID")=$PIECE(X,ECH(1),2)
+84 ; patch HL*1.6*133
+85 ; I ARY("PID")[ECH("SUB-COMPONENT") D
+86 IF ECH("SUB-COMPONENT")]""
IF ARY("PID")[ECH("SUB-COMPONENT")
Begin DoDot:2
+87 ; 2nd sub-component is Processing mode
+88 SET ARY("PMOD")=$PIECE(ARY("PID"),ECH("SUB-COMPONENT"),2)
+89 ; first sub-component is Processing id
+90 SET ARY("PID")=$PIECE(ARY("PID"),ECH("SUB-COMPONENT"))
End DoDot:2
+91 ;
+92 ; S ARY("MTN")=$P($P(X,$E(ECH),3),$E(ECH,2)),ARY("ETN")=$P($P(X,$E(ECH),3),$E(ECH,2),2)
+93 ;
+94 SET ARY("MTN")=$PIECE(X,ECH(1),3)
+95 ; 2nd sub-component is event type
+96 ;
+97 ; patch HL*1.6*133 start
+98 SET ARY("ETN")=""
+99 ; S ARY("ETN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"),2)
+100 IF ECH("SUB-COMPONENT")]""
Begin DoDot:2
+101 SET ARY("ETN")=$PIECE(ARY("MTN"),ECH("SUB-COMPONENT"),2)
End DoDot:2
+102 ; 1st sub-component is message type
+103 ; S ARY("MTN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"))
+104 IF ECH("SUB-COMPONENT")]""
Begin DoDot:2
+105 SET ARY("MTN")=$PIECE(ARY("MTN"),ECH("SUB-COMPONENT"))
End DoDot:2
+106 ; patch HL*1.6*133 end
+107 ;
+108 ; S ARY("VER")=$P(X,$E(ECH),4),ARY("ACAT")=$P(X,$E(ECH),5),ARY("APAT")=$P(X,$E(ECH),6)
+109 SET ARY("VER")=$PIECE(X,ECH(1),4)
+110 if $PIECE(X,ECH(1),5)]""
SET ARY("ACAT")=$PIECE(X,ECH(1),5)
+111 if $PIECE(X,ECH(1),6)]""
SET ARY("APAT")=$PIECE(X,ECH(1),6)
+112 ;
+113 ; BHS-10, batch comment
+114 ; first component: MSA-1, acknowledgment code
+115 ; 2nd component: MSA-3, text message
+116 ; S:$$P(.HDR,10)]"" MSA=$P($$P(.HDR,10),$E(ECH),1),$P(MSA,FS,2)=$$P(.HDR,12),$P(MSA,FS,3)=$P($$P(.HDR,10),$E(ECH),2)
+117 ;
+118 SET X=$$P(.HDR,10)
+119 IF X]""
Begin DoDot:2
+120 SET ARY("HDR-10")=X
+121 ; MSA-1, acknowledgment code: AA,AE,AR,CA,CE,or CR
+122 SET MSA=$PIECE(X,ECH(1),1)
+123 ; MSA-2 and BHS-12, reference batch control id
+124 SET $PIECE(MSA,FS,2)=$$P(.HDR,12)
+125 ; MSA-3, text message
+126 SET $PIECE(MSA,FS,3)=$PIECE(X,ECH(1),2)
End DoDot:2
+127 ;
+128 ; Reference Batch Control ID
+129 if $$P(.HDR,12)]""
SET ARY("HDR-12")=$$P(.HDR,12)
End DoDot:1
+130 ;
+131 ; I $$P(.HDR,1)="MSH" D
+132 IF ARY("HDR-1")="MSH"
Begin DoDot:1
+133 ; S ARY("MID")=$$P(.HDR,10),ARY("PID")=$$P(.HDR,11),ARY("MTN")=$P($$P(.HDR,9),$E(ECH)),ARY("ETN")=$P($$P(.HDR,9),$E(ECH),2),ARY("VER")=$$P(.HDR,12)
+134 SET ARY("MID")=$$P(.HDR,10)
+135 SET ARY("PID")=$$P(.HDR,11)
+136 SET X=$$P(.HDR,9)
+137 SET ARY("MTN")=$PIECE(X,ECH(1))
+138 SET ARY("ETN")=$PIECE(X,ECH(1),2)
+139 ;
+140 ; S:$P($$P(.HDR,9),$E(ECH),3)'="" ARY("MTN_ETN")=$P($$P(.HDR,9),$E(ECH),3)
+141 if $PIECE(X,ECH(1),3)]""
SET ARY("MTN_ETN")=$PIECE(X,ECH(1),3)
+142 ;
+143 IF ARY("PID")[ECH(1)
Begin DoDot:2
+144 ; 2nd component is Processing mode
+145 SET ARY("PMOD")=$PIECE(ARY("PID"),ECH(1),2)
+146 ; first component is Processing id
+147 SET ARY("PID")=$PIECE(ARY("PID"),ECH(1))
End DoDot:2
+148 ;
+149 SET ARY("VER")=$$P(.HDR,12)
+150 ;
+151 ; fields 13 and 14
+152 if $$P(.HDR,13)]""
SET ARY("MSH-13")=$$P(.HDR,13)
+153 if $$P(.HDR,14)]""
SET ARY("MSH-14")=$$P(.HDR,14)
+154 ;
+155 ; S:$$P(.HDR,15)]"" ARY("ACAT")=$$P(.HDR,15) S:$$P(.HDR,16)]"" ARY("APAT")=$$P(.HDR,16) S:$$P(.HDR,17)]"" ARY("CC")=$$P(.HDR,17)
+156 if $$P(.HDR,15)]""
SET ARY("ACAT")=$$P(.HDR,15)
+157 if $$P(.HDR,16)]""
SET ARY("APAT")=$$P(.HDR,16)
+158 if $$P(.HDR,17)]""
SET ARY("CC")=$$P(.HDR,17)
+159 ;
+160 ; fields 18,19,20 and 21
+161 if $$P(.HDR,18)]""
SET ARY("MSH-18")=$$P(.HDR,18)
+162 if $$P(.HDR,19)]""
SET ARY("MSH-19")=$$P(.HDR,19)
+163 if $$P(.HDR,20)]""
SET ARY("MSH-20")=$$P(.HDR,20)
+164 if $$P(.HDR,21)]""
SET ARY("MSH-21")=$$P(.HDR,21)
End DoDot:1
+165 ;
+166 ;Invoke continuation routine to perform remaining validation checks
+167 DO ^HLTPCK2A
EXIT ;
+1 ; patch HL*1.6*120
+2 ; the maximum length of field #773,22 (Error Message) is 200
+3 IF ERR]""
Begin DoDot:1
+4 SET ERR=$EXTRACT(ERR,1,200)
+5 SET ARY=$SELECT('ERR:"13^"_ERR,1:ERR)
End DoDot:1
+6 ; patch HL*1.6*120 end
+7 QUIT
+8 ;
P(MSH,P) ;get piece P from MSH array (passed by ref.)
+1 NEW FS,I,L,L1,L2,X,Y
+2 SET FS=$EXTRACT(MSH(1,0),4)
SET (L2,Y)=0
SET X=""
+3 FOR I=1:1
SET L1=$LENGTH($GET(MSH(I,0)),FS)
SET L=L1+Y-1
Begin DoDot:1
+4 if L1=1
SET L=L+1
+5 if P'>L
SET X=$PIECE($GET(MSH(I-1,0)),FS,P-L2)_$PIECE($GET(MSH(I,0)),FS,(P-Y))
+6 SET L2=Y
SET Y=L
End DoDot:1
if $LENGTH(X)!'$DATA(MSH(I,0))
QUIT
+7 QUIT X
+8 ;
