source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VOBRA.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1LA7VOBRA ;DALOI/JMC - LAB OBR segment builder (cont'd); 11-14-01
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 1994
3 ;
4 Q
5 ;
6 ;
7OBR4 ; Build OBR-4 sequence - Universal service ID
8 ;
9 S LA764=0,LA7Y=""
10 ; specify component position - primary/alternate
11 S LA7COMP=0
12 ;
13 ; Send non-VA test codes as first coding system
14 I LA7ALT'="" D
15 . N I
16 . F I=1:1:3 S $P(LA7Y,$E(LA7ECH),LA7COMP+I)=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",I),LA7FS_LA7ECH)
17 . S LA7COMP=LA7COMP+I
18 ;
19 ; Send NLT test codes as primary unless non-VA codes then send as alternate code
20 I LA7NLT'="" D
21 . S LA764=$O(^LAM("E",LA7NLT,0)),LA7Z=""
22 . I LA764 S LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")
23 . I LA7Z="" D
24 . . N LA7642
25 . . S LA764=$O(^LAM("E",$P(LA7NLT,".")_".0000",0))
26 . . I LA764 S LA7Z=$$GET1^DIQ(64,LA764_",",.01,"I")
27 . . S LA7642=$O(^LAB(64.2,"C","."_$P(LA7NLT,".",2),0))
28 . . I LA764,LA7642 S LA7Z=LA7Z_"~"_$$GET1^DIQ(64.2,LA7624_",",.01,"I")
29 . S $P(LA7Y,$E(LA7ECH),LA7COMP+1)=$$CHKDATA^LA7VHLU3(LA7NLT,LA7FS_LA7ECH)
30 . S $P(LA7Y,$E(LA7ECH),LA7COMP+2)=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
31 . S $P(LA7Y,$E(LA7ECH),LA7COMP+3)="99VA64"
32 . S LA7COMP=LA7COMP+3
33 ;
34 ; Send file #60 test name if available and no alternate
35 I LA7COMP<4,LA760 D
36 . S LA7TN=$$GET1^DIQ(60,LA760_",",.01)
37 . S $P(LA7Y,$E(LA7ECH),LA7COMP+1)=LA760
38 . S $P(LA7Y,$E(LA7ECH),LA7COMP+2)=$$CHKDATA^LA7VHLU3(LA7TN,LA7FS_LA7ECH)
39 . S $P(LA7Y,$E(LA7ECH),LA7COMP+3)="99VA60"
40 ;
41 Q
42 ;
43 ;
44OBR9 ; Build OBR-9 sequence - collection volume
45 ;
46 ; Collection volume
47 S $P(LA7Y,$E(LA7ECH,1))=LA7VOL
48 ;
49 I LA764061 D
50 . S LA7IENS=LA764061_","
51 . D GETS^DIQ(64.061,LA7IENS,".01;1","E","LA7Y")
52 . ; Collection Volume units code
53 . S $P(LA7X,$E(LA7ECH,4),1)=$G(LA7Y(64.061,LA7IENS,.01,"E"))
54 . ; Collection Volume units text
55 . S $P(LA7X,$E(LA7ECH,4),2)=$$CHKDATA^LA7VHLU3($G(LA7Y(64.061,LA7IENS,1,"E")),LA7FS_LA7ECH)
56 . ; LOINC coding system
57 . S $P(LA7X,$E(LA7ECH,4),3)="LN"
58 . S $P(LA7Y,$E(LA7ECH,1),2)=LA7X
59 ;
60 Q
61 ;
62 ;
63OBR15 ; Build OBR-15 sequence - specimen source
64 ;
65 S LA764061=0
66 S LA7COMP=0 ; specify subcomponent position - primary/alternate
67 S LA7Y=""
68 ;
69 ; Get entry in #64.061 for this Topography file #61 entry.
70 I LA761>0 S LA764061=$$GET1^DIQ(61,LA761_",",.09,"I","LA7ERR")
71 ;
72 ; If no specimen code then default to HL7 0070 entry "XXX"
73 I LA764061<1 D
74 . N LA7SCR
75 . S LA7SCR="I $P(^LAB(64.061,Y,0),U,5)=""0070"",$P(^LAB(64.061,Y,0),U,7)=""S"""
76 . S LA764061=$$FIND1^DIC(64.061,,"X","XXX","D",LA7SCR,"LA7ERR")
77 ;
78 I LA764061<1 Q LA7Y
79 ;
80 D GETS^DIQ(64.061,LA764061_",",".01;1;2;3;5","","LA7Z","LA7ERR")
81 I '$D(LA7Z) Q LA7Y
82 ;
83 ; Send non-standard local code as primary
84 I $P(LA7ALT,"^")'=""!($P(LA7ALT,"^",2)'="") D
85 . S LA7X=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^"),LA7FS_LA7ECH)
86 . S $P(LA7Y,$E(LA7ECH,4),1)=LA7X
87 . S LA7X=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",2),LA7FS_LA7ECH)
88 . S $P(LA7Y,$E(LA7ECH,4),2)=LA7X
89 . S $P(LA7Y,$E(LA7ECH,4),3)=$P(LA7ALT,"^",3)
90 . S LA7COMP=LA7COMP+3
91 ;
92 ; Send HL7 Table 0070 coding as primary code
93 I LA7Z(64.061,LA764061_",",2)'="",LA7COMP<6 D
94 . S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",2),LA7FS_LA7ECH)
95 . S $P(LA7Y,$E(LA7ECH,4),LA7COMP+1)=LA7X
96 . S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",.01),LA7FS_LA7ECH)
97 . S $P(LA7Y,$E(LA7ECH,4),LA7COMP+2)=LA7X
98 . S $P(LA7Y,$E(LA7ECH,4),LA7COMP+3)="HL7"_LA7Z(64.061,LA764061_",",5)
99 . S LA7COMP=LA7COMP+3
100 ;
101 ; Send LOINC code as primary unless HL7 code then send as alternate code
102 I LA7Z(64.061,LA764061_",",1)'="",LA7COMP<6 D
103 . S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",1),LA7FS_LA7ECH)
104 . S $P(LA7Y,$E(LA7ECH,4),LA7COMP+1)=LA7X
105 . S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",.01),LA7FS_LA7ECH)
106 . S $P(LA7Y,$E(LA7ECH,4),LA7COMP+2)=LA7X
107 . S $P(LA7Y,$E(LA7ECH,4),LA7COMP+3)="LN"
108 . S LA7COMP=LA7COMP+3
109 ;
110 ; If VA code and not HL7 and/or LOINC
111 I LA7Z(64.061,LA764061_",",3)'="",LA7COMP<6 D
112 . S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",3),LA7FS_LA7ECH)
113 . S $P(LA7Y,$E(LA7ECH,4),LA7COMP+1)=LA7X
114 . S LA7X=$$CHKDATA^LA7VHLU3(LA7Z(64.061,LA764061_",",.01),LA7FS_LA7ECH)
115 . S $P(LA7Y,$E(LA7ECH,4),LA7COMP+2)=LA7X
116 . S $P(LA7Y,$E(LA7ECH,4),LA7COMP+3)="99VA64.061"
117 ;
118 ; LA7ALT should contain "CONTROL" in 4th piece if from file #62.3
119 I $P(LA7ALT,"^",4)'="" D
120 . N LA7TXT
121 . S LA7TXT=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",4),LA7FS_LA7ECH)
122 . S $P(LA7Y,$E(LA7ECH,1),3)=LA7TXT
123 ;
124 ;
125 ; Get entry in #62 for this collection sample entry.
126 I LA762,$P(LA7ALT,"^",5)="",$P(LA7ALT,"^",6)="" D
127 . S LA7X=$$GET1^DIQ(62,LA762_",",.01,"","LA7ERR")
128 . S LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
129 . S LA7X=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
130 . S LA7X=LA762_$E(LA7ECH,4)_LA7X_$E(LA7ECH,4)_"99VA62"
131 . S $P(LA7Y,$E(LA7ECH,1),4)=LA7X
132 ;
133 ; Send collection sample code for DoD.
134 I $P(LA7ALT,"^",5)'=""!($P(LA7ALT,"^",6)'="") D
135 . S X=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",5),LA7FS_LA7ECH)
136 . S Y=$$CHKDATA^LA7VHLU3($P(LA7ALT,"^",6),LA7FS_LA7ECH)
137 . S LA7X=X_$E(LA7ECH,4)_Y_$E(LA7ECH,4)_$P(LA7ALT,"^",7)
138 . S $P(LA7Y,$E(LA7ECH,1),4)=LA7X
139 ;
140 ; Send specimen shipping condition - collection method
141 I $G(LA7CM) D
142 . S X=$$GET1^DIQ(62.93,LA7CM_",",.01)
143 . I X'="" S X=$$CHKDATA^LA7VHLU3(X,LA7FS_LA7ECH)
144 . S Y=$$GET1^DIQ(62.93,LA7CM_",",.02)
145 . I Y'="" S Y=$$CHKDATA^LA7VHLU3(Y,LA7FS_LA7ECH)
146 . S LA7X=Y_$E(LA7ECH,4)_X_$E(LA7ECH,4)_"99VA62.93"
147 . S $P(LA7Y,$E(LA7ECH,1),6)=LA7X
148 Q
149 ;
150 ;
151OBR24 ; Build OBR-24 sequence - diagnostic service id
152 ;
153 ; Code non-MI subscripts
154 I $P(LA7SS,"^")'="MI" D Q
155 . S LA7X=$P(LA7SS,"^")
156 . S LA7Y=$S(LA7X="CH":"CH",LA7X="SP":"SP",LA7X="CY":"CP",LA7X="EM":"PAT",LA7X="AU":"PAT",LA7X="BB":"BLB",1:"LAB")
157 ;
158 ; Code MI subscripts
159 S LA7X=$P(LA7SS,"^",2)
160 S LA7Y=$S(LA7X=11:"MB",LA7X=14:"PAR",LA7X=18:"MYC",LA7X=22:"MCB",LA7X=33:"VR",1:"MB")
161 ;
162 Q
163 ;
164 ;
165OBR26 ; Build OBR-26 sequence - Parent result
166 ;
167 S LA7Y=""
168 ;
169 ; Move component into sub-component position
170 ; Translate component character to sub-component character
171 S LA7C=$E(LA7ECH,1),LA7SC=$E(LA7ECH,4)
172 ;
173 ; Parent result observation identifier in 1st component
174 I LA7OBX3'="" S $P(LA7Y,$E(LA7ECH,1),1)=$TR(LA7OBX3,LA7C,LA7SC)
175 ;
176 ; Parent sub-id in 2nd component
177 I LA7OBX4'="" S $P(LA7Y,$E(LA7ECH,1),2)=$TR(LA7OBX4,LA7C,LA7SC)
178 ;
179 ; Parent test result in 3rd component
180 I LA7OBX5'="" S $P(LA7Y,$E(LA7ECH,1),3)=$TR(LA7OBX5,LA7C,LA7SC)
181 ;
182 Q
183 ;
184 ;
185OBR29 ; Build OBR-29 sequence - Parent
186 ;
187 S LA7Y=""
188 ;
189 I $G(LA7PON)'="" D
190 . S LA7Z=$$CHKDATA^LA7VHLU3(LA7PON,LA7FS_LA7ECH)
191 . S $P(LA7Y,$E(LA7ECH,1),1)=LA7Z
192 ;
193 I $G(LA7FON)'="" D
194 . S LA7Z=$$CHKDATA^LA7VHLU3(LA7FON,LA7FS_LA7ECH)
195 . S $P(LA7Y,$E(LA7ECH,2),1)=LA7Z
196 ;
197 Q
198 ;
199 ;
200OBRPF ; Build OBR-18,19,20,21 Placer/Filler #1/#2
201 ;
202 S (LA7Y,LA7Z)="",LA7I=0
203 F S LA7I=$O(LA7X(LA7I)) Q:'LA7I S $P(LA7Z,"^",LA7I)=LA7X(LA7I)
204 S LA7Y=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH)
205 Q
Note: See TracBrowser for help on using the repository browser.