HLCHK ;AISC/SAW-Validate HL7 Messages Received ;7/10/2008 16:52
;;1.6;HEALTH LEVEL SEVEN;**1,108,1006**;Oct 13, 1995
;
; Modified - IHS/CNI/TPF - 02/25/03 - Lines ACK+2 & REPLY+15
; IHS/CNI/VEN/TOAD - 10 July 2008 - explanation of mod by Rick Marshall,
; VISTA Expertise Network: This modification improves support for TCP
; connections for MSM & Cache systems by branching to IHS's SEND^HLZTCP
; instead of VA's SEND^HLLP. Tim Frazier of IHS/Chickasaw Nation
; Industries developed this mod.
;
;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
;
; ** IHS mod ** IHS/CNI/TPF - 02/25/03 - Support TCP connection for MSM & Cache
;K HLERR D SEND^HLLP,KILL
K HLERR
D @$S($D(HLZTCP):"SEND^HLZTCP",1:"SEND^HLLP")
D KILL
;
Q
;
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
;
; ** IHS mod ** IHS/CNI/TPF - 02/25/03 - Support TCP connection for MSM & Cache
;D SEND^HLLP,KILL
D @$S($D(HLZTCP):"SEND^HLZTCP",1:"SEND^HLLP")
D KILL
;
K ^TMP("HLS",$J)
Q
;
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 ;AISC/SAW-Validate HL7 Messages Received ;7/10/2008 16:52
+1 ;;1.6;HEALTH LEVEL SEVEN;**1,108,1006**;Oct 13, 1995
+2 ;
+3 ; Modified - IHS/CNI/TPF - 02/25/03 - Lines ACK+2 & REPLY+15
+4 ; IHS/CNI/VEN/TOAD - 10 July 2008 - explanation of mod by Rick Marshall,
+5 ; VISTA Expertise Network: This modification improves support for TCP
+6 ; connections for MSM & Cache systems by branching to IHS's SEND^HLZTCP
+7 ; instead of VA's SEND^HLLP. Tim Frazier of IHS/Chickasaw Nation
+8 ; Industries developed this mod.
+9 ;
+10 ;This routine is used for the Version 1.5 Interface Only
+11 DO CHK
DO IN^HLTF(HLMTN,HLMID,HLTIME)
SET HLMT=$SELECT(HLMTN="QRY":"ORF",HLMTN="ORM":"ORR",1:"ACK")
DO MSH
IF $DATA(HLERR)
GOTO ACK
+12 KILL HLDATA,HLL,HLMSA,HLMT,HLMTP,^TMP("HLR",$JOB)
IF HLROU="^NONE"!(HLROU="^")
DO KILL
QUIT
+13 DO @HLROU
GOTO REPLY
MSH ;Create MSH Segment for HL7 Reply
+1 IF '$DATA(HLDT)!('$DATA(HLDT1))
NEW %,%H,%I
DO NOW^%DTC
SET HLDT=%
SET HLDT1=$$HLDATE^HLFNC(HLDT)
+2 SET HLSDATA(1)="MSH"_HLFS_HLECH_HLFS_$PIECE(HLDATA,HLFS,5,6)_HLFS_$PIECE(HLDATA,HLFS,3,4)_HLFS_HLDT1_HLFS_HLFS_HLMT_HLFS_HLDT_HLFS_HLPID_HLFS_HLVER
QUIT
CHK ;Validate Data in Header Segment of an HL7 Message
+1 KILL HLERR
SET HLDATA=HLL(1)
SET HLFS=$EXTRACT(HLDATA,4)
SET HLECH=$PIECE(HLDATA,HLFS,2)
SET HLQ=""""""
SET HLDAN=$PIECE(HLDATA,HLFS,5)
SET HLMNT=""
Begin DoDot:1
+2 IF $EXTRACT(HLDATA,1,3)="BHS"
SET HLMID=$PIECE(HLDATA,HLFS,11)
SET X=$PIECE(HLDATA,HLFS,9)
SET HLPID=$PIECE(X,$EXTRACT(HLECH),2)
SET HLMTN=$EXTRACT($PIECE(X,$EXTRACT(HLECH),3),1,3)
SET HLVER=$PIECE(X,$EXTRACT(HLECH),4)
IF $PIECE(HLDATA,HLFS,10)]""
SET HLMSA=$PIECE(HLDATA,HLFS,10)
SET $PIECE(HLMSA,$EXTRACT(HLECH),2)=$PIECE(HLDATA,HLFS,12)
+3 IF $EXTRACT(HLDATA,1,3)="MSH"
SET HLMID=$PIECE(HLDATA,HLFS,10)
SET HLPID=$PIECE(HLDATA,HLFS,11)
SET HLMTN=$PIECE($PIECE(HLDATA,HLFS,9),$EXTRACT(HLECH))
SET HLVER=$PIECE(HLDATA,HLFS,12)
IF HLMTN=""
SET HLMTN=0
IF $EXTRACT($GET(HLL(2)),1,3)="MSA"
SET HLMSA=HLL(2)
End DoDot:1
+4 IF HLMTN']""
SET HLERR="Invalid Message Type"
QUIT
+5 IF '$DATA(^HL(771.2,"B",HLMTN))
SET HLERR="Invalid Message Type"
QUIT
+6 IF HLFS=""!(HLFS?.C)
SET HLERR="Invalid Header Segment"
QUIT
+7 IF $EXTRACT(HLDATA,1,3)'="MSH"
IF $EXTRACT(HLDATA,1,3)'="BHS"
SET HLERR="Invalid Header Segment"
QUIT
+8 IF HLDAN']""
SET HLERR="Invalid Receiving Application"
QUIT
+9 ; patch HL*1.6*108 start
+10 ;S HLDAP=+$O(^HL(771,"B",HLDAN,0)) I 'HLDAP S HLDAN=$$UPPER^HLFNC(HLDAN),HLDAP=+$O(^HL(771,"B",HLDAN,0))
+11 SET HLDAP=+$ORDER(^HL(771,"B",$EXTRACT(HLDAN,1,30),0))
IF 'HLDAP
SET HLDAN=$$UPPER^HLFNC(HLDAN)
SET HLDAP=+$ORDER(^HL(771,"B",$EXTRACT(HLDAN,1,30),0))
+12 ; patch HL*!.6*108 end
+13 ;
+14 IF 'HLDAP
SET HLERR="Invalid Receiving Application"
QUIT
+15 IF '$DATA(^HL(771,HLDAP,0))
SET HLERR="Invalid Receiving Application"
QUIT
+16 IF $PIECE(^HL(771,HLDAP,0),"^",2)'="a"
SET HLERR="Receiving Application is Inactive"
QUIT
+17 SET X=$PIECE(HLDATA,HLFS,3)
IF X']""
SET HLERR="Invalid Sending Application"
QUIT
+18 IF '$DATA(^HL(770,"AF",X))
SET X=$$UPPER^HLFNC(X)
+19 IF '$DATA(^HL(770,"AF",X))
SET HLERR="Invalid Sending Application"
QUIT
+20 SET HLSA=X
SET X=$PIECE(HLDATA,HLFS,4)
IF X']""
SET HLERR="Invalid Sending Facility"
QUIT
+21 IF '$DATA(^HL(770,"AF",HLSA,X))
SET X=$$UPPER^HLFNC(X)
+22 IF '$DATA(^HL(770,"AF",HLSA,X))
SET HLERR="Invalid Sending Facility"
QUIT
+23 SET X=$PIECE(HLDATA,HLFS,6)
SET X=$$UPPER^HLFNC(X)
IF X']""
SET HLERR="Invalid Receiving Facility"
QUIT
+24 IF '$DATA(^HL(770,"AE",HLSA,X))
SET HLERR="Invalid Receiving Facility"
QUIT
+25 IF '$DATA(HLNDAP0)
SET HLNDAP=+$ORDER(^HL(770,"B",HLSA,0))
SET HLNDAP0=$GET(^HL(770,HLNDAP,0))
IF $PIECE(HLNDAP0,"^",6)]""
SET HLION=$PIECE(HLNDAP0,"^",6)
+26 IF HLVER']""
SET HLERR="Invalid HL7 Version"
QUIT
+27 SET X=$ORDER(^HL(771.5,"B",HLVER,0))
IF 'X
SET HLERR="Invalid HL7 Version"
QUIT
+28 IF X'=$PIECE(^HL(770,+$ORDER(^HL(770,"B",HLSA,0)),0),"^",7)
SET HLERR="Invalid HL7 version for Receiving Application"
QUIT
+29 IF "DTP"'[HLPID
SET HLERR="Inappropriate HL7 Processing ID"
QUIT
+30 SET HLMTP=+$ORDER(^HL(771.2,"B",HLMTN,0))
IF HLMTN'="ACK"
IF '$ORDER(^HL(771,HLDAP,"MSG","B",HLMTP,0))
SET HLERR="Invalid Message Type for Receiving Application"
QUIT
+31 SET HLROU=$GET(^HL(771,HLDAP,"MSG",+$ORDER(^HL(771,HLDAP,"MSG","B",HLMTP,0)),"R"))
IF HLROU']""!(HLROU="NONE")
IF HLMTN'="ACK"
IF HLMTN'="MCF"
SET HLERR="Invalid Message Type for Receiving Application"
QUIT
+32 SET X=$PIECE($PIECE(HLDATA,HLFS,8),$EXTRACT(HLECH))
SET X=$$UPPER^HLFNC(X)
DO ^XUSHSH
Begin DoDot:1
+33 IF X']""
IF HLMTN'="ACK"&(HLMTN'="MCF")&(HLMTN'="ORR")
SET HLDUZ=0
QUIT
+34 SET HLDUZ=+$ORDER(^VA(200,"A",X,0))
IF '$DATA(^VA(200,HLDUZ,.1))
IF HLMTN'="ACK"
IF HLMTN'="MCF"
IF HLMTN'="ORR"
SET HLDUZ=0
End DoDot:1
IF $DATA(HLERR)
QUIT
+35 SET X=$PIECE($PIECE(HLDATA,HLFS,8),$EXTRACT(HLECH),3)
IF X]""
Begin DoDot:1
+36 IF '$DATA(^VA(200,HLDUZ,20))
SET HLERR="No Signature Code on File"
QUIT
+37 SET X=$$UPPER^HLFNC(X)
DO HASH^XUSHSHP
IF X'=$PIECE(^VA(200,HLDUZ,20),"^",4)!($PIECE(^(20),"^",2)']"")
SET HLERR="Invalid Electronic Signature Code"
QUIT
+38 SET HLESIG=$PIECE(^VA(200,HLDUZ,20),"^",2)
End DoDot:1
IF $DATA(HLERR)
QUIT
+39 IF HLROU'["^"
SET HLROU="^"_HLROU
QUIT
ACK ;Create and Send 'AR' Error Type Acknowledgement Message
+1 KILL HLDATA,HLL,^TMP("HLR",$JOB)
SET HLSDATA(2)="MSA"_HLFS_"AR"_HLFS_HLMID_HLFS_HLERR
+2 ;
+3 ; ** IHS mod ** IHS/CNI/TPF - 02/25/03 - Support TCP connection for MSM & Cache
+4 ;K HLERR D SEND^HLLP,KILL
+5 KILL HLERR
+6 DO @$SELECT($DATA(HLZTCP):"SEND^HLZTCP",1:"SEND^HLLP")
+7 DO KILL
+8 ;
+9 QUIT
+10 ;
REPLY ;Send a Reply/Ack to a HL7 Message Received
+1 NEW I,HLAC,HLMSG,HLERR
+2 IF $DATA(HLSDT)
SET I=""
SET I=$ORDER(^TMP("HLS",$JOB,HLSDT,I))
SET I=$ORDER(^(I))
SET HLMSA=$GET(^(+I))
+3 IF '$DATA(HLSDT)
IF $DATA(HLSDATA)
SET I=""
SET I=$ORDER(HLSDATA(I))
SET I=$ORDER(HLSDATA(I))
SET HLMSA=$GET(HLSDATA(+I))
+4 IF $DATA(HLMSA)
IF $DATA(HLDAP)
IF HLDAP
IF $EXTRACT(HLMSA,1,3)="MSA"
SET HLMSG=""
Begin DoDot:1
+5 SET HLAC=$PIECE(HLMSA,HLFS,2)
+6 IF (HLAC="")!('$DATA(HLNDAP))
QUIT
+7 IF $PIECE(HLMSA,HLFS,4)]""
SET HLERR=$PIECE(HLMSA,HLFS,4)
+8 SET HLAC=$SELECT(HLMTN="MCF":2,HLAC'="AA":4,1:3)
+9 DO STATUS^HLTF0(HLDA,HLAC,$GET(HLMSG))
End DoDot:1
+10 ;
+11 IF $DATA(HLSEC)
Begin DoDot:1
+12 IF $DATA(HLSDT)
SET I=""
SET I=$ORDER(^TMP("HLS",$JOB,HLSDT,I))
SET $PIECE(^TMP("HLS",$JOB,HLSDT,I),HLFS,8)=HLSEC
+13 IF '$DATA(HLSDT)
SET I=""
SET I=$ORDER(HLSDATA(I))
SET $PIECE(HLSDATA(I),HLFS,8)=HLSEC
End DoDot:1
+14 ;
+15 KILL HLERR
+16 ;
+17 ; ** IHS mod ** IHS/CNI/TPF - 02/25/03 - Support TCP connection for MSM & Cache
+18 ;D SEND^HLLP,KILL
+19 DO @$SELECT($DATA(HLZTCP):"SEND^HLZTCP",1:"SEND^HLLP")
+20 DO KILL
+21 ;
+22 KILL ^TMP("HLS",$JOB)
+23 QUIT
+24 ;
KILL ;Kill variables before receiving another HL7 message
+1 KILL 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
+2 DO NOW^%DTC
SET HLTIME=%
KILL %,%H,%I
QUIT
