LA7CORUB ;VA/DALOI/JMC - Builder of HL7 Lab Results cont'd ; 22-Oct-2013 09:22 ; MAW
;;5.2;AUTOMATED LAB INSTRUMENTS;**68,1033**;NOV 01, 1997
;
Q
;
;
OBR ;Observation Request segment for Lab Order
;
N LA761,LA762,LA7DATA,LA7PLOBR,LA7RS,LA7RSDT,LA7SNM,LA7X,LA7Y,LADFINST,OBR
;
; 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
M LA7X=LA("RUID")
S OBR(2)=$$OBR2^LA7COBR(.LA7X,LA7FS,LA7ECH)
;
; Host UID
K LA7X
M LA7X=LA("HUID")
S OBR(3)=$$OBR3^LA7COBR(.LA7X,LA7FS,LA7ECH)
S $P(OBR(3),$E(LA7ECH))=$S(LA7OBRSN>1:LA7UID_$$SUFFIX(LA7OBRSN),1:LA7UID)
I $G(LA7INPT),$G(LA7ADDPN)="" S LA7ADDPN=$G(OBR(3))
;
;MU2 lets find the accession IEN
N AUID,AX,AI,AD,AA
S AUID=$E($P(OBR(3),$E(LA7ECH)),1,10)
S AX=$Q(^LRO(68,"C",AUID))
S AA=$QS(AX,4)
S AD=$QS(AX,5)
S AI=$QS(AX,6)
K LA760,LA760I
;I $G(LRSS)="MI" D ;MU2 find lab test based on Result NLT Code
;. S LA760=$O(^LAB(60,"AE",LA7NLT,0))
I '$G(LA760) S LA760=$O(^LRO(68,AA,1,AD,1,AI,4,"B",0)) ; this needs to changed if mult obr will have to debug
S LA760I=$O(^LRO(68,AA,1,AD,1,AI,4,"B",0)) ; this needs to changed if mult obr will have to debug ; 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^LA7COBR(LA7NLT,"",LA7X,LA7FS,LA7ECH)
E S OBR(4)=$$OBR4^LA7COBR(LA7NLT,$G(LA760),LA7X,LA7FS,LA7ECH) ;MU2
;
; Collection D/T - only send date if d/t is inexact (2nd piece)
K LA7X,LA7CLDT
S LA7X=$P(LA763(0),"^") S:$P(LA763(0),"^",2) LA7X=$P(LA7X,".")
S LA7CLDT=LA7X
S OBR(7)=$$OBR7^LA7COBR(LA7X)
S OBR(8)=$$OBR8^LA7COBR(LA7X)
;
; Specimen action code
; If no OBR from PENDING ORDER file (#69.6) then assume added test.
;I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A")
I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("L") ;mu2
I $G(OBR(11))="" S OBR(11)="L"
I $G(LA7INPT),$G(LRSS)="MI",$G(LA7OBRSN)>1 S OBR(11)="G" ;mu2 micro inpatient MU2
I $G(LA7INPT),$G(LA7ADDON),$G(LA7OBRSN)>1 S OBR(11)="G" ;mu2 micro inpatient MU2
;
; Infection Warning
S OBR(12)=$$OBR12^LA7COBR(LRDFN,LA7FS,LA7ECH)
;
N ORD,ORDI,OD,OI,OII,RCI,SNM
S ORD=$P($G(^LRO(68,AA,1,AD,1,AI,.1)),U)
S ORDI=$Q(^LRO(69,"C",ORD))
S OD=$QS(ORDI,4)
S OI=$QS(ORDI,5)
S OII=$O(^LRO(69,OD,1,OI,2,"B",LA760I,0))
S RCI=$P($G(^LRO(69,OD,1,OI,2,OII,9999999)),U)
S SNM=$P($G(^LRO(69,OD,1,OI,2,OII,9999999)),U,2)
S OBR(13)=$$OBR13^LA7COBR(RCI,SNM,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")?1(1"SP",1"CY",1"EM") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
;removed below per MU2
;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,LA7SNM)=""
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)
I LA7NVAF=1,LA("SUB")'="CH" S LA7SNM=1
;removed below per MU2
;S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH,"",LA7SNM)
;
; Ordering provider
K LA7X
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)
;
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))
;ihs/cmi/maw mu2
S OBR(16)=$$ORC12^LA7CORC(LA7OP,LADFINST,LA7FS,LA7ECH,2)
S $P(OBR(16),$E(LA7ECH),9)="NPI"_$E(LA7ECH,4)_"2.16.840.1.113883.4.6"_$E(LA7ECH,4)_"ISO"
S $P(OBR(16),$E(LA7ECH),10)="L"
S $P(OBR(16),$E(LA7ECH),13)="NPI"
S $P(OBR(16),$E(LA7ECH),14)=LA7FAC_$E(LA7ECH,4)_"2.16.840.1.113883.3.72.5.26"_$E(LA7ECH,4)_"ISO"
S $P(OBR(16),$E(LA7ECH),21)=$P(OBR(16),$E(LA7ECH),6)
I $G(LA7INPT) S $P(OBR(16),$E(LA7ECH),7)="" ;mu2 inpatient
;
S OBR(17)=$$OBR17^LA7COBR(LA7FS,LA7ECH) ;MU2 order call back number
; Placer Field #1 (remote auto-inst)
; Build from info stored in #69.6
I $G(LA7PLOBR("OBR-18"))'="" D
. S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH)
; Else build "auto instrument" if sending to VA facility
I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
. N LA7X
. S LA7X(1)=LA("AUTO-INST")
. S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
;
; Placer Field #2
I $G(LA7PLOBR("OBR-19"))'="" S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),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,LAY7
;
; 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.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,"^",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)
I $P(LA7RSDT,".",2)="" S LA7RSDT=LA7RSDT_".000101"
I $G(LA7RSDT)]"" S OBR(22)=$$OBR22^LA7COBR(LA7RSDT) ;status change MU2
I '$G(OBR(22)) S OBR(22)=$$OBR22^LA7COBR($G(OBR(7))) ;mu2
I $G(OBR(22))="-1" S OBR(22)=$G(OBR(7)) ;mu2
;
; Diagnostic service id
S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
;
; Result status
I LRSS="CH",$G(LA7RSDT)]"" S LA7RS="F"
I LA7RS'="" S OBR(25)=$$OBR25^LA7VOBR(LA7RS)
I LRSS="CH",$P($G(LA7RSDT),".")="",$G(LA7INPT) S OBR(25)="X",LA7REJ=1
I $G(OBR(25))="" S OBR(25)="P" ;MU2
;
; Result copies to
N LA7OBR28
S LA7OBR28=$P($G(^LR(LRDFN,"CH",LRIDT,"IHS")),"!",2)
I $G(LA7INPT) S OBR(28)=$$OBR28^LA7COBR(LA7OBR28,LA7ECH)
;
; Parent Result and Parent
I $G(LA7INPT),$G(LA7ADDON),$G(LA7ADDPN)]"" D ;mu2 inpatient
. Q:'$G(LA7OBRSN)
. S LA7PARNT(1)=LA7ADDPN
. S LA7PARNT(2)=1
. S LA7PARNT(3)=""
I $D(LA7PARNT) D
. I $G(LA7INPT),$G(LA7ADDON),$G(LA7OBRSN)=1 Q
. S OBR(26)=$$OBR26^LA7COBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
. S OBR(29)=$$OBR29^LA7COBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
;
;-- MU2 reason for study
S OBR(31)=$$OBR31^LA7COBR(OD,OI,OII,LA7FS,LA7ECH)
I $G(LA7INPT),$G(LRSS)="MI" D
. S OBR(13)=OBR(31) ;inpatient mu2 micro wants ICD code
. S $P(OBR(13),$E(LA7ECH),9)=$P(OBR(13),$E(LA7ECH),2)
;
; Principle result interpreter
I LA("SUB")?1(1"MI",1"SP",1"CY",1"EM") D
. I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4)
. E S LA7X=$P(LA763(0),"^",2)
. S OBR(32)=$$OBR32^LA7COBR(LA7X,LADFINST,LA7FS,LA7ECH)
;
I $G(OBR(32))="" D
. S LA7X=$P($G(^BLRSITE(DUZ(2),3)),U,8)
. Q:'LA7X
. S OBR(32)=$$OBR32^LA7COBR(LA7X,DUZ(2),LA7FS,LA7ECH)
. S OBR(32)=$TR(OBR(32),$E(LA7ECH),"") ;MU2
. S $P(OBR(32),$E(LA7ECH,4),9)="NIST_Sending App"
. S $P(OBR(32),$E(LA7ECH,4),10)="2.16.840.1.113883.3.72.5.21"
. S $P(OBR(32),$E(LA7ECH,4),11)="ISO"
; 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)
N LA7OBR49
S LA7OBR49=$P($G(^LR(LRDFN,"CH",LRIDT,"IHS")),"!",2)
I $G(LA7INPT) S OBR(49)=$$OBR49^LA7COBR(LA7OBR49,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 FILE6249^LA7VHLU(LA76249,.LA7DATA)
;
Q
;
SUFFIX(CNT) ;-- return uid suffix
I CNT=2 Q "A"
I CNT=3 Q "B"
I CNT=4 Q "C"
I CNT=5 Q "D"
I CNT=6 Q "E"
I CNT=7 Q "F"
I CNT=8 Q "G"
I CNT=9 Q "H"
I CNT=10 Q "I"
I CNT=11 Q "J"
I CNT=12 Q "K"
I CNT=13 Q "L"
I CNT=14 Q "M"
I CNT=15 Q "N"
I CNT=16 Q "O"
I CNT=17 Q "P"
I CNT=18 Q "Q"
I CNT=19 Q "R"
I CNT=20 Q "S"
I CNT=21 Q "T"
I CNT=22 Q "U"
I CNT=23 Q "V"
I CNT=24 Q "W"
I CNT=25 Q "X"
I CNT=26 Q "Y"
I CNT=27 Q "Z"
Q
;
LA7CORUB ;VA/DALOI/JMC - Builder of HL7 Lab Results cont'd ; 22-Oct-2013 09:22 ; MAW
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**68,1033**;NOV 01, 1997
+2 ;
+3 QUIT
+4 ;
+5 ;
OBR ;Observation Request segment for Lab Order
+1 ;
+2 NEW LA761,LA762,LA7DATA,LA7PLOBR,LA7RS,LA7RSDT,LA7SNM,LA7X,LA7Y,LADFINST,OBR
+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 MERGE LA7X=LA("RUID")
+27 SET OBR(2)=$$OBR2^LA7COBR(.LA7X,LA7FS,LA7ECH)
+28 ;
+29 ; Host UID
+30 KILL LA7X
+31 MERGE LA7X=LA("HUID")
+32 SET OBR(3)=$$OBR3^LA7COBR(.LA7X,LA7FS,LA7ECH)
+33 SET $PIECE(OBR(3),$EXTRACT(LA7ECH))=$SELECT(LA7OBRSN>1:LA7UID_$$SUFFIX(LA7OBRSN),1:LA7UID)
+34 IF $GET(LA7INPT)
IF $GET(LA7ADDPN)=""
SET LA7ADDPN=$GET(OBR(3))
+35 ;
+36 ;MU2 lets find the accession IEN
+37 NEW AUID,AX,AI,AD,AA
+38 SET AUID=$EXTRACT($PIECE(OBR(3),$EXTRACT(LA7ECH)),1,10)
+39 SET AX=$QUERY(^LRO(68,"C",AUID))
+40 SET AA=$QSUBSCRIPT(AX,4)
+41 SET AD=$QSUBSCRIPT(AX,5)
+42 SET AI=$QSUBSCRIPT(AX,6)
+43 KILL LA760,LA760I
+44 ;I $G(LRSS)="MI" D ;MU2 find lab test based on Result NLT Code
+45 ;. S LA760=$O(^LAB(60,"AE",LA7NLT,0))
+46 ; this needs to changed if mult obr will have to debug
IF '$GET(LA760)
SET LA760=$ORDER(^LRO(68,AA,1,AD,1,AI,4,"B",0))
+47 ; this needs to changed if mult obr will have to debug ; Universal service ID, build from info stored in #69.6
SET LA760I=$ORDER(^LRO(68,AA,1,AD,1,AI,4,"B",0))
+48 KILL LA7X
+49 SET LA7X=""
+50 IF $GET(LA7PLOBR("OBR-4"))'=""
SET OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
+51 ;E S OBR(4)=$$OBR4^LA7COBR(LA7NLT,"",LA7X,LA7FS,LA7ECH)
+52 ;MU2
IF '$TEST
SET OBR(4)=$$OBR4^LA7COBR(LA7NLT,$GET(LA760),LA7X,LA7FS,LA7ECH)
+53 ;
+54 ; Collection D/T - only send date if d/t is inexact (2nd piece)
+55 KILL LA7X,LA7CLDT
+56 SET LA7X=$PIECE(LA763(0),"^")
IF $PIECE(LA763(0),"^",2)
SET LA7X=$PIECE(LA7X,".")
+57 SET LA7CLDT=LA7X
+58 SET OBR(7)=$$OBR7^LA7COBR(LA7X)
+59 SET OBR(8)=$$OBR8^LA7COBR(LA7X)
+60 ;
+61 ; Specimen action code
+62 ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
+63 ;I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A")
+64 ;mu2
IF $GET(LA7INTYP)=10
IF $GET(LA7PLOBR("OBR-4"))=""
SET OBR(11)=$$OBR11^LA7VOBR("L")
+65 IF $GET(OBR(11))=""
SET OBR(11)="L"
+66 ;mu2 micro inpatient MU2
IF $GET(LA7INPT)
IF $GET(LRSS)="MI"
IF $GET(LA7OBRSN)>1
SET OBR(11)="G"
+67 ;mu2 micro inpatient MU2
IF $GET(LA7INPT)
IF $GET(LA7ADDON)
IF $GET(LA7OBRSN)>1
SET OBR(11)="G"
+68 ;
+69 ; Infection Warning
+70 SET OBR(12)=$$OBR12^LA7COBR(LRDFN,LA7FS,LA7ECH)
+71 ;
+72 NEW ORD,ORDI,OD,OI,OII,RCI,SNM
+73 SET ORD=$PIECE($GET(^LRO(68,AA,1,AD,1,AI,.1)),U)
+74 SET ORDI=$QUERY(^LRO(69,"C",ORD))
+75 SET OD=$QSUBSCRIPT(ORDI,4)
+76 SET OI=$QSUBSCRIPT(ORDI,5)
+77 SET OII=$ORDER(^LRO(69,OD,1,OI,2,"B",LA760I,0))
+78 SET RCI=$PIECE($GET(^LRO(69,OD,1,OI,2,OII,9999999)),U)
+79 SET SNM=$PIECE($GET(^LRO(69,OD,1,OI,2,OII,9999999)),U,2)
+80 SET OBR(13)=$$OBR13^LA7COBR(RCI,SNM,LA7FS,LA7ECH)
+81 ; Lab Arrival Time
+82 ; "CH" subscript does not store lab arrival time - attempt to retrieve from file #68.
+83 ; Other subscripts do store lab arrival time (date/time received).
+84 ;I LA("SUB")?1(1"MI",1"SP",1"CY",1"EM") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
+85 IF LA("SUB")?1(1"SP",1"CY",1"EM")
SET OBR(14)=$$OBR14^LA7VOBR($PIECE(LA763(0),"^",10))
+86 ;removed below per MU2
+87 ;I LA("SUB")="CH",LA("HUID",68) D
+88 ;. S LA7X=$G(^LRO(68,$P(LA("HUID",68),"^"),1,$P(LA("HUID",68),"^",2),1,$P(LA("HUID",68),"^",3),3))
+89 ;. I $P(LA7X,"^",3) S OBR(14)=$$OBR14^LA7VOBR($P(LA7X,"^",3))
+90 ;
+91 ; Specimen source
+92 SET (LA761,LA762,LA7SNM)=""
+93 IF LA("SUB")?1(1"CH",1"MI")
Begin DoDot:1
+94 SET LA761=$PIECE(LA763(0),U,5)
+95 IF LA761=""
DO CREATE^LA7LOG(27)
+96 IF LA("SUB")="MI"
SET LA762=$PIECE(LA763(0),U,11)
End DoDot:1
+97 IF LA7NVAF=1
IF LA("SUB")'="CH"
SET LA7SNM=1
+98 ;removed below per MU2
+99 ;S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH,"",LA7SNM)
+100 ;
+101 ; Ordering provider
+102 KILL LA7X
+103 SET (LA7X,LA7Y)=""
+104 ; "CH" subscript stores requesting provider and requesting div/location.
+105 IF LA("SUB")="CH"
Begin DoDot:1
+106 NEW LA7J
+107 SET LA7J=$PIECE(LA763(0),"^",13)
+108 IF $PIECE(LA7J,";",2)="SC("
SET LA7Y=$$GET1^DIQ(44,$PIECE(LA7J,";")_",",3,"I")
+109 IF $PIECE(LA7J,";",2)="DIC(4,"
SET LA7Y=$PIECE(LA7J,";")
+110 SET LA7X=$PIECE(LA763(0),"^",10)
End DoDot:1
+111 ;
+112 ; Other subscripts only store requesting provider
+113 IF LA("SUB")?1(1"MI",1"SP",1"CY",1"EM")
SET LA7X=$PIECE(LA763(0),"^",7)
+114 ;
+115 IF LA7Y=""
SET LA7Y=LADFINST
+116 ;S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$S($G(LA7INTYP)=30:2,$G(LA7NVAF)=1:0,1:1))
+117 ;ihs/cmi/maw mu2
+118 SET OBR(16)=$$ORC12^LA7CORC(LA7OP,LADFINST,LA7FS,LA7ECH,2)
+119 SET $PIECE(OBR(16),$EXTRACT(LA7ECH),9)="NPI"_$EXTRACT(LA7ECH,4)_"2.16.840.1.113883.4.6"_$EXTRACT(LA7ECH,4)_"ISO"
+120 SET $PIECE(OBR(16),$EXTRACT(LA7ECH),10)="L"
+121 SET $PIECE(OBR(16),$EXTRACT(LA7ECH),13)="NPI"
+122 SET $PIECE(OBR(16),$EXTRACT(LA7ECH),14)=LA7FAC_$EXTRACT(LA7ECH,4)_"2.16.840.1.113883.3.72.5.26"_$EXTRACT(LA7ECH,4)_"ISO"
+123 SET $PIECE(OBR(16),$EXTRACT(LA7ECH),21)=$PIECE(OBR(16),$EXTRACT(LA7ECH),6)
+124 ;mu2 inpatient
IF $GET(LA7INPT)
SET $PIECE(OBR(16),$EXTRACT(LA7ECH),7)=""
+125 ;
+126 ;MU2 order call back number
SET OBR(17)=$$OBR17^LA7COBR(LA7FS,LA7ECH)
+127 ; Placer Field #1 (remote auto-inst)
+128 ; Build from info stored in #69.6
+129 IF $GET(LA7PLOBR("OBR-18"))'=""
Begin DoDot:1
+130 SET OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH)
End DoDot:1
+131 ; Else build "auto instrument" if sending to VA facility
+132 IF $GET(LA7PLOBR("OBR-18"))=""
IF 'LA7NVAF
Begin DoDot:1
+133 NEW LA7X
+134 SET LA7X(1)=LA("AUTO-INST")
+135 SET OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
End DoDot:1
+136 ;
+137 ; Placer Field #2
+138 IF $GET(LA7PLOBR("OBR-19"))'=""
SET OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH)
+139 ; Else build collecting UID if sending to VA facility
+140 IF $GET(LA7PLOBR("OBR-19"))=""
IF 'LA7NVAF
IF LA("RUID")'=""
Begin DoDot:1
+141 KILL LA7X
+142 SET LA7X(7)=LA("RUID")
+143 SET OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
End DoDot:1
+144 ;
+145 ; Filler Field #1
+146 ; Send file #63 ien info - used by HDR to track patient/specimen
+147 KILL LA7X
+148 SET LA7X(1)=LA("LRDFN")
SET LA7X(2)=LA("SUB")
SET LA7X(3)=LA("LRIDT")
+149 SET OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+150 ;
+151 ; Filler Field #2
+152 ; Send Accession/test info - used by DSS to track patient/specimen
+153 ; LRACC^LRAA^LRAD^LRAN^Accession Area^Area Abbreviation^NLT
+154 KILL LA7X
+155 SET LA7X(1)=$PIECE(LA763(0),"^",6)
SET LA7X(7)=LA7NLT
+156 SET LA7Y=LA("HUID",68)
+157 IF LA7Y
Begin DoDot:1
+158 NEW I
+159 FOR I=1,2,3
SET LA7X(I+1)=$PIECE(LA7Y,"^",I)
+160 SET LA7X(5)=$PIECE($GET(^LRO(68,$PIECE(LA7Y,"^"),0)),"^")
+161 SET LA7X(6)=$PIECE($GET(^LRO(68,$PIECE(LA7Y,"^"),0)),"^",11)
End DoDot:1
+162 SET OBR(21)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+163 KILL LA7X,LAY7
+164 ;
+165 ; Date Report Completed/Report status/Responsible person
+166 ; Determine report date and status from 0 node.
+167 SET LA7RSDT=$PIECE(LA763(0),"^",3)
SET (LA7PRI,LA7RS)=""
+168 ;
+169 ; If CYEMSP subscripts then check for corrected report
+170 IF LA("SUB")?1(1"SP",1"CY",1"EM")
Begin DoDot:1
+171 SET LA7RSDT=$PIECE(LA763(0),"^",11)
SET LA7PRI=$PIECE(LA763(0),"^",2)
+172 IF LA7RSDT
SET LA7RS="F"
+173 IF $PIECE(LA763(0),"^",15)
SET LA7RS="C"
+174 IF $GET(LRSB)=1.2
IF $GET(LA7SR)
SET LA7RSDT=+$GET(^LR(LRDFN,LA("SUB"),LRIDT,LRSB,LA7SR,0),"^")
End DoDot:1
+175 ;
+176 ; If MI subscript then also check various sections and audit subfile for corrected report
+177 IF LA("SUB")="MI"
Begin DoDot:1
+178 SET LA7PRI=$PIECE(LA763(0),"^",4)
+179 SET LA7X=$SELECT(LRSB=11: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)
+180 SET LA7Y=$GET(^LR(LRDFN,"MI",LRIDT,LA7X),"^")
+181 IF $PIECE(LA7Y,"^")
SET LA7RSDT=$PIECE(LA7Y,"^")
SET LA7RS=$PIECE(LA7Y,"^",2)
SET LA7PRI=$PIECE(LA7Y,"^",3)
+182 IF $PIECE(LA763(0),"^",9)=1
SET LA7RS="C"
QUIT
+183 IF '$DATA(^LR(LRDFN,"MI",LRIDT,32))
QUIT
+184 SET I=0
+185 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
+186 ;
+187 ; Also check for individual test status on "ORUT" node in file #63
+188 IF $PIECE(LA7NLT(63),"^",10)
SET LA7RS=$PIECE(LA7NLT(63),"^",10)
+189 ;
+190 ; Date Report Completed
+191 ;I LA7RSDT S OBR(22)=$$OBR22^LA7VOBR(LA7RSDT)
+192 IF $PIECE(LA7RSDT,".",2)=""
SET LA7RSDT=LA7RSDT_".000101"
+193 ;status change MU2
IF $GET(LA7RSDT)]""
SET OBR(22)=$$OBR22^LA7COBR(LA7RSDT)
+194 ;mu2
IF '$GET(OBR(22))
SET OBR(22)=$$OBR22^LA7COBR($GET(OBR(7)))
+195 ;mu2
IF $GET(OBR(22))="-1"
SET OBR(22)=$GET(OBR(7))
+196 ;
+197 ; Diagnostic service id
+198 SET OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$GET(LRSB))
+199 ;
+200 ; Result status
+201 IF LRSS="CH"
IF $GET(LA7RSDT)]""
SET LA7RS="F"
+202 IF LA7RS'=""
SET OBR(25)=$$OBR25^LA7VOBR(LA7RS)
+203 IF LRSS="CH"
IF $PIECE($GET(LA7RSDT),".")=""
IF $GET(LA7INPT)
SET OBR(25)="X"
SET LA7REJ=1
+204 ;MU2
IF $GET(OBR(25))=""
SET OBR(25)="P"
+205 ;
+206 ; Result copies to
+207 NEW LA7OBR28
+208 SET LA7OBR28=$PIECE($GET(^LR(LRDFN,"CH",LRIDT,"IHS")),"!",2)
+209 IF $GET(LA7INPT)
SET OBR(28)=$$OBR28^LA7COBR(LA7OBR28,LA7ECH)
+210 ;
+211 ; Parent Result and Parent
+212 ;mu2 inpatient
IF $GET(LA7INPT)
IF $GET(LA7ADDON)
IF $GET(LA7ADDPN)]""
Begin DoDot:1
+213 IF '$GET(LA7OBRSN)
QUIT
+214 SET LA7PARNT(1)=LA7ADDPN
+215 SET LA7PARNT(2)=1
+216 SET LA7PARNT(3)=""
End DoDot:1
+217 IF $DATA(LA7PARNT)
Begin DoDot:1
+218 IF $GET(LA7INPT)
IF $GET(LA7ADDON)
IF $GET(LA7OBRSN)=1
QUIT
+219 SET OBR(26)=$$OBR26^LA7COBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
+220 SET OBR(29)=$$OBR29^LA7COBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
End DoDot:1
+221 ;
+222 ;-- MU2 reason for study
+223 SET OBR(31)=$$OBR31^LA7COBR(OD,OI,OII,LA7FS,LA7ECH)
+224 IF $GET(LA7INPT)
IF $GET(LRSS)="MI"
Begin DoDot:1
+225 ;inpatient mu2 micro wants ICD code
SET OBR(13)=OBR(31)
+226 SET $PIECE(OBR(13),$EXTRACT(LA7ECH),9)=$PIECE(OBR(13),$EXTRACT(LA7ECH),2)
End DoDot:1
+227 ;
+228 ; Principle result interpreter
+229 IF LA("SUB")?1(1"MI",1"SP",1"CY",1"EM")
Begin DoDot:1
+230 IF LA("SUB")="MI"
SET LA7X=$PIECE(LA763(0),"^",4)
+231 IF '$TEST
SET LA7X=$PIECE(LA763(0),"^",2)
+232 SET OBR(32)=$$OBR32^LA7COBR(LA7X,LADFINST,LA7FS,LA7ECH)
End DoDot:1
+233 ;
+234 IF $GET(OBR(32))=""
Begin DoDot:1
+235 SET LA7X=$PIECE($GET(^BLRSITE(DUZ(2),3)),U,8)
+236 IF 'LA7X
QUIT
+237 SET OBR(32)=$$OBR32^LA7COBR(LA7X,DUZ(2),LA7FS,LA7ECH)
+238 ;MU2
SET OBR(32)=$TRANSLATE(OBR(32),$EXTRACT(LA7ECH),"")
+239 SET $PIECE(OBR(32),$EXTRACT(LA7ECH,4),9)="NIST_Sending App"
+240 SET $PIECE(OBR(32),$EXTRACT(LA7ECH,4),10)="2.16.840.1.113883.3.72.5.21"
+241 SET $PIECE(OBR(32),$EXTRACT(LA7ECH,4),11)="ISO"
End DoDot:1
+242 ; Assistant result interpreter
+243 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)
+244 ;
+245 ; Technician
+246 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)
+247 ;
+248 ; Typist - VistA stores as free text
+249 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)
+250 ;
+251 ; Procedure code - use Order NLT code
+252 ;S OBR(44)=$$OBR44^LA7VOBR(LA7NLT,LA7FS,LA7ECH)
+253 NEW LA7OBR49
+254 SET LA7OBR49=$PIECE($GET(^LR(LRDFN,"CH",LRIDT,"IHS")),"!",2)
+255 IF $GET(LA7INPT)
SET OBR(49)=$$OBR49^LA7COBR(LA7OBR49,LA7ECH)
+256 ;
+257 DO BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
+258 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+259 ;
+260 ; Check for flag to only build message but do not file
+261 IF '$GET(LA7NOMSG)
DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+262 ;
+263 QUIT
+264 ;
SUFFIX(CNT) ;-- return uid suffix
+1 IF CNT=2
QUIT "A"
+2 IF CNT=3
QUIT "B"
+3 IF CNT=4
QUIT "C"
+4 IF CNT=5
QUIT "D"
+5 IF CNT=6
QUIT "E"
+6 IF CNT=7
QUIT "F"
+7 IF CNT=8
QUIT "G"
+8 IF CNT=9
QUIT "H"
+9 IF CNT=10
QUIT "I"
+10 IF CNT=11
QUIT "J"
+11 IF CNT=12
QUIT "K"
+12 IF CNT=13
QUIT "L"
+13 IF CNT=14
QUIT "M"
+14 IF CNT=15
QUIT "N"
+15 IF CNT=16
QUIT "O"
+16 IF CNT=17
QUIT "P"
+17 IF CNT=18
QUIT "Q"
+18 IF CNT=19
QUIT "R"
+19 IF CNT=20
QUIT "S"
+20 IF CNT=21
QUIT "T"
+21 IF CNT=22
QUIT "U"
+22 IF CNT=23
QUIT "V"
+23 IF CNT=24
QUIT "W"
+24 IF CNT=25
QUIT "X"
+25 IF CNT=26
QUIT "Y"
+26 IF CNT=27
QUIT "Z"
+27 QUIT
+28 ;
