HLTPCK2A ;SF/RSD - Message Header Validation (Con't) ;09/13/2006
 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,66,108,120,133**;Oct 13, 1995;Build 13
 ;Per VHA Directive 2004-038, this routine should not be modified.
 S ERR=""
 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
 ;commit ack, quit
 I $E($G(MSA))="C" D  Q
 . ;find original msg.
 . 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("C",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 ""C"" x-ref" Q
 . 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
 I (ARY("RAN")']"") S:(ERR="") ERR="Invalid Receiving Application" Q
 S ARY("RAP")=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",$E(ARY("RAN"),1,30),0))
 ;
 ; patch HL*1.6*120 start
 I ($L(ARY("RAN"),ECH(1))>1) D
 . S ARY("RAN-SUB1")=$P(ARY("RAN"),ECH(1))
 . S ARY("RAN-SUB2")=$P(ARY("RAN"),ECH(1),2)
 . S ARY("RAN-SUB3")=$P(ARY("RAN"),ECH(1),3)
 . I 'ARY("RAP"),ARY("RAN-SUB1")]"" D
 .. S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN-SUB1"),1,30),0))
 . I ARY("RAN-SUB1")[ECH(3) D
 .. S ARY("RAN-SUB1-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB1"))
 . I ARY("RAN-SUB2")[ECH(3) D
 .. S ARY("RAN-SUB2-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB2"))
 . I ARY("RAN-SUB3")[ECH(3) D
 .. S ARY("RAN-SUB3-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB3"))
 . I 'ARY("RAP"),$G(ARY("RAN-SUB1-DEESCAPE"))]"" D
 .. S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN-SUB1-DEESCAPE"),1,30),0))
 I ARY("RAN")[ECH(3) D
 . S ARY("RAN-DEESCAPE")=$$DEESCAPE(ARY("RAN"))
 I 'ARY("RAP"),$G(ARY("RAN-DEESCAPE"))]"" D
 . S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN-DEESCAPE"),1,30),0))
 ; patch HL*1.6*120 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
 I (ARY("SAN")']"") S:(ERR="") ERR="Invalid Sending Application" Q
 S ARY("SAP")=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",$E(ARY("SAN"),1,30),0))
 ;
 ; patch HL*1.6*120 start
 I ($L(ARY("SAN"),ECH(1))>1) D
 . S ARY("SAN-SUB1")=$P(ARY("SAN"),ECH(1))
 . S ARY("SAN-SUB2")=$P(ARY("SAN"),ECH(1),2)
 . S ARY("SAN-SUB3")=$P(ARY("SAN"),ECH(1),3)
 . I 'ARY("SAP"),ARY("SAN-SUB1")]"" D
 .. S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN-SUB1"),1,30),0))
 . I ARY("SAN-SUB1")[ECH(3) D
 .. S ARY("SAN-SUB1-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB1"))
 . I ARY("SAN-SUB2")[ECH(3) D
 .. S ARY("SAN-SUB2-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB2"))
 . I ARY("SAN-SUB3")[ECH(3) D
 .. S ARY("SAN-SUB3-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB3"))
 . I 'ARY("SAP"),$G(ARY("SAN-SUB1-DEESCAPE"))]"" D
 .. S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN-SUB1-DEESCAPE"),1,30),0))
 I ARY("SAN")[ECH(3) D
 . S ARY("SAN-DEESCAPE")=$$DEESCAPE(ARY("SAN"))
 I 'ARY("SAP"),$G(ARY("SAN-DEESCAPE"))]"" D
 . S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN-DEESCAPE"),1,30),0))
 ; patch HL*1.6*120 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
 ;I (X'=$P($G(HLN(770)),"^",10)) S:(ERR="") ERR="Invalid HL7 Version for Receiving Application" Q
 ;
ET ;Event Type Checks
 ;
 ;I ARY("ETN")="",ARY("VER")>2.1,$G(MSA)'="" D
 ;. ;N Z,ZEP,ZP
 ;. ;S Z=0 I $P(MSA,FS,2)]"" S Z=+$O(^HLMA("C",$P(MSA,FS,2),0))
 ;. ;I '$G(^HLMA(Z,0)) S:(ERR="") ERR="Original Outgoing Message not found" Q
 ;. ;S ZEP=$P(^HLMA(Z,0),U,8)
 ;. ;I 'ZEP S:(ERR="") ERR="Event Protocol pointer (field #773,8) missing" Q
 ;. ;S ZP=$G(^ORD(101,ZEP,770)),ARY("ETN")=$P($G(^HL(779.001,+$P(ZP,U,4),0)),U)
 ;
 ;Validate event type
 I (ARY("ETN")=""),ARY("VER")>2.1,$G(MSA)="" S ERR="Event Type Required" Q
 S ARY("ETP")=0
 S:(ARY("ETN")'="") ARY("ETP")=+$O(^HL(779.001,"B",ARY("ETN"),0))
 I $G(MSA)="",ARY("VER")>2.1,('ARY("ETP")) S ERR="Invalid Event Type" Q
 ;
 D ^HLTPCK2B
 Q
DEESCAPE(INPUT) ;
 ; patch HL*1.6*120 - de-escape delimiters
 ; (assuming "\" is the escape character):
 ; - field separator (de-escape from \F\)
 ; - component separator (de-escape from \S\)
 ; - repetition separator (de-escape from \R\)
 ; - escape character (de-escape from \E\)
 ; - subcomponent separator (de-escape from \T\)
 ; \F\ will be de-escaped only if the length of FS is 1.
 ;
 ; input:
 ; INPUT - input string to be de-escaped
 ; FS - field separator
 ; ECH - encoding characters
 ; 
 ; output: de-escaped string
 ;
 N HLDATA,HLESCAPE,HLI,HLCHAR,HLCHAR23,HLEN,HLOUT
 S HLDATA=$G(INPUT)
 Q:HLDATA']"" HLDATA
 ;
 ; patch HL*1.6*133
 Q:$L($G(ECH))<3 HLDATA
 ;
 S ECH(1)=$E(ECH,1)
 S ECH(2)=$E(ECH,2)
 S ECH(3)=$E(ECH,3)
 S ECH(4)=$E(ECH,4)
 ;
 S HLEN=$L(HLDATA)
 S HLOUT=""
 F HLI=1:1:HLEN D
 . S HLCHAR=$E(HLDATA,HLI)
 . I HLCHAR=ECH(3) D
 . S HLCHAR23=$E(HLDATA,HLI+1,HLI+2)
 . I $L($G(FS))=1,(HLCHAR23=("F"_ECH(3))) D  Q
 .. S HLOUT=HLOUT_FS
 .. S HLI=HLI+2
 . I HLCHAR23=("S"_ECH(3)) D  Q
 .. S HLOUT=HLOUT_ECH(1)
 .. S HLI=HLI+2
 . I HLCHAR23=("R"_ECH(3)) D  Q
 .. S HLOUT=HLOUT_ECH(2)
 .. S HLI=HLI+2
 . I HLCHAR23=("E"_ECH(3)) D  Q
 .. S HLOUT=HLOUT_ECH(3)
 .. S HLI=HLI+2
 . I $L($G(ECH))>3,(HLCHAR23=("T"_ECH(3))) D  Q
 .. S HLOUT=HLOUT_ECH(4)
 .. S HLI=HLI+2
 . S HLOUT=HLOUT_HLCHAR
 ;
 Q HLOUT