Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLTPCK1A

HLTPCK1A.m

Go to the documentation of this file.
  1. 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**;Oct 13, 1995
  1. S ERR=""
  1. SP ;Get local site parameters
  1. S HLPARAM=$$PARAM^HLCS2,HLDOM=$P(HLPARAM,U,2),HLINSTN=$P(HLPARAM,U,6)
  1. MT ;Validate message type
  1. I (ARY("MTN")="") S:(ERR="") ERR="Invalid Message Type" Q
  1. S ARY("MTP")=0
  1. S:(ARY("MTN")'="") ARY("MTP")=+$O(^HL(771.2,"B",ARY("MTN"),0))
  1. I ('ARY("MTP")) S:(ERR="") ERR="Invalid Message Type" Q
  1. ;
  1. AT ;Determine if message is an acknowledgement type
  1. I (("ACK,ADR,MCF,MFK,MFR,ORF,ORR,RRA,RRD,RRE,RRG,TBR"[ARY("MTN"))&($G(MSA)="")) S:(ERR="") ERR="MSA Segment Missing" Q
  1. ;
  1. AAT ;Validate accept ack type and application ack type
  1. I ($G(ARY("ACAT"))'="") I ("AL,NE,ER,SU"'[ARY("ACAT")) S:(ERR="") ERR="Invalid accept ack type" Q
  1. I ($G(ARY("APAT"))'="") I ("AL,NE,ER,SU"'[ARY("APAT")) S:(ERR="") ERR="Invalid application ack type" Q
  1. ;
  1. RA ;Validate receiving application
  1. S ARY("RAN")=$P(HDR,FS,5)
  1. I (ARY("RAN")="") S:(ERR="") ERR="Invalid Receiving Application" Q
  1. S ARY("RAP")=0
  1. ;
  1. ; patch HL*1.6*108 start
  1. ;S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0))
  1. S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
  1. I (('ARY("RAP"))&(ARY("RAN")'="")) D
  1. .S X=$$UPPER^HLFNC(ARY("RAN"))
  1. .;S ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0))
  1. .S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
  1. ; patch HL*1.6*108 end
  1. ;
  1. I ('ARY("RAP")) S:(ERR="") ERR="Invalid Receiving Application" Q
  1. S X2=$G(^HL(771,ARY("RAP"),0))
  1. I (X2="") S:(ERR="") ERR="Invalid Receiving Application" Q
  1. I ($P(X2,"^",2)'="a") S:(ERR="") ERR="Receiving Application is Inactive" Q
  1. ;
  1. SA ;Validate sending application
  1. S ARY("SAN")=$P(HDR,FS,3)
  1. I (ARY("SAN")="") S:(ERR="") ERR="Invalid Sending Application" Q
  1. S ARY("SAP")=0
  1. ;
  1. ; patch HL*1.6*108 start
  1. ;S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0))
  1. S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
  1. I (('ARY("SAP"))&(ARY("SAN")'="")) D
  1. .S X=$$UPPER^HLFNC(ARY("SAN"))
  1. .;S ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0))
  1. .S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
  1. ; patch HL*1.6*108 end
  1. ;
  1. I ('ARY("SAP")) S:(ERR="") ERR="Invalid Sending Application" Q
  1. ;
  1. VN ;Validate version number
  1. I (ARY("VER")="") S:(ERR="") ERR="Missing HL7 Version" Q
  1. S X=0
  1. S:(ARY("VER")'="") X=+$O(^HL(771.5,"B",ARY("VER"),0))
  1. S ARY("VEP")=X
  1. I ('X) S:(ERR="") ERR="Invalid HL7 Version" Q
  1. ;
  1. ET ; Check for Event Type if version 2.2 or above
  1. ; if response use message id/original message to resolve event type
  1. ;I ARY("ETN")="",ARY("VER")>2.1,$G(MSA)'="" D Q:ERR]""
  1. ;. ;N HLZMID,HLZEP,HLZ770
  1. ;. ;S HLZMID=$O(^HL(772,"C",+$P(MSA,FS,2),0))
  1. ;. ;I HLZMID D
  1. ;.. ;I '$G(^HL(772,HLZMID,0)) S:(ERR="") ERR="Original Outgoing Message not found" Q
  1. ;.. ;S HLZEP=$P($G(^HL(772,HLZMID,0)),U,10)
  1. ;.. ;I HLZEP'>0 S:(ERR="") ERR="Event Protocol pointer (field #772,10) missing" Q
  1. ;.. ;S HLZ770=$G(^ORD(101,HLZEP,770))
  1. ;.. ;S ARY("ETN")=$P($G(^HL(779.001,+$P(HLZ770,U,4),0)),U)
  1. ;. ;K HLZMID,HLZEP,HLZ770
  1. ;
  1. I (ARY("ETN")=""),ARY("VER")>2.1,$G(MSA)="" S:(ERR="") ERR="Event Type REQUIRED" Q
  1. S ARY("ETP")=0
  1. 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
  1. ;
  1. MS ;Check for Message Structure Code
  1. I $G(ARY("MTN_ETN"))'="" D
  1. . S ARY("MTP_ETP")=0
  1. . S ARY("MTP_ETP")=+$O(^HL(779.005,"B",ARY("MTN_ETN"),0))
  1. . I ('ARY("MTP_ETP")) S:(ERR="") ERR="Invalid Message Structure Code" Q
  1. ;
  1. MSA ;Get receiving application data from Protocol file
  1. ;I (ARY("SAP")) D Q:ERR]""
  1. I $D(MSA) D Q
  1. .;Message is an acknowledgement - deliver to Server Protocol that
  1. .; message came from
  1. .I '$G(ARY("SAP")) S ERR="Missing Sending Application" Q
  1. .S ARY("MTIENS")=0
  1. .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")
  1. .S X=$G(^HL(772,+ARY("MTIENS"),0))
  1. .S ARY("EIDS")=$P(X,"^",10)
  1. .I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment" Q
  1. .S ARY("MTIEN")=+$P(X,"^",8)
  1. .S ARY("ACK")=$P(X,"^",7)
  1. .S X=$G(^HL(772,+$P(X,"^",8),0))
  1. .S ARY("EID")=$P(X,"^",10)
  1. .I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
  1. .D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
  1. .;Get Logical Link info if defined on subscriber
  1. .S ARY("LL")=$P($G(HLN(770)),"^",7)
  1. ;
  1. I ARY("MTP") D
  1. .;Find Server Protocol - based on sending application, message type,
  1. .;event type and version ID
  1. .I ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0))
  1. .;
  1. .;Find Server Protocol - based on sending application, message type,
  1. .;and version ID
  1. .I 'ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0))
  1. .;
  1. .I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
  1. .;Find Client Protocol - in ITEM multiple of Server Protocol
  1. .S ARY("EIDS")=0
  1. .F S ARY("EIDS")=+$O(^ORD(101,ARY("EID"),775,"B",ARY("EIDS"))) Q:('ARY("EIDS")) D Q:$G(X1)
  1. ..S (X,X1)=0
  1. ..S X=$G(^ORD(101,ARY("EIDS"),770))
  1. ..I $P(X,U,2)=ARY("RAP") S X1=1
  1. .I 'ARY("EIDS") S:(ERR="") ERR="Invalid Receiving Application for this Event" Q
  1. .D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
  1. ;
  1. LLP ;Get logical link pointer
  1. S ARY("LL")=$P($G(HLN(770)),"^",7)
  1. ;
  1. FAC ;Get sending/rec facility, validate if necessary
  1. ;
  1. S HLCS=$E(ECH,1) ;Get component separator
  1. S ARY("RAF")=$P(HDR,FS,6) ;Receiving Facility
  1. S ARY("SAF")=$P(HDR,FS,4) ;Sending Facility
  1. ;Get sending/receiving facility from Application Parameter file(771)
  1. S HL771SF=$P($G(^HL(771,ARY("SAP"),0)),U,3)
  1. S HL771RF=$P($G(^HL(771,ARY("RAP"),0)),U,3)
  1. ;Sending/Receiving facility required?
  1. S X=$G(^ORD(101,ARY("EIDS"),773))
  1. S HLSFREQ=+X,HLRFREQ=+$P(X,U,2)
  1. RF ;Validate Receiving Facility
  1. I HLRFREQ D
  1. .I ARY("RAF")="" S:ERR="" ERR="Missing required receiving facility" Q
  1. .I HL771RF]"" D Q
  1. ..;Facility data in 771 overrides data in site paramter file
  1. ..;For backward compatibility, don't validate
  1. ..Q
  1. ..Q:HL771RF=ARY("RAF")
  1. ..S:ERR="" ERR="Receiving Facility/App Parameter mismatch."
  1. .;Check against local default value (site parameters)
  1. .Q:ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS")
  1. .S:ERR="" ERR="Receiving Facility mismatch."
  1. SF ;Validate Sending Facility
  1. I HLSFREQ D
  1. .I ARY("SAF")="" S:ERR="" ERR="Missing required sending facility" Q
  1. .I HL771SF]"" D Q
  1. ..;Check for facility data in 771
  1. ..Q
  1. ..Q:HL771SF=ARY("SAF")
  1. ..S:ERR="" ERR="Sending Facility/App Parameter mismatch."
  1. .;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK
  1. .;If so, use this instead of Protocol definition for return path
  1. .S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$O(^DIC(4.2,"B",HLDOMP,0))
  1. .I 'HLDOMP S:ERR="" ERR="Unrecognized domain in sending facility"
  1. .Q:HLDOMP=$P(HLPARAM,U) ;This is local app to app
  1. .I HLDOMP N HLNK S HLNK=+$O(^HLCS(870,"D",HLDOMP,0))
  1. .I HLNK S ARY("LL")=HLNK
  1. ;
  1. PID ;Validate processing ID
  1. I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Invalid HL7 Processing ID" Q
  1. S HLPID=$P(HLPARAM,U,3) ;site param
  1. S X=$G(^ORD(101,ARY("EID"),770)),X=$P(X,U,6) ;event driver
  1. ;I X=""&($G(HLPID))="" S:ERR="" ERR="Cannot validate PROCESSING ID"
  1. ;If message is 'debug' then event driver must be 'debug.'
  1. ;If message is 'test' or 'production', then site param must match
  1. I ARY("PID")="D"&(X'="D") S:ERR="" ERR="Processing ID Mismatch with Event Driver"
  1. I ARY("PID")'="D"&(HLPID'=ARY("PID")) S:ERR="" ERR="Processing ID Mismatch with Site Parameters"
  1. ;
  1. SEC ;Validate security field - access code and electronic signature
  1. I ($P($G(HLN(773)),"^",3)) D
  1. .S X=$P($P(HDR,FS,8),$E(ECH))
  1. .S X=$$UPPER^HLFNC(X)
  1. .D ^XUSHSH
  1. .I ((X="")&('$D(MSA))) S:(ERR="") ERR="Invalid access code" Q
  1. .S ARY("DUZ")=0
  1. .S:(X'="") ARY("DUZ")=+$O(^VA(200,"A",X,0))
  1. .I ('ARY("DUZ")) S:(ERR="") ERR="Invalid access code" Q
  1. .I (($P($G(^VA(200,ARY("DUZ"),.1)),"^")="")&('$D(MSA))) S ARY("DUZ")=0 S:(ERR="") ERR="Invalid access code" Q
  1. .S X=$P($P(HDR,FS,8),$E(ECH),3) I (X'="") D
  1. ..S X1=$G(^VA(200,ARY("DUZ"),20))
  1. ..I (X1="") S:(ERR="") ERR="No Signature Code on File" Q
  1. ..S X=$$UPPER^HLFNC(X)
  1. ..D HASH^XUSHSHP
  1. ..I ((X'=$P(X1,"^",4))!($P(X1,"^",2)="")) S:(ERR="") ERR="Invalid Electronic Signature Code" Q
  1. ..S ARY("ESIG")=$P(X1,"^",2)
  1. I $D(ARY) M HLREC=ARY
  1. Q