HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;09/13/2006
;;1.6;HEALTH LEVEL SEVEN;**120,133**;Oct 13, 1995;Build 13
;Per VHA Directive 2004-038, 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
. 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)
;
;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 #>
.. I HLDOMP1[":" 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
.. ;
.. S:ERR="" ERR="Receiving Facility mismatch."
. I $P(ARY("RAF"),HLCS)=HLINSTN Q
. 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 #>
. I HLDOMP[":" 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")]""
.. S:ERR="" ERR="Receiving 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
HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;09/13/2006
+1 ;;1.6;HEALTH LEVEL SEVEN;**120,133**;Oct 13, 1995;Build 13
+2 ;Per VHA Directive 2004-038, 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 IF ('ARY("EIDS"))
IF (ERR="")
SET ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773"
QUIT
+11 ;get message text ien in file 772 and server protocol, 'EID'
+12 SET ARY("MTIEN")=+X
SET X=$GET(^HL(772,+X,0))
SET ARY("EID")=$PIECE(X,U,10)
+13 IF ('ARY("EID"))
IF (ERR="")
SET ERR="Event Protocol not found"
QUIT
+14 DO EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
End DoDot:1
QUIT
+15 ;
+16 ;Find Server Protocol - based on sending application, message type,
+17 ;event type and version ID
+18 IF ARY("ETP")
SET ARY("EID")=+$ORDER(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0))
+19 ;
+20 ;Find Server Protocol - based on sending application, message type,
+21 ;and version ID
+22 IF 'ARY("ETP")
SET ARY("EID")=+$ORDER(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0))
+23 ;
+24 IF ('ARY("EID"))
IF (ERR="")
SET ERR="Event Protocol not found"
QUIT
+25 ;Find Client Protocol - in ITEM multiple of Server Protocol
+26 SET ARY("EIDS")=0
+27 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
+28 IF 'ARY("EIDS")
SET ERR="Invalid Receiving Application for this Event"
QUIT
+29 DO EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
+30 ;
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 IF HLDOMP1[":"
SET ARY("RAF-PORT")=$PIECE(HLDOMP1,":",2)
+18 SET HLDOMP1=$PIECE(HLDOMP1,":")
+19 SET ARY("RAF-DOMAIN")=HLDOMP1
+20 ;
+21 ; if first piece of domain is "HL7." or "MPI.", remove it
+22 IF ($EXTRACT(HLDOMP1,1,4)="HL7.")!($EXTRACT(HLDOMP1,1,4)="MPI.")
Begin DoDot:3
+23 SET HLDOMP1=$PIECE(HLDOMP1,".",2,99)
End DoDot:3
+24 SET HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
+25 SET HLDOMP2=HLDOM
SET HLDOMP2=$$FIND1^DIC(4.2,"","BMX",HLDOMP2,"B^C","","ERROR")
+26 IF HLDOMP1&HLDOMP2&(HLDOMP1=HLDOMP2)
QUIT
+27 ;
+28 ; check DNS domain and ip address
+29 ;initialize variable, HLDOMP("FLAG")
+30 SET HLDOMP("FLAG")=0
+31 IF ARY("RAF-DOMAIN")]""
Begin DoDot:3
+32 ;
+33 ; match DNS domain
+34 IF $DATA(^HLCS(870,"DNS",ARY("RAF-DOMAIN")))
Begin DoDot:4
+35 SET HLDOMP("FLAG")=1
+36 SET ARY("RAF-LL")=+$ORDER(^HLCS(870,"DNS",ARY("RAF-DOMAIN"),0))
End DoDot:4
QUIT
+37 IF $DATA(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN"))))
Begin DoDot:4
+38 SET HLDOMP("FLAG")=1
+39 SET ARY("RAF-LL")=+$ORDER(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")),0))
End DoDot:4
QUIT
+40 IF $DATA(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN"))))
Begin DoDot:4
+41 SET HLDOMP("FLAG")=1
+42 SET ARY("RAF-LL")=+$ORDER(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")),0))
End DoDot:4
QUIT
+43 ;
+44 ; match ip address
+45 IF $DATA(^HLCS(870,"IP",ARY("RAF-DOMAIN")))
Begin DoDot:4
+46 SET HLDOMP("FLAG")=1
+47 SET ARY("RAF-LL")=+$ORDER(^HLCS(870,"IP",ARY("RAF-DOMAIN"),0))
End DoDot:4
QUIT
End DoDot:3
+48 IF HLDOMP("FLAG")=1
QUIT
+49 IF $PIECE(ARY("RAF"),HLCS)=HLINSTN
QUIT
+50 ;
+51 IF ERR=""
SET ERR="Receiving Facility mismatch."
End DoDot:2
QUIT
+52 IF $PIECE(ARY("RAF"),HLCS)=HLINSTN
QUIT
+53 IF ERR=""
SET ERR="Receiving Facility mismatch."
End DoDot:1
+54 ; patch HL*1.6*120 end
+55 ;
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 IF HLDOMP[":"
SET ARY("SAF-PORT")=$PIECE(HLDOMP,":",2)
+16 SET HLDOMP=$PIECE(HLDOMP,":")
+17 SET ARY("SAF-DOMAIN")=HLDOMP
+18 ;
+19 ; if first piece of domain is "HL7." or "MPI.", remove it
+20 IF ($EXTRACT(HLDOMP,1,4)="HL7.")!($EXTRACT(HLDOMP,1,4)="MPI.")
Begin DoDot:2
+21 SET HLDOMP=$PIECE(HLDOMP,".",2,99)
End DoDot:2
+22 SET HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
+23 ;Note: This expects a unique domain in domain file. Multiple entries will fail
+24 ; I 'HLDOMP S:ERR="" ERR="Unrecognized/ambiguous domain in sending facility"
+25 ;
+26 ; check DNS domain and ip address
+27 IF 'HLDOMP
Begin DoDot:2
+28 ;
+29 ;initialize variable, HLDOMP("FLAG")
+30 SET HLDOMP("FLAG")=0
+31 IF ARY("SAF-DOMAIN")]""
Begin DoDot:3
+32 ;
+33 ; match DNS domain
+34 IF $DATA(^HLCS(870,"DNS",ARY("SAF-DOMAIN")))
Begin DoDot:4
+35 SET HLDOMP("FLAG")=1
+36 SET ARY("SAF-LL")=+$ORDER(^HLCS(870,"DNS",ARY("SAF-DOMAIN"),0))
End DoDot:4
QUIT
+37 IF $DATA(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN"))))
Begin DoDot:4
+38 SET HLDOMP("FLAG")=1
+39 SET ARY("SAF-LL")=+$ORDER(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")),0))
End DoDot:4
QUIT
+40 IF $DATA(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN"))))
Begin DoDot:4
+41 SET HLDOMP("FLAG")=1
+42 SET ARY("SAF-LL")=+$ORDER(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")),0))
End DoDot:4
QUIT
+43 ;
+44 ; match ip address
+45 IF $DATA(^HLCS(870,"IP",ARY("SAF-DOMAIN")))
Begin DoDot:4
+46 SET HLDOMP("FLAG")=1
+47 SET ARY("SAF-LL")=+$ORDER(^HLCS(870,"IP",ARY("SAF-DOMAIN"),0))
End DoDot:4
QUIT
End DoDot:3
+48 IF HLDOMP("FLAG")=1
QUIT
+49 ; quit if 1st component defined
+50 SET ARY("SAF-COMPONENT1")=$PIECE(ARY("SAF"),HLCS,1)
+51 IF ARY("SAF-COMPONENT1")]""
QUIT
+52 IF ERR=""
SET ERR="Receiving Facility mismatch."
End DoDot:2
+53 ; patch HL*1.6*120 end
+54 ;
+55 ;This is local app to app
IF HLDOMP=$PIECE(HLPARAM,U)
QUIT
+56 IF HLDOMP
NEW HLNK
SET HLNK=+$ORDER(^HLCS(870,"D",HLDOMP,0))
+57 IF $GET(HLNK)
SET ARY("LL")=HLNK
End DoDot:1
+58 ;
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
