Changeset 1337 for ccr/branches/ohum/p/C0CVORU.m
- Timestamp:
- Jan 4, 2012, 9:40:24 PM (13 years ago)
- File:
-
- 1 edited
-
ccr/branches/ohum/p/C0CVORU.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/branches/ohum/p/C0CVORU.m
r1333 r1337 1 C0C7VORU 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994;Build 1 3 4 EN(LA) 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 CH 43 44 45 46 47 48 49 50 51 52 ORC 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 OBR 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 OBX 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 NTE 272 273 274 1 C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994 3 ; 4 EN(LA) ; called from C0CVLAB 5 ; variables 6 ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68) 7 ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4) 8 ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68) 9 ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64) 10 ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64) 11 ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time) 12 ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60) 13 ; LA("LRDFN") - IEN in LAB DATA file (#63) 14 ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results. 15 ; LA("AUTO-INST") - Auto-Instrument 16 ; 17 N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY 18 ; 19 S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")="" 20 I $G(PRIMARY)'="" D 21 . S PRIMARY=$$SITE^VASITE(DT,PRIMARY) 22 . S PRIMARY=$P(PRIMARY,U,3) 23 . S LA("AUTO-INST")="LA7V HOST "_PRIMARY 24 ; 25 I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q 26 . ; need to add error logging when no entry in 63. 27 ; 28 ; Get zeroth node of entry in #63. 29 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) 30 S LA7NLT=$G(LA("NLT")) 31 ; 32 S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE")) 33 S LA7NTESN=0 34 D ORC 35 ; 36 I $G(LA("SUB"))="CH" D CH 37 ;I $G(LA("SUB"))="MI" D MI^LA7VORU1 38 ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2 39 Q 40 ; 41 ; 42 CH ; Build segments for "CH" subscript 43 ; 44 D OBR 45 D NTE 46 S LA7OBXSN=0 47 D OBX 48 ; 49 Q 50 ; 51 ; 52 ORC ; Build ORC segment 53 ; 54 N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC 55 ; 56 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) 57 ; 58 S ORC(0)="ORC" 59 ; 60 ; Order control 61 S ORC(1)=$$ORC1^LA7VORC("RE") 62 ; 63 ; Remote UID 64 S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH) 65 ; 66 ; Host UID 67 S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH) 68 ; 69 ; Return shipping manifest if found 70 S LA7SM="",LA7696=0 71 I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0)) 72 I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14) 73 I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH) 74 ; 75 ; Order status 76 ; DoD/CHCS requires ORC-5 valued otherwise will not process message 77 I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH) 78 ; 79 ; Ordering provider 80 S (LA7X,LA7Y)="" 81 ; "CH" subscript stores requesting provider and requesting div/location. 82 I LA("SUB")="CH" D 83 . N LA7J 84 . S LA7J=$P(LA763(0),"^",13) 85 . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") 86 . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") 87 . S LA7X=$P(LA763(0),"^",10) 88 ; 89 ; Other subscripts only store requesting provider 90 I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) 91 ; Get default institution from MailMan Site Parameters file 92 I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 93 S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) 94 ; 95 ; Entering organization 96 S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH) 97 ; 98 D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS) 99 D FILESEG^LA7VHLU(GBL,.LA7DATA) 100 ; 101 ; Check for flag to only build message but do not file 102 I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA) 103 ; 104 Q 105 ; 106 ; 107 OBR ;Observation Request segment for Lab Order 108 ; 109 N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR 110 ; 111 ; Retrieve placer's OBR information stored in #69.6 112 D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR) 113 ; 114 ; Initialize OBR segment 115 S OBR(0)="OBR" 116 S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN) 117 ; 118 ; Remote UID 119 S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH) 120 ; 121 ; Host UID 122 S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH) 123 ; 124 ; Universal service ID, build from info stored in #69.6 125 S LA7X="" 126 I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH) 127 E S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH) 128 ; 129 ; Collection D/T 130 S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U)) 131 ; 132 ; Specimen action code 133 ; If no OBR from PENDING ORDER file (#69.6) then assume added test. 134 I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A") 135 ; 136 ; Infection Warning 137 S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH) 138 ; 139 ; Lab Arrival Time 140 ; "CH" subscript does not store lab arrival time, use collection time. 141 ; Other subscripts do store lab arrival time (date/time received). 142 I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10)) 143 I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^")) 144 ; 145 ; Specimen source 146 S (LA761,LA762)="" 147 I "CHMI"[LA("SUB") D 148 . S LA761=$P(LA763(0),U,5) 149 . I LA761="" D CREATE^LA7LOG(27) 150 . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11) 151 S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH) 152 ; 153 ; Ordering provider 154 S (LA7X,LA7Y)="" 155 ; "CH" subscript stores requesting provider and requesting div/location. 156 I LA("SUB")="CH" D 157 . N LA7J 158 . S LA7J=$P(LA763(0),"^",13) 159 . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") 160 . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") 161 . S LA7X=$P(LA763(0),"^",10) 162 ; 163 ; Other subscripts only store requesting provider 164 I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) 165 ; Get default institution from MailMan Site Parameters file 166 I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 167 S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) 168 ; 169 ; Placer Field #1 (remote auto-inst) 170 ; Build from info stored in #69.6 171 I $G(LA7PLOBR("OBR-18"))'="" D 172 . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH) 173 ; Else build "auto instrument" if sending to VA facility 174 I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D 175 . N LA7X 176 . S LA7X(1)=LA("AUTO-INST") 177 . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH) 178 ; 179 ; Placer Field #2 180 I $G(LA7PLOBR("OBR-19"))'="" D 181 . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH) 182 ; Else build collecting UID if sending to VA facility 183 I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D 184 . K LA7X 185 . S LA7X(7)=LA("RUID") 186 . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH) 187 ; 188 ; Filler Field #1 189 ; Send file #63 ien info - used by HDR to track patient/specimen 190 K LA7X 191 S LA7X(1)=LA("LRDFN") 192 S LA7X(2)=LA("SUB") 193 S LA7X(3)=LA("LRIDT") 194 S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH) 195 ; 196 ; Date Report Completed 197 I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3)) 198 ; 199 ; Diagnostic service id 200 S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB)) 201 ; 202 ; Parent Result and Parent 203 I $D(LA7PARNT) D 204 . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH) 205 . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH) 206 ; 207 ; Principle result interpreter 208 ; Get default institution from MailMan Site Parameters file 209 I "CYEMMISP"[LA("SUB") D 210 . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4) 211 . E S LA7X=$P(LA763(0),"^",2) 212 . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 213 . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) 214 ; 215 ; Assistant result interpreter 216 ; Get default institution from MailMan Site Parameters file 217 I "EMSP"[LA("SUB") D 218 . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 219 . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) 220 ; 221 ; Technician 222 ; Get default institution from MailMan Site Parameters file 223 I "CYEM"[LA("SUB") D 224 . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 225 . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) 226 ; 227 ; Typist - VistA stores as free text 228 ; Get default institution from MailMan Site Parameters file 229 I "CYEMSP"[LA("SUB") D 230 . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 231 . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) 232 ; 233 D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS) 234 D FILESEG^LA7VHLU(GBL,.LA7DATA) 235 ; 236 ; Check for flag to only build message but do not file 237 I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) 238 ; 239 Q 240 ; 241 ; 242 OBX ;Observation/Result segment for Lab Results 243 ; 244 N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X 245 ; 246 S LA7VTIEN=0 247 F S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN D 248 . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2) 249 . ; Build OBX segment 250 . K LA7DATA 251 . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF)) 252 . ; If OBX failed to build then don't store 253 . I '$D(LA7DATA) Q 254 . ; 255 . D FILESEG^LA7VHLU(GBL,.LA7DATA) 256 . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) 257 . ; 258 . ; Send performing lab comment and interpretation from file #60 259 . S LA7NTESN=0 260 . I LA7NVAF=1 D PLC^LA7VORUA 261 . D INTRP^LA7VORUA 262 . ; 263 . ; Mark result as sent - set to 1, if corrected results set to 2 264 . I LA("SUB")="CH" D 265 . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q 266 . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1) 267 ; 268 Q 269 ; 270 ; 271 NTE ; Build NTE segment 272 ; 273 D NTE^LA7VORUA 274 Q
Note:
See TracChangeset
for help on using the changeset viewer.
