Routine: HLCHK

HLCHK ;AISC/SAW-Validate HL7 Messages Received ;3/24/2004  14:09

 ;;1.6;HEALTH LEVEL SEVEN;**1,108**;Oct 13, 1995

 ;This routine is used for the Version 1.5 Interface Only

 D CHK D IN^HLTF(HLMTN,HLMID,HLTIME) S HLMT=$S(HLMTN="QRY":"ORF",HLMTN="ORM":"ORR",1:"ACK") D MSH G ACK:$D(HLERR)

 K HLDATA,HLL,HLMSA,HLMT,HLMTP,^TMP("HLR",$J) I HLROU="^NONE"!(HLROU="^") D KILL Q

 D @HLROU G REPLY

MSH ;Create MSH Segment for HL7 Reply

 I '$D(HLDT)!('$D(HLDT1)) N %,%H,%I D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(HLDT)

 S HLSDATA(1)="MSH"_HLFS_HLECH_HLFS_$P(HLDATA,HLFS,5,6)_HLFS_$P(HLDATA,HLFS,3,4)_HLFS_HLDT1_HLFS_HLFS_HLMT_HLFS_HLDT_HLFS_HLPID_HLFS_HLVER Q

CHK ;Validate Data in Header Segment of an HL7 Message

 K HLERR S HLDATA=HLL(1),HLFS=$E(HLDATA,4),HLECH=$P(HLDATA,HLFS,2),HLQ="""""",HLDAN=$P(HLDATA,HLFS,5),HLMNT="" D

 .I $E(HLDATA,1,3)="BHS" S HLMID=$P(HLDATA,HLFS,11),X=$P(HLDATA,HLFS,9),HLPID=$P(X,$E(HLECH),2),HLMTN=$E($P(X,$E(HLECH),3),1,3),HLVER=$P(X,$E(HLECH),4) S:$P(HLDATA,HLFS,10)]"" HLMSA=$P(HLDATA,HLFS,10),$P(HLMSA,$E(HLECH),2)=$P(HLDATA,HLFS,12)

 .I $E(HLDATA,1,3)="MSH" S HLMID=$P(HLDATA,HLFS,10),HLPID=$P(HLDATA,HLFS,11),HLMTN=$P($P(HLDATA,HLFS,9),$E(HLECH)),HLVER=$P(HLDATA,HLFS,12) S:HLMTN="" HLMTN=0 I $E($G(HLL(2)),1,3)="MSA" S HLMSA=HLL(2)

 I HLMTN']"" S HLERR="Invalid Message Type" Q

 I '$D(^HL(771.2,"B",HLMTN)) S HLERR="Invalid Message Type" Q

 I HLFS=""!(HLFS?.C) S HLERR="Invalid Header Segment" Q

 I $E(HLDATA,1,3)'="MSH",$E(HLDATA,1,3)'="BHS" S HLERR="Invalid Header Segment" Q

 I HLDAN']"" S HLERR="Invalid Receiving Application" Q

 ; patch HL*1.6*108 start

 ;S HLDAP=+$O(^HL(771,"B",HLDAN,0)) I 'HLDAP S HLDAN=$$UPPER^HLFNC(HLDAN),HLDAP=+$O(^HL(771,"B",HLDAN,0))

 S HLDAP=+$O(^HL(771,"B",$E(HLDAN,1,30),0)) I 'HLDAP S HLDAN=$$UPPER^HLFNC(HLDAN),HLDAP=+$O(^HL(771,"B",$E(HLDAN,1,30),0))

 ; patch HL*!.6*108 end

 I 'HLDAP S HLERR="Invalid Receiving Application" Q

 I '$D(^HL(771,HLDAP,0)) S HLERR="Invalid Receiving Application" Q

 I $P(^HL(771,HLDAP,0),"^",2)'="a" S HLERR="Receiving Application is Inactive" Q

 S X=$P(HLDATA,HLFS,3) I X']"" S HLERR="Invalid Sending Application" Q

 I '$D(^HL(770,"AF",X)) S X=$$UPPER^HLFNC(X)

 I '$D(^HL(770,"AF",X)) S HLERR="Invalid Sending Application" Q

 S HLSA=X,X=$P(HLDATA,HLFS,4) I X']"" S HLERR="Invalid Sending Facility" Q

 I '$D(^HL(770,"AF",HLSA,X)) S X=$$UPPER^HLFNC(X)

 I '$D(^HL(770,"AF",HLSA,X)) S HLERR="Invalid Sending Facility" Q

 S X=$P(HLDATA,HLFS,6),X=$$UPPER^HLFNC(X) I X']"" S HLERR="Invalid Receiving Facility" Q

 I '$D(^HL(770,"AE",HLSA,X)) S HLERR="Invalid Receiving Facility" Q

 I '$D(HLNDAP0) S HLNDAP=+$O(^HL(770,"B",HLSA,0)),HLNDAP0=$G(^HL(770,HLNDAP,0)) S:$P(HLNDAP0,"^",6)]"" HLION=$P(HLNDAP0,"^",6)

 I HLVER']"" S HLERR="Invalid HL7 Version" Q

 S X=$O(^HL(771.5,"B",HLVER,0)) I 'X S HLERR="Invalid HL7 Version" Q

 I X'=$P(^HL(770,+$O(^HL(770,"B",HLSA,0)),0),"^",7) S HLERR="Invalid HL7 version for Receiving Application" Q

 I "DTP"'[HLPID S HLERR="Inappropriate HL7 Processing ID" Q

 S HLMTP=+$O(^HL(771.2,"B",HLMTN,0)) I HLMTN'="ACK",'$O(^HL(771,HLDAP,"MSG","B",HLMTP,0)) S HLERR="Invalid Message Type for Receiving Application" Q

 S HLROU=$G(^HL(771,HLDAP,"MSG",+$O(^HL(771,HLDAP,"MSG","B",HLMTP,0)),"R")) I HLROU']""!(HLROU="NONE") I HLMTN'="ACK",HLMTN'="MCF" S HLERR="Invalid Message Type for Receiving Application" Q

 S X=$P($P(HLDATA,HLFS,8),$E(HLECH)),X=$$UPPER^HLFNC(X) D ^XUSHSH D  Q:$D(HLERR)

 .I X']"" S:HLMTN'="ACK"&(HLMTN'="MCF")&(HLMTN'="ORR") HLDUZ=0 Q

 .S HLDUZ=+$O(^VA(200,"A",X,0)) I '$D(^VA(200,HLDUZ,.1)) I HLMTN'="ACK",HLMTN'="MCF",HLMTN'="ORR" S HLDUZ=0

 S X=$P($P(HLDATA,HLFS,8),$E(HLECH),3) I X]"" D  Q:$D(HLERR)

 .I '$D(^VA(200,HLDUZ,20)) S HLERR="No Signature Code on File" Q

 .S X=$$UPPER^HLFNC(X) D HASH^XUSHSHP I X'=$P(^VA(200,HLDUZ,20),"^",4)!($P(^(20),"^",2)']"") S HLERR="Invalid Electronic Signature Code" Q

 .S HLESIG=$P(^VA(200,HLDUZ,20),"^",2)

 S:HLROU'["^" HLROU="^"_HLROU Q

ACK ;Create and Send 'AR' Error Type Acknowledgement Message

 K HLDATA,HLL,^TMP("HLR",$J) S HLSDATA(2)="MSA"_HLFS_"AR"_HLFS_HLMID_HLFS_HLERR

 K HLERR D SEND^HLLP,KILL

REPLY ;Send a Reply/Ack to a HL7 Message Received

 N I,HLAC,HLMSG,HLERR

 I $D(HLSDT) S I="",I=$O(^TMP("HLS",$J,HLSDT,I)),I=$O(^(I)),HLMSA=$G(^(+I))

 I '$D(HLSDT),$D(HLSDATA) S I="",I=$O(HLSDATA(I)),I=$O(HLSDATA(I)),HLMSA=$G(HLSDATA(+I))

 I $D(HLMSA),$D(HLDAP),HLDAP,$E(HLMSA,1,3)="MSA" S HLMSG="" D

 . S HLAC=$P(HLMSA,HLFS,2)

 . Q:(HLAC="")!('$D(HLNDAP))

 . I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)

 . S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3)

 . D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))

 I $D(HLSEC) D

 . I $D(HLSDT) S I="",I=$O(^TMP("HLS",$J,HLSDT,I)),$P(^TMP("HLS",$J,HLSDT,I),HLFS,8)=HLSEC

 . I '$D(HLSDT) S I="",I=$O(HLSDATA(I)),$P(HLSDATA(I),HLFS,8)=HLSEC

 K HLERR

 D SEND^HLLP,KILL

 K ^TMP("HLS",$J)

KILL ;Kill variables before receiving another HL7 message

 K HLB,HLC,HLC1,HLC2,HLCSUM,HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLDUZ,HLECH,HLERR,HLESIG,HLFS,HLI,HLII,HLK,HLMID,HLMSA,HLMTN,HLPID,HLQ,HLROU,HLSA,HLSDATA,HLSDT,HLVER,X,X0,X1

 D NOW^%DTC S HLTIME=% K %,%H,%I Q

HLCHK.m