- 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
- 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
- D SEND^HLLP,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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCHK 5140 printed Feb 18, 2025@23:22:39 Page 2
- HLCHK ;AISC/SAW-Validate HL7 Messages Received ;3/24/2004 14:09
- +1 ;;1.6;HEALTH LEVEL SEVEN;**1,108**;Oct 13, 1995
- +2 ;This routine is used for the Version 1.5 Interface Only
- +3 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
- +4 KILL HLDATA,HLL,HLMSA,HLMT,HLMTP,^TMP("HLR",$JOB)
- IF HLROU="^NONE"!(HLROU="^")
- DO KILL
- QUIT
- +5 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 KILL HLERR
- DO SEND^HLLP
- DO KILL
- +3 QUIT
- +4 ;
- 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 DO SEND^HLLP
- DO KILL
- +17 KILL ^TMP("HLS",$JOB)
- +18 QUIT
- +19 ;
- 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
