Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LA7VORUB

LA7VORUB.m

Go to the documentation of this file. 
  1. LA7VORUB ;DALOI/JMC - Builder of HL7 Lab Results cont'd ;08/16/13  17:02
  1.  ;;5.2;AUTOMATED LAB INSTRUMENTS;**68,74,80**;Sep 27, 1994;Build 19
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. OBR ;Observation Request segment for Lab Order
  1.  ;
  1.  N LA761,LA762,LA7DATA,LA7PLOBR,LA7PRI,LA7RSDT,LA7SAC,LA7SNM,LA7X,LA7Y,LADFINST,OBR,X,Y
  1.  ;
  1.  ; Retrieve placer's OBR information stored in #69.6
  1.  D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
  1.  ;
  1.  ; Retrieve "ORUT" node for this NLT from file #63
  1.  S LA7NLT(63)=""
  1.  I LA7NLT'="" D
  1.  . S LA7X=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT","B",LA7NLT,0))
  1.  . I LA7X>0 S LA7NLT(63)=$G(^LR(LRDFN,LRSS,LRIDT,"ORUT",LA7X,0))
  1.  ;
  1.  ; Default institution from Kernel
  1.  S LADFINST=+$$KSP^XUPARAM("INST")
  1.  ;
  1.  ; Retreive accession info used below  - accession area^accession date^accession number
  1.  S LA7Y=$$CHECKUID^LRWU4(LA("HUID"))
  1.  I LA7Y S LA("HUID",68)=$P(LA7Y,"^",2,4)
  1.  E  S LA("HUID",68)=""
  1.  ;
  1.  ; Initialize OBR segment
  1.  S OBR(0)="OBR"
  1.  S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
  1.  ;
  1.  ; Remote UID
  1.  K LA7X
  1.  M LA7X=LA("RUID")
  1.  S OBR(2)=$$OBR2^LA7VOBR(.LA7X,LA7FS,LA7ECH)
  1.  ;
  1.  ; Host UID
  1.  K LA7X
  1.  M LA7X=LA("HUID")
  1.  S OBR(3)=$$OBR3^LA7VOBR(.LA7X,LA7FS,LA7ECH)
  1.  ;
  1.  ; Universal service ID, build from info stored in #69.6
  1.  K LA7X
  1.  S LA7X=""
  1.  I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
  1.  E  S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,$P(LA7NLT(63),"^",13),LA7X,LA7FS,LA7ECH)
  1.  ;
  1.  ; Collection D/T - only send date if d/t is inexact (2nd piece)
  1.  K LA7X
  1.  S LA7X=$P(LA763(0),"^") S:$P(LA763(0),"^",2) LA7X=$P(LA7X,".")
  1.  S OBR(7)=$$OBR7^LA7VOBR(LA7X)
  1.  ;
  1.  ; Specimen action code from order type in file #63 "ORUT" node
  1.  ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
  1.  S LA7SAC=""
  1.  I $P(LA7NLT(63),"^",5) S LA7SAC=$$GET1^DIQ(64.061,$P(LA7NLT(63),"^",5)_",",2)
  1.  I $G(LA7INTYP)=10 D
  1.  . I LA7SAC="",$G(LA7PLOBR("OBR-4"))="" S LA7SAC="A"
  1.  . I LA7NVAF=1,LA7SAC'?1(1"G",1"R",1"A") S LA7SAC=""
  1.  I LA7SAC'="" S OBR(11)=$$OBR11^LA7VOBR(LA7SAC)
  1.  ;
  1.  ; Infection Warning
  1.  S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
  1.  ;
  1.  ; Lab Arrival Time
  1.  ; "CH" subscript does not store lab arrival time - attempt to retrieve from file #68.
  1.  ; Other subscripts do store lab arrival time (date/time received).
  1.  I LA("SUB")?1(1"MI",1"SP",1"CY",1"EM") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
  1.  I LA("SUB")="CH",LA("HUID",68) D
  1.  . S LA7X=$G(^LRO(68,$P(LA("HUID",68),"^"),1,$P(LA("HUID",68),"^",2),1,$P(LA("HUID",68),"^",3),3))
  1.  . I $P(LA7X,"^",3) S OBR(14)=$$OBR14^LA7VOBR($P(LA7X,"^",3))
  1.  ;
  1.  ; Specimen source
  1.  S (LA761,LA762,LA7Y)="",LA7SNM=1
  1.  I LA("SUB")?1(1"CH",1"MI") D
  1.  . S LA761=$P(LA763(0),U,5)
  1.  . I LA761="" D CREATE^LA7LOG(27)
  1.  . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11)
  1.  ;
  1.  ; If multiple different specimens then OBR-15 always indicates XXX for AP subscripts - specimen is communicated in OBX segments.
  1.  I LA("SUB")?1(1"SP",1"CY",1"EM") D
  1.  . S LA7I=0
  1.  . F  S LA7I=$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),.1,LA7I)) Q:'LA7I   D  Q:'LA7I
  1.  . . S LA7X=$P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),.1,LA7I,0),"^",6)
  1.  . . I 'LA761,LA7X S LA761=LA7X
  1.  . . I LA761,LA7X,(LA761'=LA7X) S (LA761,LA7I)=0
  1.  . S LA762=$P(LA7NLT(63),"^",9)
  1.  ;
  1.  I LA7NVAF=1 S LA7SNM=2
  1.  ;
  1.  S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,LA7Y,LA7FS,LA7ECH,"",LA7SNM)
  1.  ;
  1.  ; If LEDI reflex test and not DoD/CHCS interface
  1.  ;    then check original ordered test for placer field 1/2 (OBR-18/19) and ordering provider (OBR-17)
  1.  I $G(LA7INTYP)=10,LA7SAC="G",LA7NVAF'=1,$G(LA7PLOBR("OBR-18"))="",$G(LA7PLOBR("OBR-19"))="" D
  1.  . N LA7REFLEXNLT,LA7REFLEXPARENT
  1.  . S LA7REFLEXNLT=$P(LA7NLT(63),"^",15)
  1.  . I LA7REFLEXNLT="" Q
  1.  . D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA7REFLEXNLT,.LA7REFLEXPARENT)
  1.  . F I="OBR-18","OBR-19" S LA7PLOBR(I)=$G(LA7REFLEXPARENT(I))
  1.  . I $G(LA7PLOBR("OBR-17"))="" S LA7PLOBR("OBR-17")=$G(LA7REFLEXPARENT("OBR-17"))
  1.  ;
  1.  ; Ordering provider
  1.  K LA7X,LA7Y
  1.  S (LA7X,LA7Y)=""
  1.  ; "CH" subscript stores requesting provider and requesting div/location.
  1.  I LA("SUB")="CH" D
  1.  . N LA7J
  1.  . S LA7J=$P(LA763(0),"^",13)
  1.  . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
  1.  . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
  1.  . S LA7X=$P(LA763(0),"^",10)
  1.  ;
  1.  ; Other subscripts only store requesting provider
  1.  I LA("SUB")?1(1"MI",1"SP",1"CY",1"EM") S LA7X=$P(LA763(0),"^",7)
  1.  ;
  1.  ; Send back ordering provider stored in #69.6 if available.
  1.  I LA7INTYP=10,$G(LA7PLOBR("OBR-17"))'="" S LA7X=LA7PLOBR("OBR-17")
  1.  ;
  1.  I LA7Y="" S LA7Y=LADFINST
  1.  S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$S($G(LA7INTYP)=30:2,$G(LA7NVAF)=1:0,1:1))
  1.  ;
  1.  ; Placer Field #1 (remote auto-inst)
  1.  ; Build from info stored in #69.6
  1.  I $G(LA7PLOBR("OBR-18"))'="" D
  1.  . K LA7X
  1.  . S LA7X=$$UNESC^LA7VHLU3(LA7PLOBR("OBR-18"),LA7PLOBR("FS")_LA7PLOBR("ECH"))
  1.  . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
  1.  ;
  1.  ; Else build "auto instrument" if sending to VA facility
  1.  I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
  1.  . K LA7X
  1.  . S LA7X(1)=LA("AUTO-INST")
  1.  . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
  1.  ;
  1.  ; Placer Field #2
  1.  I $G(LA7PLOBR("OBR-19"))'="" D
  1.  . K LA7X
  1.  . S LA7X=$$UNESC^LA7VHLU3(LA7PLOBR("OBR-19"),LA7PLOBR("FS")_LA7PLOBR("ECH"))
  1.  . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
  1.  ;
  1.  ; Else build collecting UID if sending to VA facility
  1.  I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D
  1.  . K LA7X
  1.  . S LA7X(7)=LA("RUID")
  1.  . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
  1.  ;
  1.  ; Filler Field #1
  1.  ; Send file #63 ien info - used by HDR to track patient/specimen
  1.  K LA7X
  1.  S LA7X(1)=LA("LRDFN"),LA7X(2)=LA("SUB"),LA7X(3)=LA("LRIDT")
  1.  S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
  1.  ;
  1.  ; Filler Field #2
  1.  ; Send Accession/test info - used by DSS to track patient/specimen
  1.  ; LRACC^LRAA^LRAD^LRAN^Accession Area^Area Abbreviation^NLT
  1.  K LA7X
  1.  S LA7X(1)=$P(LA763(0),"^",6),LA7X(7)=LA7NLT
  1.  S LA7Y=LA("HUID",68)
  1.  I LA7Y D
  1.  . N I
  1.  . F I=1,2,3 S LA7X(I+1)=$P(LA7Y,"^",I)
  1.  . S LA7X(5)=$P($G(^LRO(68,$P(LA7Y,"^"),0)),"^")
  1.  . S LA7X(6)=$P($G(^LRO(68,$P(LA7Y,"^"),0)),"^",11)
  1.  S OBR(21)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
  1.  K LA7X
  1.  ;
  1.  ; Date Report Completed/Report status/Responsible person
  1.  ; Determine report date and status from 0 node.
  1.  S LA7RSDT=$P(LA763(0),"^",3),(LA7PRI,LA7RS)=""
  1.  ;
  1.  ; If CYEMSP subscripts then check for corrected report
  1.  I LA("SUB")?1(1"SP",1"CY",1"EM") D
  1.  . S LA7RSDT=$P(LA763(0),"^",11),LA7PRI=$P(LA763(0),"^",2)
  1.  . I LA7RSDT S LA7RS="F"
  1.  . I $P(LA763(0),"^",15) S LA7RS="C"
  1.  . I $G(LRSB)=1.2,$G(LA7SR) S LA7RSDT=+$G(^LR(LRDFN,LA("SUB"),LRIDT,LRSB,LA7SR,0),"^")
  1.  ;
  1.  ; If MI subscript then also check various sections and audit subfile for corrected report
  1.  I LA("SUB")="MI" D
  1.  . S LA7PRI=$P(LA763(0),"^",4)
  1.  . S LA7X=$S(LRSB=11:1,LRSB=11.52:1,LRSB=11.6:1,LRSB=12:1,LRSB=14:5,LRSB=16:5,LRSB=18:8,LRSB=20:8,LRSB=22:11,LRSB=26:11,LRSB=24:11,LRSB=33:16,LRSB=36:16,1:0)
  1.  . S LA7Y=$G(^LR(LRDFN,"MI",LRIDT,LA7X),"^")
  1.  . I $P(LA7Y,"^") S LA7RSDT=$P(LA7Y,"^"),LA7RS=$P(LA7Y,"^",2),LA7PRI=$P(LA7Y,"^",$S(LA7X=11:5,1:3))
  1.  . I $P(LA763(0),"^",9)=1 S LA7RS="C" Q
  1.  . I '$D(^LR(LRDFN,"MI",LRIDT,32)) Q
  1.  . S I=0
  1.  . F  S I=$O(^LR(LRDFN,"MI",LRIDT,32,I)) Q:'I  I $P(^(I,0),"^",4)>1,LA7RS="F" S LA7RS="C" Q
  1.  ;
  1.  ; Also check for individual test status on "ORUT" node in file #63
  1.  I $P(LA7NLT(63),"^",10) S LA7RS=$P(LA7NLT(63),"^",10)
  1.  ;
  1.  ; Date Report Completed
  1.  I LA7RSDT S OBR(22)=$$OBR22^LA7VOBR(LA7RSDT)
  1.  ;
  1.  ; Diagnostic service id
  1.  S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
  1.  ;
  1.  ; Result status
  1.  I LA7RS'="" S OBR(25)=$$OBR25^LA7VOBR(LA7RS)
  1.  ;
  1.  ; Parent Result and Parent
  1.  I $D(LA7PARNT) D
  1.  . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
  1.  . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
  1.  ;
  1.  ; Principle result interpreter
  1.  I LA("SUB")?1(1"CY",1"EM",1"MI",1"SP"),LA7PRI'="" S OBR(32)=$$OBR32^LA7VOBR(LA7PRI,LADFINST,LA7FS,LA7ECH)
  1.  ;
  1.  ; Assistant result interpreter
  1.  I LA("SUB")?1(1"SP",1"EM"),$P(LA763(0),"^",4) S OBR(33)=$$OBR33^LA7VOBR($P(LA763(0),"^",4),LADFINST,LA7FS,LA7ECH)
  1.  ;
  1.  ; Technician
  1.  I LA("SUB")?1(1"CY",1"EM"),$P(LA763(0),"^",4) S OBR(34)=$$OBR34^LA7VOBR($P(LA763(0),"^",4),LADFINST,LA7FS,LA7ECH)
  1.  ;
  1.  ; Typist - VistA stores as free text
  1.  I LA("SUB")?1(1"SP",1"CY",1"EM"),$P(LA763(0),"^",9)'="" S OBR(35)=$$OBR35^LA7VOBR($P(LA763(0),"^",9),LADFINST,LA7FS,LA7ECH)
  1.  ;
  1.  ; Procedure code - use Order NLT code
  1.  S OBR(44)=$$OBR44^LA7VOBR(LA7NLT,LA7FS,LA7ECH)
  1.  ;
  1.  D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
  1.  D FILESEG^LA7VHLU(GBL,.LA7DATA)
  1.  ;
  1.  ; Check for flag to only build message but do not file
  1.  I '$G(LA7NOMSG) D
  1.  . D FILE6249^LA7VHLU(LA76249,.LA7DATA)
  1.  . I LA("HUID")'="" D
  1.  . . D SETID^LA7VHLU1(LA76249,LA7ID,LA("HUID"),0)
  1.  . . D SETID^LA7VHLU1(LA76249,"",LA("HUID"),0)
  1.  . I LA("RUID")'="" D
  1.  . . D SETID^LA7VHLU1(LA76249,LA7ID,LA("RUID"),0)
  1.  . . D SETID^LA7VHLU1(LA76249,"",LA("RUID"),0)
  1.  ;
  1.  Q