source: ccr/trunk/p/C0CQRY1.m@ 785

Last change on this file since 785 was 693, checked in by George Lilly, 15 years ago

for RPMS Labs installs
File size: 3.9 KB
RevLine 
[693]1LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 31
3 ;
4 Q
5 ;
6CHKSC ; Check search NLT/LOINC codes
7 ;
8 N J
9 ;
10 S J=0
11 F S J=$O(LA7SC(J)) Q:'J D
12 . N X
13 . S X=LA7SC(J)
14 . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q
15 . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
16 . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q
17 . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
18 . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed"
19 . K LA7SC(J)
20 Q
21 ;
22 ;
23SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes
24 ; Find all topographies that use this HL7 specimen code
25 N J,K,L
26 ;
27 S J=0
28 F S J=$O(LA7SPEC(J)) Q:'J D
29 . S K=LA7SPEC(J),L=0
30 . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)=""
31 Q
32 ;
33 ;
34BUILDMSG ; Build HL7 message with result of query
35 ;
36 N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X
37 ;
38 I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
39 S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
40 S (HLQ,HL("Q"))=""""""
41 ; Set flag to not send HL7 message
42 S LA7NOMSG=1
43 ; Create dummy MSH to pass HL7 delimiters
44 S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
45 D FILESEG^LA7VHLU(GBL,.LA7MSH)
46 ;
47 F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
48 ;
49 ; Take search results and put in HL7 message structure
50 S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0
51 ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M
52 F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT
53 . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
54 . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0
55 . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR
56 . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR
57 . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR
58 . D OBX
59 ;
60 Q
61 ;
62 ;
63PID ; Build PID segment
64 ;
65 N LA7PID
66 ;
67 S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
68 S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
69 D DEM^LRX
70 D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL)
71 D FILESEG^LA7VHLU(GBL,.LA7PID)
72 S (LA("LRIDT"),LA("SUB"))=""
73 Q
74 ;
75 ;
76ORC ; Build ORC segment
77 ;
78 N X
79 ;
80 S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5)
81 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
82 S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
83 S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4)
84 I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
85 S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
86 D ORC^LA7VORU
87 S LA("NLT")=""
88 ;
89 Q
90 ;
91 ;
92OBR ; Build OBR segment
93 ;
94 N LA764,LA7NLT
95 ;
96 S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
97 I $L(LA7NLT) D
98 . S LA764=+$O(^LAM("E",LA7NLT,0))
99 . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
100 I LA("SUB")="CH" D
101 . D OBR^LA7VORU
102 . D NTE^LA7VORU
103 . S LA7OBXSN=0
104 ;
105 Q
106 ;
107 ;
108OBX ; Build OBX segment
109 ;
110 N LA7DATA,LA7VT
111 ;
112 S LA7NTESN=0
113 I LA("SUB")="MI" D MI^LA7VORU1 Q
114 I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
115 ;
116 S LA7VT=$QS(LA7ROOT,7)
117 D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
118 I '$D(LA7DATA) Q
119 D FILESEG^LA7VHLU(GBL,.LA7DATA)
120 ; Send any test interpretation from file #60
121 D INTRP^LA7VORUA
122 ;
123 Q
Note: See TracBrowser for help on using the repository browser.