LA7CORUB.m

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)