HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ; 09/22/2009 14:41
;;1.6;HEALTH LEVEL SEVEN;**120,133,122,148,163**;Oct 13, 1995;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
; splitted from HLTPCK2A
; to be called from HLTPCK2A
;
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
;
;Get server and client Protocols
MSA ;if ack, then get information and quit, we don't need to respond
I $G(MSA)]"" D Q
. ;Message is an acknowledgement, find original message
. S ARY("MSAID")=$P(MSA,FS,2),ARY("MTIENS")=0
. I ARY("MSAID")="" S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Message ID" Q
. F S ARY("MTIENS")=+$O(^HLMA("AH",ARY("SAP"),ARY("MSAID"),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HLMA(ARY("MTIENS"),0)),U,3)="O")
. I 'ARY("MTIENS") S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""AH"" x-ref" Q
. ;get subscriber protocol and ack. to (show if this is an ack to an ack)
. S X=$G(^HLMA(ARY("MTIENS"),0)),ARY("EIDS")=$P(X,U,8),ARY("ACK")=$P(X,U,10)
. ;if no subscriber protocol then response msg. is invalid
. ;
. ; patch HL*1.6*122 start
. ; comment out the following code: for patch 109- dynamic addressing
. ; I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q
. ;get message text ien in file 772 and server protocol, 'EID'
. S ARY("MTIEN")=+X,X=$G(^HL(772,+X,0)),ARY("EID")=$P(X,U,10)
. I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
. ; D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
. I ARY("EIDS") D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
. ; patch HL*1.6*122 end
;
;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))
;
;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))
;
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")!($P($G(^ORD(101,ARY("EIDS"),770)),U,2)=ARY("RAP"))
I 'ARY("EIDS") S 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^HLTPCK2(.HDR,6) ;Receiving Facility
S ARY("SAF")=$$P^HLTPCK2(.HDR,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"
.I HL771RF]"" D Q
..;Facility data in 771 overrides data in site paramter file
..Q
.;Check against local default value (site parameters)
.Q:ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS")
.;
.; patch HL*1.6*120 start
.; I $P(ARY("RAF"),HLCS)=HLINSTN,$P(ARY("RAF"),HLCS,3)="DNS" D Q
. I $P(ARY("RAF"),HLCS,3)="DNS" D Q
.. N ERROR,HLDOMP1,HLDOMP2
.. ; S HLDOMP1=$P(ARY("RAF"),HLCS,2),HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
.. S HLDOMP1=$P(ARY("RAF"),HLCS,2)
.. ;
.. ; assume the format is <domain>:<port #>
.. ; patch HL*1.6*163 can no longer assume one format for <domain><port> with IPV6
.. ; check for IPV6 address with delimiter of "]:" and process accordingly
.. ; ;$$FORCEIP6^XLFIPV(IP) API (ICR #5844)
.. I HLDOMP1["]" D
... S ARY("RAF-PORT")=$P(HLDOMP1,"]:",2)
... S HLDOMP1=$E($P(HLDOMP1,"]"),2,99)
... S HLDOMP1=$$FORCEIP6^XLFIPV(HLDOMP1)
.. E I HLDOMP1[":" D
...S ARY("RAF-PORT")=$P(HLDOMP1,":",2)
...S HLDOMP1=$P(HLDOMP1,":")
..S ARY("RAF-DOMAIN")=HLDOMP1
.. ;
.. ; if first piece of domain is "HL7." or "MPI.", remove it
.. I ($E(HLDOMP1,1,4)="HL7.")!($E(HLDOMP1,1,4)="MPI.") D
... S HLDOMP1=$P(HLDOMP1,".",2,99)
.. S HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
.. S HLDOMP2=HLDOM,HLDOMP2=$$FIND1^DIC(4.2,"","BMX",HLDOMP2,"B^C","","ERROR")
.. I HLDOMP1&HLDOMP2&(HLDOMP1=HLDOMP2) Q
.. ;
.. ; check DNS domain and ip address
.. ;initialize variable, HLDOMP("FLAG")
.. S HLDOMP("FLAG")=0
.. I ARY("RAF-DOMAIN")]"" D
... ;
... ; match DNS domain
... I $D(^HLCS(870,"DNS",ARY("RAF-DOMAIN"))) D Q
.... S HLDOMP("FLAG")=1
.... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",ARY("RAF-DOMAIN"),0))
... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")))) D Q
.... S HLDOMP("FLAG")=1
.... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")),0))
... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")))) D Q
.... S HLDOMP("FLAG")=1
.... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")),0))
... ;
... ; match ip address
... I $D(^HLCS(870,"IP",ARY("RAF-DOMAIN"))) D Q
.... S HLDOMP("FLAG")=1
.... S ARY("RAF-LL")=+$O(^HLCS(870,"IP",ARY("RAF-DOMAIN"),0))
.. Q:HLDOMP("FLAG")=1
.. I $P(ARY("RAF"),HLCS)=HLINSTN Q
.. ;
.. ; patch HL*1.6*148
.. ; S:ERR="" ERR="Receiving Facility mismatch."
.. S:ERR="" ERR="Receiving Facility Mismatch."
. I $P(ARY("RAF"),HLCS)=HLINSTN Q
. ; patch HL*1.6*148
. ; S:ERR="" ERR="Receiving Facility mismatch."
. S:ERR="" ERR="Receiving facility mismatch."
; patch HL*1.6*120 end
;
SF ;Validate Sending Facility
I HLSFREQ D
.I ARY("SAF")="" S:ERR="" ERR="Missing required sending facility"
.I HL771SF]"" D Q
..;Check for facility data in 771
..Q
.;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK
.;If so, use this instead of Protocol definition for return path
.;
.; patch HL*1.6*120 start
. N HLDOMP
. ; S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
. S HLDOMP=$P(ARY("SAF"),HLCS,2)
. ;
. ; assume the format is <domain>:<port #>
. ; patch HL*1.6*163 can no longer assume one format for <domain><port> with IPV6
. ; check for IPV6 address with delimiter of "]:" and process accordingly
. ; ;$$FORCEIP6^XLFIPV(IP) API (ICR #5844)
. I HLDOMP["]" D
.. S ARY("SAF-PORT")=$P(HLDOMP,"]:",2)
.. S HLDOMP=$E($P(HLDOMP,"]"),2,99)
.. S HLDOMP=$$FORCEIP6^XLFIPV(HLDOMP)
. E I HLDOMP[":" D
.. S ARY("SAF-PORT")=$P(HLDOMP,":",2)
.. S HLDOMP=$P(HLDOMP,":")
. S ARY("SAF-DOMAIN")=HLDOMP
. ;
. ; if first piece of domain is "HL7." or "MPI.", remove it
. I ($E(HLDOMP,1,4)="HL7.")!($E(HLDOMP,1,4)="MPI.") D
.. S HLDOMP=$P(HLDOMP,".",2,99)
. S HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
.;Note: This expects a unique domain in domain file. Multiple entries will fail
. ; I 'HLDOMP S:ERR="" ERR="Unrecognized/ambiguous domain in sending facility"
. ;
. ; check DNS domain and ip address
. I 'HLDOMP D
.. ;
.. ;initialize variable, HLDOMP("FLAG")
.. S HLDOMP("FLAG")=0
.. I ARY("SAF-DOMAIN")]"" D
... ;
... ; match DNS domain
... I $D(^HLCS(870,"DNS",ARY("SAF-DOMAIN"))) D Q
.... S HLDOMP("FLAG")=1
.... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",ARY("SAF-DOMAIN"),0))
... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")))) D Q
.... S HLDOMP("FLAG")=1
.... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")),0))
... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")))) D Q
.... S HLDOMP("FLAG")=1
.... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")),0))
... ;
... ; match ip address
... I $D(^HLCS(870,"IP",ARY("SAF-DOMAIN"))) D Q
.... S HLDOMP("FLAG")=1
.... S ARY("SAF-LL")=+$O(^HLCS(870,"IP",ARY("SAF-DOMAIN"),0))
.. Q:HLDOMP("FLAG")=1
.. ; quit if 1st component defined
.. S ARY("SAF-COMPONENT1")=$P(ARY("SAF"),HLCS,1)
.. Q:ARY("SAF-COMPONENT1")]""
.. ; patch HL*1.6*148
.. ; S:ERR="" ERR="Receiving Facility mismatch."
.. S:ERR="" ERR="Sending Facility mismatch."
. ; patch HL*1.6*120 end
. ;
.Q:HLDOMP=$P(HLPARAM,U) ;This is local app to app
.I HLDOMP N HLNK S HLNK=+$O(^HLCS(870,"D",HLDOMP,0))
.I $G(HLNK) S ARY("LL")=HLNK
;
PID ;Validate processing ID
I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Invalid HL7 Processing ID"
S HLPID=$P(HLPARAM,U,3) ;site param
S X=$G(^ORD(101,ARY("EID"),770)),X=$P(X,U,6) ;event driver
;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^HLTPCK2(.HDR,8),$E(ECH))
.S X=$$UPPER^HLFNC(X)
.D ^XUSHSH
.I X="",(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^HLTPCK2(.HDR,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[HHLTPCK2B 9921 printed Oct 16, 2024@18:00:55 Page 2
HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ; 09/22/2009 14:41
+1 ;;1.6;HEALTH LEVEL SEVEN;**120,133,122,148,163**;Oct 13, 1995;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; splitted from HLTPCK2A
+5 ; to be called from HLTPCK2A
+6 ;
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 ;
+6 ;Get server and client Protocols
MSA ;if ack, then get information and quit, we don't need to respond
+1 IF $GET(MSA)]""
Begin DoDot:1
+2 ;Message is an acknowledgement, find original message
+3 SET ARY("MSAID")=$PIECE(MSA,FS,2)
SET ARY("MTIENS")=0
+4 IF ARY("MSAID")=""
if (ERR="")
SET ERR="Invalid Message Control ID in MSA Segment - No Message ID"
QUIT
+5 FOR
SET ARY("MTIENS")=+$ORDER(^HLMA("AH",ARY("SAP"),ARY("MSAID"),ARY("MTIENS")))
if 'ARY("MTIENS")!($PIECE($GET(^HLMA(ARY("MTIENS"),0)),U,3)="O")
QUIT
+6 IF 'ARY("MTIENS")
if (ERR="")
SET ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""AH"" x-ref"
QUIT
+7 ;get subscriber protocol and ack. to (show if this is an ack to an ack)
+8 SET X=$GET(^HLMA(ARY("MTIENS"),0))
SET ARY("EIDS")=$PIECE(X,U,8)
SET ARY("ACK")=$PIECE(X,U,10)
+9 ;if no subscriber protocol then response msg. is invalid
+10 ;
+11 ; patch HL*1.6*122 start
+12 ; comment out the following code: for patch 109- dynamic addressing
+13 ; I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q
+14 ;get message text ien in file 772 and server protocol, 'EID'
+15 SET ARY("MTIEN")=+X
SET X=$GET(^HL(772,+X,0))
SET ARY("EID")=$PIECE(X,U,10)
+16 IF ('ARY("EID"))
if (ERR="")
SET ERR="Event Protocol not found"
QUIT
+17 ; D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+18 IF ARY("EIDS")
DO EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+19 ; patch HL*1.6*122 end
End DoDot:1
QUIT
+20 ;
+21 ;Find Server Protocol - based on sending application, message type,
+22 ;event type and version ID
+23 IF ARY("ETP")
SET ARY("EID")=+$ORDER(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0))
+24 ;
+25 ;Find Server Protocol - based on sending application, message type,
+26 ;and version ID
+27 IF 'ARY("ETP")
SET ARY("EID")=+$ORDER(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0))
+28 ;
+29 IF ('ARY("EID"))
if (ERR="")
SET ERR="Event Protocol not found"
QUIT
+30 ;Find Client Protocol - in ITEM multiple of Server Protocol
+31 SET ARY("EIDS")=0
+32 FOR
SET ARY("EIDS")=+$ORDER(^ORD(101,ARY("EID"),775,"B",ARY("EIDS")))
if 'ARY("EIDS")!($PIECE($GET(^ORD(101,ARY("EIDS"),770)),U,2)=ARY("RAP"))
QUIT
+33 IF 'ARY("EIDS")
SET ERR="Invalid Receiving Application for this Event"
QUIT
+34 DO EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+35 ;
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")=$$P^HLTPCK2(.HDR,6)
+4 ;Sending Facility
SET ARY("SAF")=$$P^HLTPCK2(.HDR,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"
+3 IF HL771RF]""
Begin DoDot:2
+4 ;Facility data in 771 overrides data in site paramter file
+5 QUIT
End DoDot:2
QUIT
+6 ;Check against local default value (site parameters)
+7 if ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS")
QUIT
+8 ;
+9 ; patch HL*1.6*120 start
+10 ; I $P(ARY("RAF"),HLCS)=HLINSTN,$P(ARY("RAF"),HLCS,3)="DNS" D Q
+11 IF $PIECE(ARY("RAF"),HLCS,3)="DNS"
Begin DoDot:2
+12 NEW ERROR,HLDOMP1,HLDOMP2
+13 ; S HLDOMP1=$P(ARY("RAF"),HLCS,2),HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
+14 SET HLDOMP1=$PIECE(ARY("RAF"),HLCS,2)
+15 ;
+16 ; assume the format is <domain>:<port #>
+17 ; patch HL*1.6*163 can no longer assume one format for <domain><port> with IPV6
+18 ; check for IPV6 address with delimiter of "]:" and process accordingly
+19 ; ;$$FORCEIP6^XLFIPV(IP) API (ICR #5844)
+20 IF HLDOMP1["]"
Begin DoDot:3
+21 SET ARY("RAF-PORT")=$PIECE(HLDOMP1,"]:",2)
+22 SET HLDOMP1=$EXTRACT($PIECE(HLDOMP1,"]"),2,99)
+23 SET HLDOMP1=$$FORCEIP6^XLFIPV(HLDOMP1)
End DoDot:3
+24 IF '$TEST
IF HLDOMP1[":"
Begin DoDot:3
+25 SET ARY("RAF-PORT")=$PIECE(HLDOMP1,":",2)
+26 SET HLDOMP1=$PIECE(HLDOMP1,":")
End DoDot:3
+27 SET ARY("RAF-DOMAIN")=HLDOMP1
+28 ;
+29 ; if first piece of domain is "HL7." or "MPI.", remove it
+30 IF ($EXTRACT(HLDOMP1,1,4)="HL7.")!($EXTRACT(HLDOMP1,1,4)="MPI.")
Begin DoDot:3
+31 SET HLDOMP1=$PIECE(HLDOMP1,".",2,99)
End DoDot:3
+32 SET HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
+33 SET HLDOMP2=HLDOM
SET HLDOMP2=$$FIND1^DIC(4.2,"","BMX",HLDOMP2,"B^C","","ERROR")
+34 IF HLDOMP1&HLDOMP2&(HLDOMP1=HLDOMP2)
QUIT
+35 ;
+36 ; check DNS domain and ip address
+37 ;initialize variable, HLDOMP("FLAG")
+38 SET HLDOMP("FLAG")=0
+39 IF ARY("RAF-DOMAIN")]""
Begin DoDot:3
+40 ;
+41 ; match DNS domain
+42 IF $DATA(^HLCS(870,"DNS",ARY("RAF-DOMAIN")))
Begin DoDot:4
+43 SET HLDOMP("FLAG")=1
+44 SET ARY("RAF-LL")=+$ORDER(^HLCS(870,"DNS",ARY("RAF-DOMAIN"),0))
End DoDot:4
QUIT
+45 IF $DATA(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN"))))
Begin DoDot:4
+46 SET HLDOMP("FLAG")=1
+47 SET ARY("RAF-LL")=+$ORDER(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")),0))
End DoDot:4
QUIT
+48 IF $DATA(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN"))))
Begin DoDot:4
+49 SET HLDOMP("FLAG")=1
+50 SET ARY("RAF-LL")=+$ORDER(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")),0))
End DoDot:4
QUIT
+51 ;
+52 ; match ip address
+53 IF $DATA(^HLCS(870,"IP",ARY("RAF-DOMAIN")))
Begin DoDot:4
+54 SET HLDOMP("FLAG")=1
+55 SET ARY("RAF-LL")=+$ORDER(^HLCS(870,"IP",ARY("RAF-DOMAIN"),0))
End DoDot:4
QUIT
End DoDot:3
+56 if HLDOMP("FLAG")=1
QUIT
+57 IF $PIECE(ARY("RAF"),HLCS)=HLINSTN
QUIT
+58 ;
+59 ; patch HL*1.6*148
+60 ; S:ERR="" ERR="Receiving Facility mismatch."
+61 if ERR=""
SET ERR="Receiving Facility Mismatch."
End DoDot:2
QUIT
+62 IF $PIECE(ARY("RAF"),HLCS)=HLINSTN
QUIT
+63 ; patch HL*1.6*148
+64 ; S:ERR="" ERR="Receiving Facility mismatch."
+65 if ERR=""
SET ERR="Receiving facility mismatch."
End DoDot:1
+66 ; patch HL*1.6*120 end
+67 ;
SF ;Validate Sending Facility
+1 IF HLSFREQ
Begin DoDot:1
+2 IF ARY("SAF")=""
if ERR=""
SET ERR="Missing required sending facility"
+3 IF HL771SF]""
Begin DoDot:2
+4 ;Check for facility data in 771
+5 QUIT
End DoDot:2
QUIT
+6 ;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK
+7 ;If so, use this instead of Protocol definition for return path
+8 ;
+9 ; patch HL*1.6*120 start
+10 NEW HLDOMP
+11 ; S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
+12 SET HLDOMP=$PIECE(ARY("SAF"),HLCS,2)
+13 ;
+14 ; assume the format is <domain>:<port #>
+15 ; patch HL*1.6*163 can no longer assume one format for <domain><port> with IPV6
+16 ; check for IPV6 address with delimiter of "]:" and process accordingly
+17 ; ;$$FORCEIP6^XLFIPV(IP) API (ICR #5844)
+18 IF HLDOMP["]"
Begin DoDot:2
+19 SET ARY("SAF-PORT")=$PIECE(HLDOMP,"]:",2)
+20 SET HLDOMP=$EXTRACT($PIECE(HLDOMP,"]"),2,99)
+21 SET HLDOMP=$$FORCEIP6^XLFIPV(HLDOMP)
End DoDot:2
+22 IF '$TEST
IF HLDOMP[":"
Begin DoDot:2
+23 SET ARY("SAF-PORT")=$PIECE(HLDOMP,":",2)
+24 SET HLDOMP=$PIECE(HLDOMP,":")
End DoDot:2
+25 SET ARY("SAF-DOMAIN")=HLDOMP
+26 ;
+27 ; if first piece of domain is "HL7." or "MPI.", remove it
+28 IF ($EXTRACT(HLDOMP,1,4)="HL7.")!($EXTRACT(HLDOMP,1,4)="MPI.")
Begin DoDot:2
+29 SET HLDOMP=$PIECE(HLDOMP,".",2,99)
End DoDot:2
+30 SET HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
+31 ;Note: This expects a unique domain in domain file. Multiple entries will fail
+32 ; I 'HLDOMP S:ERR="" ERR="Unrecognized/ambiguous domain in sending facility"
+33 ;
+34 ; check DNS domain and ip address
+35 IF 'HLDOMP
Begin DoDot:2
+36 ;
+37 ;initialize variable, HLDOMP("FLAG")
+38 SET HLDOMP("FLAG")=0
+39 IF ARY("SAF-DOMAIN")]""
Begin DoDot:3
+40 ;
+41 ; match DNS domain
+42 IF $DATA(^HLCS(870,"DNS",ARY("SAF-DOMAIN")))
Begin DoDot:4
+43 SET HLDOMP("FLAG")=1
+44 SET ARY("SAF-LL")=+$ORDER(^HLCS(870,"DNS",ARY("SAF-DOMAIN"),0))
End DoDot:4
QUIT
+45 IF $DATA(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN"))))
Begin DoDot:4
+46 SET HLDOMP("FLAG")=1
+47 SET ARY("SAF-LL")=+$ORDER(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")),0))
End DoDot:4
QUIT
+48 IF $DATA(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN"))))
Begin DoDot:4
+49 SET HLDOMP("FLAG")=1
+50 SET ARY("SAF-LL")=+$ORDER(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")),0))
End DoDot:4
QUIT
+51 ;
+52 ; match ip address
+53 IF $DATA(^HLCS(870,"IP",ARY("SAF-DOMAIN")))
Begin DoDot:4
+54 SET HLDOMP("FLAG")=1
+55 SET ARY("SAF-LL")=+$ORDER(^HLCS(870,"IP",ARY("SAF-DOMAIN"),0))
End DoDot:4
QUIT
End DoDot:3
+56 if HLDOMP("FLAG")=1
QUIT
+57 ; quit if 1st component defined
+58 SET ARY("SAF-COMPONENT1")=$PIECE(ARY("SAF"),HLCS,1)
+59 if ARY("SAF-COMPONENT1")]""
QUIT
+60 ; patch HL*1.6*148
+61 ; S:ERR="" ERR="Receiving Facility mismatch."
+62 if ERR=""
SET ERR="Sending Facility mismatch."
End DoDot:2
+63 ; patch HL*1.6*120 end
+64 ;
+65 ;This is local app to app
if HLDOMP=$PIECE(HLPARAM,U)
QUIT
+66 IF HLDOMP
NEW HLNK
SET HLNK=+$ORDER(^HLCS(870,"D",HLDOMP,0))
+67 IF $GET(HLNK)
SET ARY("LL")=HLNK
End DoDot:1
+68 ;
PID ;Validate processing ID
+1 IF ("DTP"'[ARY("PID"))
if (ERR="")
SET ERR="Invalid HL7 Processing ID"
+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 ;If message is 'debug' then event driver must be 'debug.'
+5 ;If message is 'test' or 'production', then site param must match
+6 IF ARY("PID")="D"&(X'="D")
if ERR=""
SET ERR="Processing ID Mismatch with Event Driver"
+7 IF ARY("PID")'="D"&(HLPID'=ARY("PID"))
if ERR=""
SET ERR="Processing ID Mismatch with Site Parameters"
+8 ;
SEC ;Validate security field - access code and electronic signature
+1 IF ($PIECE($GET(HLN(773)),"^",3))
Begin DoDot:1
+2 SET X=$PIECE($$P^HLTPCK2(.HDR,8),$EXTRACT(ECH))
+3 SET X=$$UPPER^HLFNC(X)
+4 DO ^XUSHSH
+5 IF X=""
IF (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($$P^HLTPCK2(.HDR,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
