194 lines
8.1 KiB
Mathematica
194 lines
8.1 KiB
Mathematica
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**;Oct 13, 1995
|
|
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))
|
|
.;
|
|
.;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")) 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
|
|
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))
|
|
.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
|