source: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCHK.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1HLCHK ;AISC/SAW-Validate HL7 Messages Received ;3/24/2004 14:09
2 ;;1.6;HEALTH LEVEL SEVEN;**1,108**;Oct 13, 1995
3 ;This routine is used for the Version 1.5 Interface Only
4 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)
5 K HLDATA,HLL,HLMSA,HLMT,HLMTP,^TMP("HLR",$J) I HLROU="^NONE"!(HLROU="^") D KILL Q
6 D @HLROU G REPLY
7MSH ;Create MSH Segment for HL7 Reply
8 I '$D(HLDT)!('$D(HLDT1)) N %,%H,%I D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(HLDT)
9 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
10CHK ;Validate Data in Header Segment of an HL7 Message
11 K HLERR S HLDATA=HLL(1),HLFS=$E(HLDATA,4),HLECH=$P(HLDATA,HLFS,2),HLQ="""""",HLDAN=$P(HLDATA,HLFS,5),HLMNT="" D
12 .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)
13 .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)
14 I HLMTN']"" S HLERR="Invalid Message Type" Q
15 I '$D(^HL(771.2,"B",HLMTN)) S HLERR="Invalid Message Type" Q
16 I HLFS=""!(HLFS?.C) S HLERR="Invalid Header Segment" Q
17 I $E(HLDATA,1,3)'="MSH",$E(HLDATA,1,3)'="BHS" S HLERR="Invalid Header Segment" Q
18 I HLDAN']"" S HLERR="Invalid Receiving Application" Q
19 ; patch HL*1.6*108 start
20 ;S HLDAP=+$O(^HL(771,"B",HLDAN,0)) I 'HLDAP S HLDAN=$$UPPER^HLFNC(HLDAN),HLDAP=+$O(^HL(771,"B",HLDAN,0))
21 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))
22 ; patch HL*!.6*108 end
23 ;
24 I 'HLDAP S HLERR="Invalid Receiving Application" Q
25 I '$D(^HL(771,HLDAP,0)) S HLERR="Invalid Receiving Application" Q
26 I $P(^HL(771,HLDAP,0),"^",2)'="a" S HLERR="Receiving Application is Inactive" Q
27 S X=$P(HLDATA,HLFS,3) I X']"" S HLERR="Invalid Sending Application" Q
28 I '$D(^HL(770,"AF",X)) S X=$$UPPER^HLFNC(X)
29 I '$D(^HL(770,"AF",X)) S HLERR="Invalid Sending Application" Q
30 S HLSA=X,X=$P(HLDATA,HLFS,4) I X']"" S HLERR="Invalid Sending Facility" Q
31 I '$D(^HL(770,"AF",HLSA,X)) S X=$$UPPER^HLFNC(X)
32 I '$D(^HL(770,"AF",HLSA,X)) S HLERR="Invalid Sending Facility" Q
33 S X=$P(HLDATA,HLFS,6),X=$$UPPER^HLFNC(X) I X']"" S HLERR="Invalid Receiving Facility" Q
34 I '$D(^HL(770,"AE",HLSA,X)) S HLERR="Invalid Receiving Facility" Q
35 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)
36 I HLVER']"" S HLERR="Invalid HL7 Version" Q
37 S X=$O(^HL(771.5,"B",HLVER,0)) I 'X S HLERR="Invalid HL7 Version" Q
38 I X'=$P(^HL(770,+$O(^HL(770,"B",HLSA,0)),0),"^",7) S HLERR="Invalid HL7 version for Receiving Application" Q
39 I "DTP"'[HLPID S HLERR="Inappropriate HL7 Processing ID" Q
40 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
41 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
42 S X=$P($P(HLDATA,HLFS,8),$E(HLECH)),X=$$UPPER^HLFNC(X) D ^XUSHSH D Q:$D(HLERR)
43 .I X']"" S:HLMTN'="ACK"&(HLMTN'="MCF")&(HLMTN'="ORR") HLDUZ=0 Q
44 .S HLDUZ=+$O(^VA(200,"A",X,0)) I '$D(^VA(200,HLDUZ,.1)) I HLMTN'="ACK",HLMTN'="MCF",HLMTN'="ORR" S HLDUZ=0
45 S X=$P($P(HLDATA,HLFS,8),$E(HLECH),3) I X]"" D Q:$D(HLERR)
46 .I '$D(^VA(200,HLDUZ,20)) S HLERR="No Signature Code on File" Q
47 .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
48 .S HLESIG=$P(^VA(200,HLDUZ,20),"^",2)
49 S:HLROU'["^" HLROU="^"_HLROU Q
50ACK ;Create and Send 'AR' Error Type Acknowledgement Message
51 K HLDATA,HLL,^TMP("HLR",$J) S HLSDATA(2)="MSA"_HLFS_"AR"_HLFS_HLMID_HLFS_HLERR
52 K HLERR D SEND^HLLP,KILL
53 Q
54 ;
55REPLY ;Send a Reply/Ack to a HL7 Message Received
56 N I,HLAC,HLMSG,HLERR
57 I $D(HLSDT) S I="",I=$O(^TMP("HLS",$J,HLSDT,I)),I=$O(^(I)),HLMSA=$G(^(+I))
58 I '$D(HLSDT),$D(HLSDATA) S I="",I=$O(HLSDATA(I)),I=$O(HLSDATA(I)),HLMSA=$G(HLSDATA(+I))
59 I $D(HLMSA),$D(HLDAP),HLDAP,$E(HLMSA,1,3)="MSA" S HLMSG="" D
60 . S HLAC=$P(HLMSA,HLFS,2)
61 . Q:(HLAC="")!('$D(HLNDAP))
62 . I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
63 . S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3)
64 . D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
65 ;
66 I $D(HLSEC) D
67 . I $D(HLSDT) S I="",I=$O(^TMP("HLS",$J,HLSDT,I)),$P(^TMP("HLS",$J,HLSDT,I),HLFS,8)=HLSEC
68 . I '$D(HLSDT) S I="",I=$O(HLSDATA(I)),$P(HLSDATA(I),HLFS,8)=HLSEC
69 ;
70 K HLERR
71 D SEND^HLLP,KILL
72 K ^TMP("HLS",$J)
73 Q
74 ;
75KILL ;Kill variables before receiving another HL7 message
76 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
77 D NOW^%DTC S HLTIME=% K %,%H,%I Q
Note: See TracBrowser for help on using the repository browser.