LA7VORUB ;DALOI/JMC - Builder of HL7 Lab Results cont'd ;08/16/13 17:02
;;5.2;AUTOMATED LAB INSTRUMENTS;**68,74,80**;Sep 27, 1994;Build 19
;
Q
;
;
OBR ;Observation Request segment for Lab Order
;
N LA761,LA762,LA7DATA,LA7PLOBR,LA7PRI,LA7RSDT,LA7SAC,LA7SNM,LA7X,LA7Y,LADFINST,OBR,X,Y
;
; Retrieve placer's OBR information stored in #69.6
D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
;
; Retrieve "ORUT" node for this NLT from file #63
S LA7NLT(63)=""
I LA7NLT'="" D
. S LA7X=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT","B",LA7NLT,0))
. I LA7X>0 S LA7NLT(63)=$G(^LR(LRDFN,LRSS,LRIDT,"ORUT",LA7X,0))
;
; Default institution from Kernel
S LADFINST=+$$KSP^XUPARAM("INST")
;
; Retreive accession info used below - accession area^accession date^accession number
S LA7Y=$$CHECKUID^LRWU4(LA("HUID"))
I LA7Y S LA("HUID",68)=$P(LA7Y,"^",2,4)
E S LA("HUID",68)=""
;
; Initialize OBR segment
S OBR(0)="OBR"
S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
;
; Remote UID
K LA7X
M LA7X=LA("RUID")
S OBR(2)=$$OBR2^LA7VOBR(.LA7X,LA7FS,LA7ECH)
;
; Host UID
K LA7X
M LA7X=LA("HUID")
S OBR(3)=$$OBR3^LA7VOBR(.LA7X,LA7FS,LA7ECH)
;
; Universal service ID, build from info stored in #69.6
K LA7X
S LA7X=""
I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
E S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,$P(LA7NLT(63),"^",13),LA7X,LA7FS,LA7ECH)
;
; Collection D/T - only send date if d/t is inexact (2nd piece)
K LA7X
S LA7X=$P(LA763(0),"^") S:$P(LA763(0),"^",2) LA7X=$P(LA7X,".")
S OBR(7)=$$OBR7^LA7VOBR(LA7X)
;
; Specimen action code from order type in file #63 "ORUT" node
; If no OBR from PENDING ORDER file (#69.6) then assume added test.
S LA7SAC=""
I $P(LA7NLT(63),"^",5) S LA7SAC=$$GET1^DIQ(64.061,$P(LA7NLT(63),"^",5)_",",2)
I $G(LA7INTYP)=10 D
. I LA7SAC="",$G(LA7PLOBR("OBR-4"))="" S LA7SAC="A"
. I LA7NVAF=1,LA7SAC'?1(1"G",1"R",1"A") S LA7SAC=""
I LA7SAC'="" S OBR(11)=$$OBR11^LA7VOBR(LA7SAC)
;
; Infection Warning
S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
;
; Lab Arrival Time
; "CH" subscript does not store lab arrival time - attempt to retrieve from file #68.
; Other subscripts do store lab arrival time (date/time received).
I LA("SUB")?1(1"MI",1"SP",1"CY",1"EM") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
I LA("SUB")="CH",LA("HUID",68) D
. S LA7X=$G(^LRO(68,$P(LA("HUID",68),"^"),1,$P(LA("HUID",68),"^",2),1,$P(LA("HUID",68),"^",3),3))
. I $P(LA7X,"^",3) S OBR(14)=$$OBR14^LA7VOBR($P(LA7X,"^",3))
;
; Specimen source
S (LA761,LA762,LA7Y)="",LA7SNM=1
I LA("SUB")?1(1"CH",1"MI") D
. S LA761=$P(LA763(0),U,5)
. I LA761="" D CREATE^LA7LOG(27)
. I LA("SUB")="MI" S LA762=$P(LA763(0),U,11)
;
; If multiple different specimens then OBR-15 always indicates XXX for AP subscripts - specimen is communicated in OBX segments.
I LA("SUB")?1(1"SP",1"CY",1"EM") D
. S LA7I=0
. F S LA7I=$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),.1,LA7I)) Q:'LA7I D Q:'LA7I
. . S LA7X=$P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),.1,LA7I,0),"^",6)
. . I 'LA761,LA7X S LA761=LA7X
. . I LA761,LA7X,(LA761'=LA7X) S (LA761,LA7I)=0
. S LA762=$P(LA7NLT(63),"^",9)
;
I LA7NVAF=1 S LA7SNM=2
;
S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,LA7Y,LA7FS,LA7ECH,"",LA7SNM)
;
; If LEDI reflex test and not DoD/CHCS interface
; then check original ordered test for placer field 1/2 (OBR-18/19) and ordering provider (OBR-17)
I $G(LA7INTYP)=10,LA7SAC="G",LA7NVAF'=1,$G(LA7PLOBR("OBR-18"))="",$G(LA7PLOBR("OBR-19"))="" D
. N LA7REFLEXNLT,LA7REFLEXPARENT
. S LA7REFLEXNLT=$P(LA7NLT(63),"^",15)
. I LA7REFLEXNLT="" Q
. D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA7REFLEXNLT,.LA7REFLEXPARENT)
. F I="OBR-18","OBR-19" S LA7PLOBR(I)=$G(LA7REFLEXPARENT(I))
. I $G(LA7PLOBR("OBR-17"))="" S LA7PLOBR("OBR-17")=$G(LA7REFLEXPARENT("OBR-17"))
;
; Ordering provider
K LA7X,LA7Y
S (LA7X,LA7Y)=""
; "CH" subscript stores requesting provider and requesting div/location.
I LA("SUB")="CH" D
. N LA7J
. S LA7J=$P(LA763(0),"^",13)
. I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
. I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
. S LA7X=$P(LA763(0),"^",10)
;
; Other subscripts only store requesting provider
I LA("SUB")?1(1"MI",1"SP",1"CY",1"EM") S LA7X=$P(LA763(0),"^",7)
;
; Send back ordering provider stored in #69.6 if available.
I LA7INTYP=10,$G(LA7PLOBR("OBR-17"))'="" S LA7X=LA7PLOBR("OBR-17")
;
I LA7Y="" S LA7Y=LADFINST
S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$S($G(LA7INTYP)=30:2,$G(LA7NVAF)=1:0,1:1))
;
; Placer Field #1 (remote auto-inst)
; Build from info stored in #69.6
I $G(LA7PLOBR("OBR-18"))'="" D
. K LA7X
. S LA7X=$$UNESC^LA7VHLU3(LA7PLOBR("OBR-18"),LA7PLOBR("FS")_LA7PLOBR("ECH"))
. S OBR(18)=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
;
; Else build "auto instrument" if sending to VA facility
I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
. K LA7X
. S LA7X(1)=LA("AUTO-INST")
. S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
;
; Placer Field #2
I $G(LA7PLOBR("OBR-19"))'="" D
. K LA7X
. S LA7X=$$UNESC^LA7VHLU3(LA7PLOBR("OBR-19"),LA7PLOBR("FS")_LA7PLOBR("ECH"))
. S OBR(19)=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
;
; Else build collecting UID if sending to VA facility
I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D
. K LA7X
. S LA7X(7)=LA("RUID")
. S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
;
; Filler Field #1
; Send file #63 ien info - used by HDR to track patient/specimen
K LA7X
S LA7X(1)=LA("LRDFN"),LA7X(2)=LA("SUB"),LA7X(3)=LA("LRIDT")
S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
;
; Filler Field #2
; Send Accession/test info - used by DSS to track patient/specimen
; LRACC^LRAA^LRAD^LRAN^Accession Area^Area Abbreviation^NLT
K LA7X
S LA7X(1)=$P(LA763(0),"^",6),LA7X(7)=LA7NLT
S LA7Y=LA("HUID",68)
I LA7Y D
. N I
. F I=1,2,3 S LA7X(I+1)=$P(LA7Y,"^",I)
. S LA7X(5)=$P($G(^LRO(68,$P(LA7Y,"^"),0)),"^")
. S LA7X(6)=$P($G(^LRO(68,$P(LA7Y,"^"),0)),"^",11)
S OBR(21)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
K LA7X
;
; Date Report Completed/Report status/Responsible person
; Determine report date and status from 0 node.
S LA7RSDT=$P(LA763(0),"^",3),(LA7PRI,LA7RS)=""
;
; If CYEMSP subscripts then check for corrected report
I LA("SUB")?1(1"SP",1"CY",1"EM") D
. S LA7RSDT=$P(LA763(0),"^",11),LA7PRI=$P(LA763(0),"^",2)
. I LA7RSDT S LA7RS="F"
. I $P(LA763(0),"^",15) S LA7RS="C"
. I $G(LRSB)=1.2,$G(LA7SR) S LA7RSDT=+$G(^LR(LRDFN,LA("SUB"),LRIDT,LRSB,LA7SR,0),"^")
;
; If MI subscript then also check various sections and audit subfile for corrected report
I LA("SUB")="MI" D
. S LA7PRI=$P(LA763(0),"^",4)
. 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)
. S LA7Y=$G(^LR(LRDFN,"MI",LRIDT,LA7X),"^")
. I $P(LA7Y,"^") S LA7RSDT=$P(LA7Y,"^"),LA7RS=$P(LA7Y,"^",2),LA7PRI=$P(LA7Y,"^",$S(LA7X=11:5,1:3))
. I $P(LA763(0),"^",9)=1 S LA7RS="C" Q
. I '$D(^LR(LRDFN,"MI",LRIDT,32)) Q
. S I=0
. F S I=$O(^LR(LRDFN,"MI",LRIDT,32,I)) Q:'I I $P(^(I,0),"^",4)>1,LA7RS="F" S LA7RS="C" Q
;
; Also check for individual test status on "ORUT" node in file #63
I $P(LA7NLT(63),"^",10) S LA7RS=$P(LA7NLT(63),"^",10)
;
; Date Report Completed
I LA7RSDT S OBR(22)=$$OBR22^LA7VOBR(LA7RSDT)
;
; Diagnostic service id
S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
;
; Result status
I LA7RS'="" S OBR(25)=$$OBR25^LA7VOBR(LA7RS)
;
; Parent Result and Parent
I $D(LA7PARNT) D
. S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
. S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
;
; Principle result interpreter
I LA("SUB")?1(1"CY",1"EM",1"MI",1"SP"),LA7PRI'="" S OBR(32)=$$OBR32^LA7VOBR(LA7PRI,LADFINST,LA7FS,LA7ECH)
;
; Assistant result interpreter
I LA("SUB")?1(1"SP",1"EM"),$P(LA763(0),"^",4) S OBR(33)=$$OBR33^LA7VOBR($P(LA763(0),"^",4),LADFINST,LA7FS,LA7ECH)
;
; Technician
I LA("SUB")?1(1"CY",1"EM"),$P(LA763(0),"^",4) S OBR(34)=$$OBR34^LA7VOBR($P(LA763(0),"^",4),LADFINST,LA7FS,LA7ECH)
;
; Typist - VistA stores as free text
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)
;
; Procedure code - use Order NLT code
S OBR(44)=$$OBR44^LA7VOBR(LA7NLT,LA7FS,LA7ECH)
;
D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
D FILESEG^LA7VHLU(GBL,.LA7DATA)
;
; Check for flag to only build message but do not file
I '$G(LA7NOMSG) D
. D FILE6249^LA7VHLU(LA76249,.LA7DATA)
. I LA("HUID")'="" D
. . D SETID^LA7VHLU1(LA76249,LA7ID,LA("HUID"),0)
. . D SETID^LA7VHLU1(LA76249,"",LA("HUID"),0)
. I LA("RUID")'="" D
. . D SETID^LA7VHLU1(LA76249,LA7ID,LA("RUID"),0)
. . D SETID^LA7VHLU1(LA76249,"",LA("RUID"),0)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VORUB 8964 printed Oct 16, 2024@17:41:56 Page 2
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
+2 ;
+3 QUIT
+4 ;
+5 ;
OBR ;Observation Request segment for Lab Order
+1 ;
+2 NEW LA761,LA762,LA7DATA,LA7PLOBR,LA7PRI,LA7RSDT,LA7SAC,LA7SNM,LA7X,LA7Y,LADFINST,OBR,X,Y
+3 ;
+4 ; Retrieve placer's OBR information stored in #69.6
+5 DO RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
+6 ;
+7 ; Retrieve "ORUT" node for this NLT from file #63
+8 SET LA7NLT(63)=""
+9 IF LA7NLT'=""
Begin DoDot:1
+10 SET LA7X=$ORDER(^LR(LRDFN,LRSS,LRIDT,"ORUT","B",LA7NLT,0))
+11 IF LA7X>0
SET LA7NLT(63)=$GET(^LR(LRDFN,LRSS,LRIDT,"ORUT",LA7X,0))
End DoDot:1
+12 ;
+13 ; Default institution from Kernel
+14 SET LADFINST=+$$KSP^XUPARAM("INST")
+15 ;
+16 ; Retreive accession info used below - accession area^accession date^accession number
+17 SET LA7Y=$$CHECKUID^LRWU4(LA("HUID"))
+18 IF LA7Y
SET LA("HUID",68)=$PIECE(LA7Y,"^",2,4)
+19 IF '$TEST
SET LA("HUID",68)=""
+20 ;
+21 ; Initialize OBR segment
+22 SET OBR(0)="OBR"
+23 SET OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
+24 ;
+25 ; Remote UID
+26 KILL LA7X
+27 MERGE LA7X=LA("RUID")
+28 SET OBR(2)=$$OBR2^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+29 ;
+30 ; Host UID
+31 KILL LA7X
+32 MERGE LA7X=LA("HUID")
+33 SET OBR(3)=$$OBR3^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+34 ;
+35 ; Universal service ID, build from info stored in #69.6
+36 KILL LA7X
+37 SET LA7X=""
+38 IF $GET(LA7PLOBR("OBR-4"))'=""
SET OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
+39 IF '$TEST
SET OBR(4)=$$OBR4^LA7VOBR(LA7NLT,$PIECE(LA7NLT(63),"^",13),LA7X,LA7FS,LA7ECH)
+40 ;
+41 ; Collection D/T - only send date if d/t is inexact (2nd piece)
+42 KILL LA7X
+43 SET LA7X=$PIECE(LA763(0),"^")
if $PIECE(LA763(0),"^",2)
SET LA7X=$PIECE(LA7X,".")
+44 SET OBR(7)=$$OBR7^LA7VOBR(LA7X)
+45 ;
+46 ; Specimen action code from order type in file #63 "ORUT" node
+47 ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
+48 SET LA7SAC=""
+49 IF $PIECE(LA7NLT(63),"^",5)
SET LA7SAC=$$GET1^DIQ(64.061,$PIECE(LA7NLT(63),"^",5)_",",2)
+50 IF $GET(LA7INTYP)=10
Begin DoDot:1
+51 IF LA7SAC=""
IF $GET(LA7PLOBR("OBR-4"))=""
SET LA7SAC="A"
+52 IF LA7NVAF=1
IF LA7SAC'?1(1"G",1"R",1"A")
SET LA7SAC=""
End DoDot:1
+53 IF LA7SAC'=""
SET OBR(11)=$$OBR11^LA7VOBR(LA7SAC)
+54 ;
+55 ; Infection Warning
+56 SET OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
+57 ;
+58 ; Lab Arrival Time
+59 ; "CH" subscript does not store lab arrival time - attempt to retrieve from file #68.
+60 ; Other subscripts do store lab arrival time (date/time received).
+61 IF LA("SUB")?1(1"MI",1"SP",1"CY",1"EM")
SET OBR(14)=$$OBR14^LA7VOBR($PIECE(LA763(0),"^",10))
+62 IF LA("SUB")="CH"
IF LA("HUID",68)
Begin DoDot:1
+63 SET LA7X=$GET(^LRO(68,$PIECE(LA("HUID",68),"^"),1,$PIECE(LA("HUID",68),"^",2),1,$PIECE(LA("HUID",68),"^",3),3))
+64 IF $PIECE(LA7X,"^",3)
SET OBR(14)=$$OBR14^LA7VOBR($PIECE(LA7X,"^",3))
End DoDot:1
+65 ;
+66 ; Specimen source
+67 SET (LA761,LA762,LA7Y)=""
SET LA7SNM=1
+68 IF LA("SUB")?1(1"CH",1"MI")
Begin DoDot:1
+69 SET LA761=$PIECE(LA763(0),U,5)
+70 IF LA761=""
DO CREATE^LA7LOG(27)
+71 IF LA("SUB")="MI"
SET LA762=$PIECE(LA763(0),U,11)
End DoDot:1
+72 ;
+73 ; If multiple different specimens then OBR-15 always indicates XXX for AP subscripts - specimen is communicated in OBX segments.
+74 IF LA("SUB")?1(1"SP",1"CY",1"EM")
Begin DoDot:1
+75 SET LA7I=0
+76 FOR
SET LA7I=$ORDER(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),.1,LA7I))
if 'LA7I
QUIT
Begin DoDot:2
+77 SET LA7X=$PIECE(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),.1,LA7I,0),"^",6)
+78 IF 'LA761
IF LA7X
SET LA761=LA7X
+79 IF LA761
IF LA7X
IF (LA761'=LA7X)
SET (LA761,LA7I)=0
End DoDot:2
if 'LA7I
QUIT
+80 SET LA762=$PIECE(LA7NLT(63),"^",9)
End DoDot:1
+81 ;
+82 IF LA7NVAF=1
SET LA7SNM=2
+83 ;
+84 SET OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,LA7Y,LA7FS,LA7ECH,"",LA7SNM)
+85 ;
+86 ; If LEDI reflex test and not DoD/CHCS interface
+87 ; then check original ordered test for placer field 1/2 (OBR-18/19) and ordering provider (OBR-17)
+88 IF $GET(LA7INTYP)=10
IF LA7SAC="G"
IF LA7NVAF'=1
IF $GET(LA7PLOBR("OBR-18"))=""
IF $GET(LA7PLOBR("OBR-19"))=""
Begin DoDot:1
+89 NEW LA7REFLEXNLT,LA7REFLEXPARENT
+90 SET LA7REFLEXNLT=$PIECE(LA7NLT(63),"^",15)
+91 IF LA7REFLEXNLT=""
QUIT
+92 DO RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA7REFLEXNLT,.LA7REFLEXPARENT)
+93 FOR I="OBR-18","OBR-19"
SET LA7PLOBR(I)=$GET(LA7REFLEXPARENT(I))
+94 IF $GET(LA7PLOBR("OBR-17"))=""
SET LA7PLOBR("OBR-17")=$GET(LA7REFLEXPARENT("OBR-17"))
End DoDot:1
+95 ;
+96 ; Ordering provider
+97 KILL LA7X,LA7Y
+98 SET (LA7X,LA7Y)=""
+99 ; "CH" subscript stores requesting provider and requesting div/location.
+100 IF LA("SUB")="CH"
Begin DoDot:1
+101 NEW LA7J
+102 SET LA7J=$PIECE(LA763(0),"^",13)
+103 IF $PIECE(LA7J,";",2)="SC("
SET LA7Y=$$GET1^DIQ(44,$PIECE(LA7J,";")_",",3,"I")
+104 IF $PIECE(LA7J,";",2)="DIC(4,"
SET LA7Y=$PIECE(LA7J,";")
+105 SET LA7X=$PIECE(LA763(0),"^",10)
End DoDot:1
+106 ;
+107 ; Other subscripts only store requesting provider
+108 IF LA("SUB")?1(1"MI",1"SP",1"CY",1"EM")
SET LA7X=$PIECE(LA763(0),"^",7)
+109 ;
+110 ; Send back ordering provider stored in #69.6 if available.
+111 IF LA7INTYP=10
IF $GET(LA7PLOBR("OBR-17"))'=""
SET LA7X=LA7PLOBR("OBR-17")
+112 ;
+113 IF LA7Y=""
SET LA7Y=LADFINST
+114 SET OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$SELECT($GET(LA7INTYP)=30:2,$GET(LA7NVAF)=1:0,1:1))
+115 ;
+116 ; Placer Field #1 (remote auto-inst)
+117 ; Build from info stored in #69.6
+118 IF $GET(LA7PLOBR("OBR-18"))'=""
Begin DoDot:1
+119 KILL LA7X
+120 SET LA7X=$$UNESC^LA7VHLU3(LA7PLOBR("OBR-18"),LA7PLOBR("FS")_LA7PLOBR("ECH"))
+121 SET OBR(18)=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
End DoDot:1
+122 ;
+123 ; Else build "auto instrument" if sending to VA facility
+124 IF $GET(LA7PLOBR("OBR-18"))=""
IF 'LA7NVAF
Begin DoDot:1
+125 KILL LA7X
+126 SET LA7X(1)=LA("AUTO-INST")
+127 SET OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
End DoDot:1
+128 ;
+129 ; Placer Field #2
+130 IF $GET(LA7PLOBR("OBR-19"))'=""
Begin DoDot:1
+131 KILL LA7X
+132 SET LA7X=$$UNESC^LA7VHLU3(LA7PLOBR("OBR-19"),LA7PLOBR("FS")_LA7PLOBR("ECH"))
+133 SET OBR(19)=$$CHKDATA^LA7VHLU3(LA7X,LA7FS_LA7ECH)
End DoDot:1
+134 ;
+135 ; Else build collecting UID if sending to VA facility
+136 IF $GET(LA7PLOBR("OBR-19"))=""
IF 'LA7NVAF
IF LA("RUID")'=""
Begin DoDot:1
+137 KILL LA7X
+138 SET LA7X(7)=LA("RUID")
+139 SET OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
End DoDot:1
+140 ;
+141 ; Filler Field #1
+142 ; Send file #63 ien info - used by HDR to track patient/specimen
+143 KILL LA7X
+144 SET LA7X(1)=LA("LRDFN")
SET LA7X(2)=LA("SUB")
SET LA7X(3)=LA("LRIDT")
+145 SET OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+146 ;
+147 ; Filler Field #2
+148 ; Send Accession/test info - used by DSS to track patient/specimen
+149 ; LRACC^LRAA^LRAD^LRAN^Accession Area^Area Abbreviation^NLT
+150 KILL LA7X
+151 SET LA7X(1)=$PIECE(LA763(0),"^",6)
SET LA7X(7)=LA7NLT
+152 SET LA7Y=LA("HUID",68)
+153 IF LA7Y
Begin DoDot:1
+154 NEW I
+155 FOR I=1,2,3
SET LA7X(I+1)=$PIECE(LA7Y,"^",I)
+156 SET LA7X(5)=$PIECE($GET(^LRO(68,$PIECE(LA7Y,"^"),0)),"^")
+157 SET LA7X(6)=$PIECE($GET(^LRO(68,$PIECE(LA7Y,"^"),0)),"^",11)
End DoDot:1
+158 SET OBR(21)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+159 KILL LA7X
+160 ;
+161 ; Date Report Completed/Report status/Responsible person
+162 ; Determine report date and status from 0 node.
+163 SET LA7RSDT=$PIECE(LA763(0),"^",3)
SET (LA7PRI,LA7RS)=""
+164 ;
+165 ; If CYEMSP subscripts then check for corrected report
+166 IF LA("SUB")?1(1"SP",1"CY",1"EM")
Begin DoDot:1
+167 SET LA7RSDT=$PIECE(LA763(0),"^",11)
SET LA7PRI=$PIECE(LA763(0),"^",2)
+168 IF LA7RSDT
SET LA7RS="F"
+169 IF $PIECE(LA763(0),"^",15)
SET LA7RS="C"
+170 IF $GET(LRSB)=1.2
IF $GET(LA7SR)
SET LA7RSDT=+$GET(^LR(LRDFN,LA("SUB"),LRIDT,LRSB,LA7SR,0),"^")
End DoDot:1
+171 ;
+172 ; If MI subscript then also check various sections and audit subfile for corrected report
+173 IF LA("SUB")="MI"
Begin DoDot:1
+174 SET LA7PRI=$PIECE(LA763(0),"^",4)
+175 SET LA7X=$SELECT(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)
+176 SET LA7Y=$GET(^LR(LRDFN,"MI",LRIDT,LA7X),"^")
+177 IF $PIECE(LA7Y,"^")
SET LA7RSDT=$PIECE(LA7Y,"^")
SET LA7RS=$PIECE(LA7Y,"^",2)
SET LA7PRI=$PIECE(LA7Y,"^",$SELECT(LA7X=11:5,1:3))
+178 IF $PIECE(LA763(0),"^",9)=1
SET LA7RS="C"
QUIT
+179 IF '$DATA(^LR(LRDFN,"MI",LRIDT,32))
QUIT
+180 SET I=0
+181 FOR
SET I=$ORDER(^LR(LRDFN,"MI",LRIDT,32,I))
if 'I
QUIT
IF $PIECE(^(I,0),"^",4)>1
IF LA7RS="F"
SET LA7RS="C"
QUIT
End DoDot:1
+182 ;
+183 ; Also check for individual test status on "ORUT" node in file #63
+184 IF $PIECE(LA7NLT(63),"^",10)
SET LA7RS=$PIECE(LA7NLT(63),"^",10)
+185 ;
+186 ; Date Report Completed
+187 IF LA7RSDT
SET OBR(22)=$$OBR22^LA7VOBR(LA7RSDT)
+188 ;
+189 ; Diagnostic service id
+190 SET OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$GET(LRSB))
+191 ;
+192 ; Result status
+193 IF LA7RS'=""
SET OBR(25)=$$OBR25^LA7VOBR(LA7RS)
+194 ;
+195 ; Parent Result and Parent
+196 IF $DATA(LA7PARNT)
Begin DoDot:1
+197 SET OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
+198 SET OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
End DoDot:1
+199 ;
+200 ; Principle result interpreter
+201 IF LA("SUB")?1(1"CY",1"EM",1"MI",1"SP")
IF LA7PRI'=""
SET OBR(32)=$$OBR32^LA7VOBR(LA7PRI,LADFINST,LA7FS,LA7ECH)
+202 ;
+203 ; Assistant result interpreter
+204 IF LA("SUB")?1(1"SP",1"EM")
IF $PIECE(LA763(0),"^",4)
SET OBR(33)=$$OBR33^LA7VOBR($PIECE(LA763(0),"^",4),LADFINST,LA7FS,LA7ECH)
+205 ;
+206 ; Technician
+207 IF LA("SUB")?1(1"CY",1"EM")
IF $PIECE(LA763(0),"^",4)
SET OBR(34)=$$OBR34^LA7VOBR($PIECE(LA763(0),"^",4),LADFINST,LA7FS,LA7ECH)
+208 ;
+209 ; Typist - VistA stores as free text
+210 IF LA("SUB")?1(1"SP",1"CY",1"EM")
IF $PIECE(LA763(0),"^",9)'=""
SET OBR(35)=$$OBR35^LA7VOBR($PIECE(LA763(0),"^",9),LADFINST,LA7FS,LA7ECH)
+211 ;
+212 ; Procedure code - use Order NLT code
+213 SET OBR(44)=$$OBR44^LA7VOBR(LA7NLT,LA7FS,LA7ECH)
+214 ;
+215 DO BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
+216 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+217 ;
+218 ; Check for flag to only build message but do not file
+219 IF '$GET(LA7NOMSG)
Begin DoDot:1
+220 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+221 IF LA("HUID")'=""
Begin DoDot:2
+222 DO SETID^LA7VHLU1(LA76249,LA7ID,LA("HUID"),0)
+223 DO SETID^LA7VHLU1(LA76249,"",LA("HUID"),0)
End DoDot:2
+224 IF LA("RUID")'=""
Begin DoDot:2
+225 DO SETID^LA7VHLU1(LA76249,LA7ID,LA("RUID"),0)
+226 DO SETID^LA7VHLU1(LA76249,"",LA("RUID"),0)
End DoDot:2
End DoDot:1
+227 ;
+228 QUIT
