HLTPCK1A ;SAW/AISC - Message Header Validation Routine for HL7 (Con't) ;03/24/2004 15:12
;;1.6;HEALTH LEVEL SEVEN;**2,25,34,57,59,108,171,174**;Oct 13, 1995;Build 6
;;Per VA Directive 6402, this routine should not be modified.
;
S ERR=""
SP ;Get local site parameters
S HLPARAM=$$PARAM^HLCS2,HLDOM=$P(HLPARAM,U,2),HLINSTN=$P(HLPARAM,U,6)
MT ;Validate message type
I (ARY("MTN")="") S:(ERR="") ERR="Invalid Message Type" Q
S ARY("MTP")=0
S:(ARY("MTN")'="") ARY("MTP")=+$O(^HL(771.2,"B",ARY("MTN"),0))
I ('ARY("MTP")) S:(ERR="") ERR="Invalid Message Type" Q
;
AT ;Determine if message is an acknowledgement type
I (("ACK,ADR,MCF,MFK,MFR,ORF,ORR,RRA,RRD,RRE,RRG,TBR"[ARY("MTN"))&($G(MSA)="")) S:(ERR="") ERR="MSA Segment Missing" Q
;
AAT ;Validate accept ack type and application ack type
I ($G(ARY("ACAT"))'="") I ("AL,NE,ER,SU"'[ARY("ACAT")) S:(ERR="") ERR="Invalid accept ack type" Q
I ($G(ARY("APAT"))'="") I ("AL,NE,ER,SU"'[ARY("APAT")) S:(ERR="") ERR="Invalid application ack type" Q
;
RA ;Validate receiving application
S ARY("RAN")=$P(HDR,FS,5)
I (ARY("RAN")="") S:(ERR="") ERR="Invalid Receiving Application" Q
S ARY("RAP")=0
;
; patch HL*1.6*108 start
;S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0))
S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
I (('ARY("RAP"))&(ARY("RAN")'="")) D
.S X=$$UPPER^HLFNC(ARY("RAN"))
.;S ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0))
.S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
; patch HL*1.6*108 end
;
I ('ARY("RAP")) S:(ERR="") ERR="Invalid Receiving Application" Q
S X2=$G(^HL(771,ARY("RAP"),0))
I (X2="") S:(ERR="") ERR="Invalid Receiving Application" Q
I ($P(X2,"^",2)'="a") S:(ERR="") ERR="Receiving Application is Inactive" Q
;
SA ;Validate sending application
S ARY("SAN")=$P(HDR,FS,3)
I (ARY("SAN")="") S:(ERR="") ERR="Invalid Sending Application" Q
S ARY("SAP")=0
;
; patch HL*1.6*108 start
;S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0))
S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
I (('ARY("SAP"))&(ARY("SAN")'="")) D
.S X=$$UPPER^HLFNC(ARY("SAN"))
.;S ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0))
.S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
; patch HL*1.6*108 end
;
I ('ARY("SAP")) S:(ERR="") ERR="Invalid Sending Application" Q
;
VN ;Validate version number
I (ARY("VER")="") S:(ERR="") ERR="Missing HL7 Version" Q
S X=0
S:(ARY("VER")'="") X=+$O(^HL(771.5,"B",ARY("VER"),0))
S ARY("VEP")=X
I ('X) S:(ERR="") ERR="Invalid HL7 Version" Q
;
ET ; Check for Event Type if version 2.2 or above
; if response use message id/original message to resolve event type
;I ARY("ETN")="",ARY("VER")>2.1,$G(MSA)'="" D Q:ERR]""
;. ;N HLZMID,HLZEP,HLZ770
;. ;S HLZMID=$O(^HL(772,"C",+$P(MSA,FS,2),0))
;. ;I HLZMID D
;.. ;I '$G(^HL(772,HLZMID,0)) S:(ERR="") ERR="Original Outgoing Message not found" Q
;.. ;S HLZEP=$P($G(^HL(772,HLZMID,0)),U,10)
;.. ;I HLZEP'>0 S:(ERR="") ERR="Event Protocol pointer (field #772,10) missing" Q
;.. ;S HLZ770=$G(^ORD(101,HLZEP,770))
;.. ;S ARY("ETN")=$P($G(^HL(779.001,+$P(HLZ770,U,4),0)),U)
;. ;K HLZMID,HLZEP,HLZ770
;
I (ARY("ETN")=""),ARY("VER")>2.1,$G(MSA)="" S:(ERR="") ERR="Event Type REQUIRED" Q
S ARY("ETP")=0
I $G(MSA)="",(ARY("ETN")'="") S ARY("ETP")=+$O(^HL(779.001,"B",ARY("ETN"),0)) I ('ARY("ETP")) S:(ERR="") ERR="Invalid Event Type" Q
;
MS ;Check for Message Structure Code
I $G(ARY("MTN_ETN"))'="" D
. S ARY("MTP_ETP")=0
. S ARY("MTP_ETP")=+$O(^HL(779.005,"B",ARY("MTN_ETN"),0))
. I ('ARY("MTP_ETP")) S:(ERR="") ERR="Invalid Message Structure Code" Q
;
MSA ;Get receiving application data from Protocol file
;I (ARY("SAP")) D Q:ERR]""
I $D(MSA) D Q
.;Message is an acknowledgement - deliver to Server Protocol that
.; message came from
.I '$G(ARY("SAP")) S ERR="Missing Sending Application" Q
.S ARY("MTIENS")=0
.F S ARY("MTIENS")=+$O(^HL(772,"AH",ARY("SAP"),$P(MSA,FS,2),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HL(772,+ARY("MTIENS"),0)),U,4)="O")
.S X=$G(^HL(772,+ARY("MTIENS"),0))
.S ARY("EIDS")=$P(X,"^",10)
.I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment" Q
.S ARY("MTIEN")=+$P(X,"^",8)
.S ARY("ACK")=$P(X,"^",7)
.S X=$G(^HL(772,+$P(X,"^",8),0))
.S ARY("EID")=$P(X,"^",10)
.I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
.D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
.;Get Logical Link info if defined on subscriber
.S ARY("LL")=$P($G(HLN(770)),"^",7)
;
I ARY("MTP") D
.;Find Server Protocol - based on sending application, message type,
.;event type and version ID
.;I ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0)) ; Removed in HL*1.6*171
.;
.;Find Server Protocol - based on sending application, message type,
.;and version ID
.;I 'ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0)) ; Removed in HL*1.6*171
.;
.N HL772 S HL772=0 F S HL772=$O(^HL(772,"C",ARY("MID"),HL772)) Q:HL772'>0 D Q:ARY("EID") ; HL*171 - Get file #772 IEN from "C" xref using message ID
..S ARY("EID")=HL772
..;HL*171 - If #772 entry matches date/time and sending application of message, save protocol from RELATED EVENT PROTOCOL field (#10) to ARY("EID")
..S:ARY("EID") ARY("EID")=$S($P(^HL(772,ARY("EID"),0),U,1)=$$HL7TFM^XLFDT(ARY("DTM"))&($P(^HL(772,ARY("EID"),0),U,2)=ARY("SAP")):$P(^HL(772,ARY("EID"),0),U,10),1:"")
.;HL*171 - If message was not found in file #772, try file #773
.I '$G(ARY("EID")) S ARY("EID")=$O(^HLMA("C",ARY("MID"),0)) S:ARY("EID") ARY("EID")=$P(^HLMA(ARY("EID"),0),U) S:ARY("EID") ARY("EID")=$P(^HL(772,ARY("EID"),0),U,10)
.;
.I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
.;Find Client Protocol - in ITEM multiple of Server Protocol
.S ARY("EIDS")=0
.F S ARY("EIDS")=+$O(^ORD(101,ARY("EID"),775,"B",ARY("EIDS"))) Q:('ARY("EIDS")) D Q:$G(X1)
..S (X,X1)=0
..S X=$G(^ORD(101,ARY("EIDS"),770))
..I $P(X,U,2)=ARY("RAP") S X1=1
.I 'ARY("EIDS") S:(ERR="") ERR="Invalid Receiving Application for this Event" Q
.D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
;
LLP ;Get logical link pointer
S ARY("LL")=$P($G(HLN(770)),"^",7)
;
FAC ;Get sending/rec facility, validate if necessary
;
S HLCS=$E(ECH,1) ;Get component separator
S ARY("RAF")=$P(HDR,FS,6) ;Receiving Facility
S ARY("SAF")=$P(HDR,FS,4) ;Sending Facility
;Get sending/receiving facility from Application Parameter file(771)
S HL771SF=$P($G(^HL(771,ARY("SAP"),0)),U,3)
S HL771RF=$P($G(^HL(771,ARY("RAP"),0)),U,3)
;Sending/Receiving facility required?
S X=$G(^ORD(101,ARY("EIDS"),773))
S HLSFREQ=+X,HLRFREQ=+$P(X,U,2)
RF ;Validate Receiving Facility
I HLRFREQ D
.I ARY("RAF")="" S:ERR="" ERR="Missing required receiving facility" Q
.I HL771RF]"" D Q
..;Facility data in 771 overrides data in site paramter file
..;For backward compatibility, don't validate
..Q
..Q:HL771RF=ARY("RAF")
..S:ERR="" ERR="Receiving Facility/App Parameter mismatch."
.;Check against local default value (site parameters)
.Q:ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS")
.S:ERR="" ERR="Receiving Facility mismatch."
SF ;Validate Sending Facility
N HLDOMPF,HLDOMPS,HLDOMX
I HLSFREQ D
.I ARY("SAF")="" S:ERR="" ERR="Missing required sending facility" Q
.I HL771SF]"" D Q
..;Check for facility data in 771
..Q
..Q:HL771SF=ARY("SAF")
..S:ERR="" ERR="Sending Facility/App Parameter mismatch."
.;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK
.;If so, use this instead of Protocol definition for return path
.;S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$O(^DIC(4.2,"B",HLDOMP,0))
.;Patch HL*1.6*174 updates logic to only extract the first 30 chars of the domain to adhere to the 30 char limit in the "B" cross reference
.S HLDOMPF=$P(ARY("SAF"),HLCS,2),HLDOMPS=$E(HLDOMPF,1,30) D
..I HLDOMPF=HLDOMPS S HLDOMP=$O(^DIC(4.2,"B",HLDOMPF,0)) Q ;If 30 or less characters, use exact match
..S HLDOMX=0 F S HLDOMX=$O(^DIC(4.2,"B",HLDOMPS,HLDOMX)) Q:'HLDOMX I $P(^DIC(4.2,HLDOMX,0),U)=HLDOMPF S HLDOMP=$O(^DIC(4.2,"B",HLDOMPS,0)) Q ;ensure you have the right entry for >30 characters
.I 'HLDOMP S:ERR="" ERR="Unrecognized domain in sending facility"
.Q:HLDOMP=$P(HLPARAM,U) ;This is local app to app
.I HLDOMP N HLNK S HLNK=+$O(^HLCS(870,"D",HLDOMP,0))
.I HLNK S ARY("LL")=HLNK
;
PID ;Validate processing ID
I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Invalid HL7 Processing ID" Q
S HLPID=$P(HLPARAM,U,3) ;site param
S X=$G(^ORD(101,ARY("EID"),770)),X=$P(X,U,6) ;event driver
;I X=""&($G(HLPID))="" S:ERR="" ERR="Cannot validate PROCESSING ID"
;If message is 'debug' then event driver must be 'debug.'
;If message is 'test' or 'production', then site param must match
I ARY("PID")="D"&(X'="D") S:ERR="" ERR="Processing ID Mismatch with Event Driver"
I ARY("PID")'="D"&(HLPID'=ARY("PID")) S:ERR="" ERR="Processing ID Mismatch with Site Parameters"
;
SEC ;Validate security field - access code and electronic signature
I ($P($G(HLN(773)),"^",3)) D
.S X=$P($P(HDR,FS,8),$E(ECH))
.S X=$$UPPER^HLFNC(X)
.D ^XUSHSH
.I ((X="")&('$D(MSA))) S:(ERR="") ERR="Invalid access code" Q
.S ARY("DUZ")=0
.S:(X'="") ARY("DUZ")=+$O(^VA(200,"A",X,0))
.I ('ARY("DUZ")) S:(ERR="") ERR="Invalid access code" Q
.I (($P($G(^VA(200,ARY("DUZ"),.1)),"^")="")&('$D(MSA))) S ARY("DUZ")=0 S:(ERR="") ERR="Invalid access code" Q
.S X=$P($P(HDR,FS,8),$E(ECH),3) I (X'="") D
..S X1=$G(^VA(200,ARY("DUZ"),20))
..I (X1="") S:(ERR="") ERR="No Signature Code on File" Q
..S X=$$UPPER^HLFNC(X)
..D HASH^XUSHSHP
..I ((X'=$P(X1,"^",4))!($P(X1,"^",2)="")) S:(ERR="") ERR="Invalid Electronic Signature Code" Q
..S ARY("ESIG")=$P(X1,"^",2)
I $D(ARY) M HLREC=ARY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLTPCK1A 9872 printed Oct 16, 2024@18:00:53 Page 2
HLTPCK1A ;SAW/AISC - Message Header Validation Routine for HL7 (Con't) ;03/24/2004 15:12
+1 ;;1.6;HEALTH LEVEL SEVEN;**2,25,34,57,59,108,171,174**;Oct 13, 1995;Build 6
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 SET ERR=""
SP ;Get local site parameters
+1 SET HLPARAM=$$PARAM^HLCS2
SET HLDOM=$PIECE(HLPARAM,U,2)
SET HLINSTN=$PIECE(HLPARAM,U,6)
MT ;Validate message type
+1 IF (ARY("MTN")="")
if (ERR="")
SET ERR="Invalid Message Type"
QUIT
+2 SET ARY("MTP")=0
+3 if (ARY("MTN")'="")
SET ARY("MTP")=+$ORDER(^HL(771.2,"B",ARY("MTN"),0))
+4 IF ('ARY("MTP"))
if (ERR="")
SET ERR="Invalid Message Type"
QUIT
+5 ;
AT ;Determine if message is an acknowledgement type
+1 IF (("ACK,ADR,MCF,MFK,MFR,ORF,ORR,RRA,RRD,RRE,RRG,TBR"[ARY("MTN"))&($GET(MSA)=""))
if (ERR="")
SET ERR="MSA Segment Missing"
QUIT
+2 ;
AAT ;Validate accept ack type and application ack type
+1 IF ($GET(ARY("ACAT"))'="")
IF ("AL,NE,ER,SU"'[ARY("ACAT"))
if (ERR="")
SET ERR="Invalid accept ack type"
QUIT
+2 IF ($GET(ARY("APAT"))'="")
IF ("AL,NE,ER,SU"'[ARY("APAT"))
if (ERR="")
SET ERR="Invalid application ack type"
QUIT
+3 ;
RA ;Validate receiving application
+1 SET ARY("RAN")=$PIECE(HDR,FS,5)
+2 IF (ARY("RAN")="")
if (ERR="")
SET ERR="Invalid Receiving Application"
QUIT
+3 SET ARY("RAP")=0
+4 ;
+5 ; patch HL*1.6*108 start
+6 ;S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0))
+7 if (ARY("RAN")'="")
SET ARY("RAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("RAN"),1,30),0))
+8 IF (('ARY("RAP"))&(ARY("RAN")'=""))
Begin DoDot:1
+9 SET X=$$UPPER^HLFNC(ARY("RAN"))
+10 ;S ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0))
+11 SET ARY("RAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("RAN"),1,30),0))
End DoDot:1
+12 ; patch HL*1.6*108 end
+13 ;
+14 IF ('ARY("RAP"))
if (ERR="")
SET ERR="Invalid Receiving Application"
QUIT
+15 SET X2=$GET(^HL(771,ARY("RAP"),0))
+16 IF (X2="")
if (ERR="")
SET ERR="Invalid Receiving Application"
QUIT
+17 IF ($PIECE(X2,"^",2)'="a")
if (ERR="")
SET ERR="Receiving Application is Inactive"
QUIT
+18 ;
SA ;Validate sending application
+1 SET ARY("SAN")=$PIECE(HDR,FS,3)
+2 IF (ARY("SAN")="")
if (ERR="")
SET ERR="Invalid Sending Application"
QUIT
+3 SET ARY("SAP")=0
+4 ;
+5 ; patch HL*1.6*108 start
+6 ;S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0))
+7 if (ARY("SAN")'="")
SET ARY("SAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("SAN"),1,30),0))
+8 IF (('ARY("SAP"))&(ARY("SAN")'=""))
Begin DoDot:1
+9 SET X=$$UPPER^HLFNC(ARY("SAN"))
+10 ;S ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0))
+11 SET ARY("SAP")=+$ORDER(^HL(771,"B",$EXTRACT(ARY("SAN"),1,30),0))
End DoDot:1
+12 ; patch HL*1.6*108 end
+13 ;
+14 IF ('ARY("SAP"))
if (ERR="")
SET ERR="Invalid Sending Application"
QUIT
+15 ;
VN ;Validate version number
+1 IF (ARY("VER")="")
if (ERR="")
SET ERR="Missing HL7 Version"
QUIT
+2 SET X=0
+3 if (ARY("VER")'="")
SET X=+$ORDER(^HL(771.5,"B",ARY("VER"),0))
+4 SET ARY("VEP")=X
+5 IF ('X)
if (ERR="")
SET ERR="Invalid HL7 Version"
QUIT
+6 ;
ET ; Check for Event Type if version 2.2 or above
+1 ; if response use message id/original message to resolve event type
+2 ;I ARY("ETN")="",ARY("VER")>2.1,$G(MSA)'="" D Q:ERR]""
+3 ;. ;N HLZMID,HLZEP,HLZ770
+4 ;. ;S HLZMID=$O(^HL(772,"C",+$P(MSA,FS,2),0))
+5 ;. ;I HLZMID D
+6 ;.. ;I '$G(^HL(772,HLZMID,0)) S:(ERR="") ERR="Original Outgoing Message not found" Q
+7 ;.. ;S HLZEP=$P($G(^HL(772,HLZMID,0)),U,10)
+8 ;.. ;I HLZEP'>0 S:(ERR="") ERR="Event Protocol pointer (field #772,10) missing" Q
+9 ;.. ;S HLZ770=$G(^ORD(101,HLZEP,770))
+10 ;.. ;S ARY("ETN")=$P($G(^HL(779.001,+$P(HLZ770,U,4),0)),U)
+11 ;. ;K HLZMID,HLZEP,HLZ770
+12 ;
+13 IF (ARY("ETN")="")
IF ARY("VER")>2.1
IF $GET(MSA)=""
if (ERR="")
SET ERR="Event Type REQUIRED"
QUIT
+14 SET ARY("ETP")=0
+15 IF $GET(MSA)=""
IF (ARY("ETN")'="")
SET ARY("ETP")=+$ORDER(^HL(779.001,"B",ARY("ETN"),0))
IF ('ARY("ETP"))
if (ERR="")
SET ERR="Invalid Event Type"
QUIT
+16 ;
MS ;Check for Message Structure Code
+1 IF $GET(ARY("MTN_ETN"))'=""
Begin DoDot:1
+2 SET ARY("MTP_ETP")=0
+3 SET ARY("MTP_ETP")=+$ORDER(^HL(779.005,"B",ARY("MTN_ETN"),0))
+4 IF ('ARY("MTP_ETP"))
if (ERR="")
SET ERR="Invalid Message Structure Code"
QUIT
End DoDot:1
+5 ;
MSA ;Get receiving application data from Protocol file
+1 ;I (ARY("SAP")) D Q:ERR]""
+2 IF $DATA(MSA)
Begin DoDot:1
+3 ;Message is an acknowledgement - deliver to Server Protocol that
+4 ; message came from
+5 IF '$GET(ARY("SAP"))
SET ERR="Missing Sending Application"
QUIT
+6 SET ARY("MTIENS")=0
+7 FOR
SET ARY("MTIENS")=+$ORDER(^HL(772,"AH",ARY("SAP"),$PIECE(MSA,FS,2),ARY("MTIENS")))
if 'ARY("MTIENS")!($PIECE($GET(^HL(772,+ARY("MTIENS"),0)),U,4)="O")
QUIT
+8 SET X=$GET(^HL(772,+ARY("MTIENS"),0))
+9 SET ARY("EIDS")=$PIECE(X,"^",10)
+10 IF ('ARY("EIDS"))
if (ERR="")
SET ERR="Invalid Message Control ID in MSA Segment"
QUIT
+11 SET ARY("MTIEN")=+$PIECE(X,"^",8)
+12 SET ARY("ACK")=$PIECE(X,"^",7)
+13 SET X=$GET(^HL(772,+$PIECE(X,"^",8),0))
+14 SET ARY("EID")=$PIECE(X,"^",10)
+15 IF ('ARY("EID"))
if (ERR="")
SET ERR="Event Protocol not found"
QUIT
+16 DO EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+17 ;Get Logical Link info if defined on subscriber
+18 SET ARY("LL")=$PIECE($GET(HLN(770)),"^",7)
End DoDot:1
QUIT
+19 ;
+20 IF ARY("MTP")
Begin DoDot:1
+21 ;Find Server Protocol - based on sending application, message type,
+22 ;event type and version ID
+23 ;I ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0)) ; Removed in HL*1.6*171
+24 ;
+25 ;Find Server Protocol - based on sending application, message type,
+26 ;and version ID
+27 ;I 'ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0)) ; Removed in HL*1.6*171
+28 ;
+29 ; HL*171 - Get file #772 IEN from "C" xref using message ID
NEW HL772
SET HL772=0
FOR
SET HL772=$ORDER(^HL(772,"C",ARY("MID"),HL772))
if HL772'>0
QUIT
Begin DoDot:2
+30 SET ARY("EID")=HL772
+31 ;HL*171 - If #772 entry matches date/time and sending application of message, save protocol from RELATED EVENT PROTOCOL field (#10) to ARY("EID")
+32 if ARY("EID")
SET ARY("EID")=$SELECT($PIECE(^HL(772,ARY("EID"),0),U,1)=$$HL7TFM^XLFDT(ARY("DTM"))&($PIECE(^HL(772,ARY("EID"),0),U,2)=ARY("SAP")):$PIECE(^HL(772,ARY("EID"),0),U,10),1:"")
End DoDot:2
if ARY("EID")
QUIT
+33 ;HL*171 - If message was not found in file #772, try file #773
+34 IF '$GET(ARY("EID"))
SET ARY("EID")=$ORDER(^HLMA("C",ARY("MID"),0))
if ARY("EID")
SET ARY("EID")=$PIECE(^HLMA(ARY("EID"),0),U)
if ARY("EID")
SET ARY("EID")=$PIECE(^HL(772,ARY("EID"),0),U,10)
+35 ;
+36 IF ('ARY("EID"))
if (ERR="")
SET ERR="Event Protocol not found"
QUIT
+37 ;Find Client Protocol - in ITEM multiple of Server Protocol
+38 SET ARY("EIDS")=0
+39 FOR
SET ARY("EIDS")=+$ORDER(^ORD(101,ARY("EID"),775,"B",ARY("EIDS")))
if ('ARY("EIDS"))
QUIT
Begin DoDot:2
+40 SET (X,X1)=0
+41 SET X=$GET(^ORD(101,ARY("EIDS"),770))
+42 IF $PIECE(X,U,2)=ARY("RAP")
SET X1=1
End DoDot:2
if $GET(X1)
QUIT
+43 IF 'ARY("EIDS")
if (ERR="")
SET ERR="Invalid Receiving Application for this Event"
QUIT
+44 DO EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
End DoDot:1
+45 ;
LLP ;Get logical link pointer
+1 SET ARY("LL")=$PIECE($GET(HLN(770)),"^",7)
+2 ;
FAC ;Get sending/rec facility, validate if necessary
+1 ;
+2 ;Get component separator
SET HLCS=$EXTRACT(ECH,1)
+3 ;Receiving Facility
SET ARY("RAF")=$PIECE(HDR,FS,6)
+4 ;Sending Facility
SET ARY("SAF")=$PIECE(HDR,FS,4)
+5 ;Get sending/receiving facility from Application Parameter file(771)
+6 SET HL771SF=$PIECE($GET(^HL(771,ARY("SAP"),0)),U,3)
+7 SET HL771RF=$PIECE($GET(^HL(771,ARY("RAP"),0)),U,3)
+8 ;Sending/Receiving facility required?
+9 SET X=$GET(^ORD(101,ARY("EIDS"),773))
+10 SET HLSFREQ=+X
SET HLRFREQ=+$PIECE(X,U,2)
RF ;Validate Receiving Facility
+1 IF HLRFREQ
Begin DoDot:1
+2 IF ARY("RAF")=""
if ERR=""
SET ERR="Missing required receiving facility"
QUIT
+3 IF HL771RF]""
Begin DoDot:2
+4 ;Facility data in 771 overrides data in site paramter file
+5 ;For backward compatibility, don't validate
+6 QUIT
+7 if HL771RF=ARY("RAF")
QUIT
+8 if ERR=""
SET ERR="Receiving Facility/App Parameter mismatch."
End DoDot:2
QUIT
+9 ;Check against local default value (site parameters)
+10 if ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS")
QUIT
+11 if ERR=""
SET ERR="Receiving Facility mismatch."
End DoDot:1
SF ;Validate Sending Facility
+1 NEW HLDOMPF,HLDOMPS,HLDOMX
+2 IF HLSFREQ
Begin DoDot:1
+3 IF ARY("SAF")=""
if ERR=""
SET ERR="Missing required sending facility"
QUIT
+4 IF HL771SF]""
Begin DoDot:2
+5 ;Check for facility data in 771
+6 QUIT
+7 if HL771SF=ARY("SAF")
QUIT
+8 if ERR=""
SET ERR="Sending Facility/App Parameter mismatch."
End DoDot:2
QUIT
+9 ;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK
+10 ;If so, use this instead of Protocol definition for return path
+11 ;S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$O(^DIC(4.2,"B",HLDOMP,0))
+12 ;Patch HL*1.6*174 updates logic to only extract the first 30 chars of the domain to adhere to the 30 char limit in the "B" cross reference
+13 SET HLDOMPF=$PIECE(ARY("SAF"),HLCS,2)
SET HLDOMPS=$EXTRACT(HLDOMPF,1,30)
Begin DoDot:2
+14 ;If 30 or less characters, use exact match
IF HLDOMPF=HLDOMPS
SET HLDOMP=$ORDER(^DIC(4.2,"B",HLDOMPF,0))
QUIT
+15 ;ensure you have the right entry for >30 characters
SET HLDOMX=0
FOR
SET HLDOMX=$ORDER(^DIC(4.2,"B",HLDOMPS,HLDOMX))
if 'HLDOMX
QUIT
IF $PIECE(^DIC(4.2,HLDOMX,0),U)=HLDOMPF
SET HLDOMP=$ORDER(^DIC(4.2,"B",HLDOMPS,0))
QUIT
End DoDot:2
+16 IF 'HLDOMP
if ERR=""
SET ERR="Unrecognized domain in sending facility"
+17 ;This is local app to app
if HLDOMP=$PIECE(HLPARAM,U)
QUIT
+18 IF HLDOMP
NEW HLNK
SET HLNK=+$ORDER(^HLCS(870,"D",HLDOMP,0))
+19 IF HLNK
SET ARY("LL")=HLNK
End DoDot:1
+20 ;
PID ;Validate processing ID
+1 IF ("DTP"'[ARY("PID"))
if (ERR="")
SET ERR="Invalid HL7 Processing ID"
QUIT
+2 ;site param
SET HLPID=$PIECE(HLPARAM,U,3)
+3 ;event driver
SET X=$GET(^ORD(101,ARY("EID"),770))
SET X=$PIECE(X,U,6)
+4 ;I X=""&($G(HLPID))="" S:ERR="" ERR="Cannot validate PROCESSING ID"
+5 ;If message is 'debug' then event driver must be 'debug.'
+6 ;If message is 'test' or 'production', then site param must match
+7 IF ARY("PID")="D"&(X'="D")
if ERR=""
SET ERR="Processing ID Mismatch with Event Driver"
+8 IF ARY("PID")'="D"&(HLPID'=ARY("PID"))
if ERR=""
SET ERR="Processing ID Mismatch with Site Parameters"
+9 ;
SEC ;Validate security field - access code and electronic signature
+1 IF ($PIECE($GET(HLN(773)),"^",3))
Begin DoDot:1
+2 SET X=$PIECE($PIECE(HDR,FS,8),$EXTRACT(ECH))
+3 SET X=$$UPPER^HLFNC(X)
+4 DO ^XUSHSH
+5 IF ((X="")&('$DATA(MSA)))
if (ERR="")
SET ERR="Invalid access code"
QUIT
+6 SET ARY("DUZ")=0
+7 if (X'="")
SET ARY("DUZ")=+$ORDER(^VA(200,"A",X,0))
+8 IF ('ARY("DUZ"))
if (ERR="")
SET ERR="Invalid access code"
QUIT
+9 IF (($PIECE($GET(^VA(200,ARY("DUZ"),.1)),"^")="")&('$DATA(MSA)))
SET ARY("DUZ")=0
if (ERR="")
SET ERR="Invalid access code"
QUIT
+10 SET X=$PIECE($PIECE(HDR,FS,8),$EXTRACT(ECH),3)
IF (X'="")
Begin DoDot:2
+11 SET X1=$GET(^VA(200,ARY("DUZ"),20))
+12 IF (X1="")
if (ERR="")
SET ERR="No Signature Code on File"
QUIT
+13 SET X=$$UPPER^HLFNC(X)
+14 DO HASH^XUSHSHP
+15 IF ((X'=$PIECE(X1,"^",4))!($PIECE(X1,"^",2)=""))
if (ERR="")
SET ERR="Invalid Electronic Signature Code"
QUIT
+16 SET ARY("ESIG")=$PIECE(X1,"^",2)
End DoDot:2
End DoDot:1
+17 IF $DATA(ARY)
MERGE HLREC=ARY
+18 QUIT
