LA7VORU ;DALOI/JMC - Builder of HL7 Lab Results OBR/OBX/NTE ;Jun 14, 2022@18:38
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,61,64,71,68,74,101**;Sep 27, 1994;Build 6
;
EN(LA) ; called from IN^LA7VMSG(...)
; variables
; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
; LA("LRDFN") - IEN in LAB DATA file (#63)
; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
; LA("AUTO-INST") - Auto-Instrument
;
N LA763,LA7NLT,LA7NVAF,LA7RS,LA7X,PRIMARY
;
S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
I $G(PRIMARY)'="" D
. S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
. S PRIMARY=$P(PRIMARY,U,3)
. S LA("AUTO-INST")="LA7V HOST "_PRIMARY
;
I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q
. ; need to add error logging when no entry in 63.
;
; Check for date report completed.
S LRDFN=LA("LRDFN"),LRSS=LA("SUB"),LRIDT=LA("LRIDT")
I '$$OK2SEND^LA7SRR D CREATE^LA7LOG(122) Q
;
; Get zeroth node of entry in #63.
S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
S LA7NLT=$G(LA("NLT"))
;
S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
S LA7NTESN=0
D ORC
;
I $G(LA("SUB"))="CH" D CH
I $G(LA("SUB"))="MI" D MI^LA7VORU1
I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
Q
;
;
CH ; Build segments for "CH" subscript
;
D OBR
D NTE
S LA7OBXSN=0
D OBX
;
Q
;
;
ORC ; Build ORC segment
;
N LA76205,LA763,LA7696,LA7DATA,LA7PLOBR,LA7SM,LA7X,LA7Y,LADFINST,ORC
N LA7HIT,LA7696TX
;
S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
;
; Retrieve placer's OBR information stored in #69.6
D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
;
; Default institution from Kernel
S LADFINST=+$$KSP^XUPARAM("INST")
;
S ORC(0)="ORC"
;
; Order control
S ORC(1)=$$ORC1^LA7VORC("RE")
;
; Remote UID
K LA7X
M LA7X=LA("RUID")
S ORC(2)=$$ORC2^LA7VORC(.LA7X,LA7FS,LA7ECH)
;
; Host UID
K LA7X
M LA7X=LA("HUID")
S ORC(3)=$$ORC3^LA7VORC(.LA7X,LA7FS,LA7ECH)
;
; Return shipping manifest if found
;LA*5.2*101: Determine correct shipping manifest identifier for
; test if UID is on more than one shipping manifest.
S LA7SM="",(LA7HIT,LA7696)=0
I LA("SITE")'="",LA("RUID")'="",LA("NLT")'="" D
. F S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),LA7696)) Q:LA7696="" Q:LA7HIT D
. . S LA7696TX=0
. . F S LA7696TX=$O(^LRO(69.6,LA7696,2,LA7696TX)) Q:'LA7696TX Q:LA7HIT D
. . . I $P($G(^LRO(69.6,LA7696,2,LA7696TX,0)),"^",2)=LA("NLT") D
. . . . S LA7HIT=1
. . . . S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
;end of LA*5.2*101
I LA7SM'="" D
. S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
. D SETID^LA7VHLU1(LA76249,LA7ID,LA7SM,0)
. D SETID^LA7VHLU1(LA76249,"",LA7SM,0)
;
; Order status
; DoD/CHCS requires ORC-5 valued otherwise will not process message
I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
;
; Test urgency - lookup ordered test in "ORUT" node
K LA7X
I LA("NLT")'="" D
. S LA7X=$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORUT","B",LA("NLT"),""))
. I LA7X<1 Q
. S LA76205=$P($G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORUT",LA7X,0)),"^",2)
. S ORC(7)=$$ORC7^LA7VORC("","",LA76205,LA7FS,LA7ECH)
;
; Ordering provider
K LA7X,LA7Y
S (LA7X,LA7Y)=""
; "CH" and "MI" subscript store requesting provider and requesting div/location.
I "CHMI"[LA("SUB") 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,";")
. I LA("SUB")="CH" S LA7X=$P(LA763(0),"^",10)
. I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",7)
;
; Other subscripts only store requesting provider
I "CYEMSP"[LA("SUB") 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 ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$S($G(LA7INTYP)=30:2,$G(LA7NVAF)=1:0,1:1))
;
; Enterer's location
S LA7X=""
I "CHMI"[LA("SUB") S LA7X=$P(LA763(0),"^",13)
I LA7X'="" S ORC(13)=$$ORC13^LA7VORC(LA7X,LA7FS,LA7ECH)
;
; Entering organization
S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
;
; Ordering facility/address
S LA7X=$P($G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")),"^",3)
I 'LA7X,"CHMI"[LA("SUB") S LA7X=$P(LA763(0),"^",14)
I LA7X D
. S ORC(21)=$$ORC21^LA7VORC(LA7X,LA7FS,LA7ECH)
. S ORC(22)=$$ORC22^LA7VORC(LA7X,$P(LA763(0),"^"),LA7FS,LA7ECH)
;
D BUILDSEG^LA7VHLU(.ORC,.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(LA76249P,.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
;
;
OBR ;Observation Request segment for Lab Order
;
D OBR^LA7VORUB
Q
;
;
OBX ;Observation/Result segment for Lab Results
;
D OBX^LA7VORUA
Q
;
;
NTE ; Build NTE segment
;
D NTE^LA7VORUA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VORU 5596 printed Apr 09, 2024@20:48:06 Page 2
LA7VORU ;DALOI/JMC - Builder of HL7 Lab Results OBR/OBX/NTE ;Jun 14, 2022@18:38
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,61,64,71,68,74,101**;Sep 27, 1994;Build 6
+2 ;
EN(LA) ; called from IN^LA7VMSG(...)
+1 ; variables
+2 ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
+3 ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
+4 ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
+5 ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
+6 ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
+7 ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
+8 ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
+9 ; LA("LRDFN") - IEN in LAB DATA file (#63)
+10 ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
+11 ; LA("AUTO-INST") - Auto-Instrument
+12 ;
+13 NEW LA763,LA7NLT,LA7NVAF,LA7RS,LA7X,PRIMARY
+14 ;
+15 SET PRIMARY=$$PRIM^VASITE(DT)
SET LA("AUTO-INST")=""
+16 IF $GET(PRIMARY)'=""
Begin DoDot:1
+17 SET PRIMARY=$$SITE^VASITE(DT,PRIMARY)
+18 SET PRIMARY=$PIECE(PRIMARY,U,3)
+19 SET LA("AUTO-INST")="LA7V HOST "_PRIMARY
End DoDot:1
+20 ;
+21 IF '$ORDER(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
Begin DoDot:1
+22 ; need to add error logging when no entry in 63.
End DoDot:1
QUIT
+23 ;
+24 ; Check for date report completed.
+25 SET LRDFN=LA("LRDFN")
SET LRSS=LA("SUB")
SET LRIDT=LA("LRIDT")
+26 IF '$$OK2SEND^LA7SRR
DO CREATE^LA7LOG(122)
QUIT
+27 ;
+28 ; Get zeroth node of entry in #63.
+29 SET LA763(0)=$GET(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
+30 SET LA7NLT=$GET(LA("NLT"))
+31 ;
+32 SET LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
+33 SET LA7NTESN=0
+34 DO ORC
+35 ;
+36 IF $GET(LA("SUB"))="CH"
DO CH
+37 IF $GET(LA("SUB"))="MI"
DO MI^LA7VORU1
+38 IF "SPCYEM"[$GET(LA("SUB"))
DO AP^LA7VORU2
+39 QUIT
+40 ;
+41 ;
CH ; Build segments for "CH" subscript
+1 ;
+2 DO OBR
+3 DO NTE
+4 SET LA7OBXSN=0
+5 DO OBX
+6 ;
+7 QUIT
+8 ;
+9 ;
ORC ; Build ORC segment
+1 ;
+2 NEW LA76205,LA763,LA7696,LA7DATA,LA7PLOBR,LA7SM,LA7X,LA7Y,LADFINST,ORC
+3 NEW LA7HIT,LA7696TX
+4 ;
+5 SET LA763(0)=$GET(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
+6 ;
+7 ; Retrieve placer's OBR information stored in #69.6
+8 DO RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
+9 ;
+10 ; Default institution from Kernel
+11 SET LADFINST=+$$KSP^XUPARAM("INST")
+12 ;
+13 SET ORC(0)="ORC"
+14 ;
+15 ; Order control
+16 SET ORC(1)=$$ORC1^LA7VORC("RE")
+17 ;
+18 ; Remote UID
+19 KILL LA7X
+20 MERGE LA7X=LA("RUID")
+21 SET ORC(2)=$$ORC2^LA7VORC(.LA7X,LA7FS,LA7ECH)
+22 ;
+23 ; Host UID
+24 KILL LA7X
+25 MERGE LA7X=LA("HUID")
+26 SET ORC(3)=$$ORC3^LA7VORC(.LA7X,LA7FS,LA7ECH)
+27 ;
+28 ; Return shipping manifest if found
+29 ;LA*5.2*101: Determine correct shipping manifest identifier for
+30 ; test if UID is on more than one shipping manifest.
+31 SET LA7SM=""
SET (LA7HIT,LA7696)=0
+32 IF LA("SITE")'=""
IF LA("RUID")'=""
IF LA("NLT")'=""
Begin DoDot:1
+33 FOR
SET LA7696=$ORDER(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),LA7696))
if LA7696=""
QUIT
if LA7HIT
QUIT
Begin DoDot:2
+34 SET LA7696TX=0
+35 FOR
SET LA7696TX=$ORDER(^LRO(69.6,LA7696,2,LA7696TX))
if 'LA7696TX
QUIT
if LA7HIT
QUIT
Begin DoDot:3
+36 IF $PIECE($GET(^LRO(69.6,LA7696,2,LA7696TX,0)),"^",2)=LA("NLT")
Begin DoDot:4
+37 SET LA7HIT=1
+38 SET LA7SM=$PIECE($GET(^LRO(69.6,LA7696,0)),U,14)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+39 ;end of LA*5.2*101
+40 IF LA7SM'=""
Begin DoDot:1
+41 SET ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
+42 DO SETID^LA7VHLU1(LA76249,LA7ID,LA7SM,0)
+43 DO SETID^LA7VHLU1(LA76249,"",LA7SM,0)
End DoDot:1
+44 ;
+45 ; Order status
+46 ; DoD/CHCS requires ORC-5 valued otherwise will not process message
+47 IF LA7NVAF=1
SET ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
+48 ;
+49 ; Test urgency - lookup ordered test in "ORUT" node
+50 KILL LA7X
+51 IF LA("NLT")'=""
Begin DoDot:1
+52 SET LA7X=$ORDER(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORUT","B",LA("NLT"),""))
+53 IF LA7X<1
QUIT
+54 SET LA76205=$PIECE($GET(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORUT",LA7X,0)),"^",2)
+55 SET ORC(7)=$$ORC7^LA7VORC("","",LA76205,LA7FS,LA7ECH)
End DoDot:1
+56 ;
+57 ; Ordering provider
+58 KILL LA7X,LA7Y
+59 SET (LA7X,LA7Y)=""
+60 ; "CH" and "MI" subscript store requesting provider and requesting div/location.
+61 IF "CHMI"[LA("SUB")
Begin DoDot:1
+62 NEW LA7J
+63 SET LA7J=$PIECE(LA763(0),"^",13)
+64 IF $PIECE(LA7J,";",2)="SC("
SET LA7Y=$$GET1^DIQ(44,$PIECE(LA7J,";")_",",3,"I")
+65 IF $PIECE(LA7J,";",2)="DIC(4,"
SET LA7Y=$PIECE(LA7J,";")
+66 IF LA("SUB")="CH"
SET LA7X=$PIECE(LA763(0),"^",10)
+67 IF LA("SUB")="MI"
SET LA7X=$PIECE(LA763(0),"^",7)
End DoDot:1
+68 ;
+69 ; Other subscripts only store requesting provider
+70 IF "CYEMSP"[LA("SUB")
SET LA7X=$PIECE(LA763(0),"^",7)
+71 ;
+72 ; Send back ordering provider stored in #69.6 if available.
+73 IF LA7INTYP=10
IF $GET(LA7PLOBR("OBR-17"))'=""
SET LA7X=LA7PLOBR("OBR-17")
+74 ;
+75 IF LA7Y=""
SET LA7Y=LADFINST
+76 SET ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$SELECT($GET(LA7INTYP)=30:2,$GET(LA7NVAF)=1:0,1:1))
+77 ;
+78 ; Enterer's location
+79 SET LA7X=""
+80 IF "CHMI"[LA("SUB")
SET LA7X=$PIECE(LA763(0),"^",13)
+81 IF LA7X'=""
SET ORC(13)=$$ORC13^LA7VORC(LA7X,LA7FS,LA7ECH)
+82 ;
+83 ; Entering organization
+84 SET ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
+85 ;
+86 ; Ordering facility/address
+87 SET LA7X=$PIECE($GET(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")),"^",3)
+88 IF 'LA7X
IF "CHMI"[LA("SUB")
SET LA7X=$PIECE(LA763(0),"^",14)
+89 IF LA7X
Begin DoDot:1
+90 SET ORC(21)=$$ORC21^LA7VORC(LA7X,LA7FS,LA7ECH)
+91 SET ORC(22)=$$ORC22^LA7VORC(LA7X,$PIECE(LA763(0),"^"),LA7FS,LA7ECH)
End DoDot:1
+92 ;
+93 DO BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
+94 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+95 ;
+96 ; Check for flag to only build message but do not file
+97 IF '$GET(LA7NOMSG)
Begin DoDot:1
+98 DO FILE6249^LA7VHLU(LA76249P,.LA7DATA)
+99 IF LA("HUID")'=""
Begin DoDot:2
+100 DO SETID^LA7VHLU1(LA76249,LA7ID,LA("HUID"),0)
+101 DO SETID^LA7VHLU1(LA76249,"",LA("HUID"),0)
End DoDot:2
+102 IF LA("RUID")'=""
Begin DoDot:2
+103 DO SETID^LA7VHLU1(LA76249,LA7ID,LA("RUID"),0)
+104 DO SETID^LA7VHLU1(LA76249,"",LA("RUID"),0)
End DoDot:2
End DoDot:1
+105 ;
+106 QUIT
+107 ;
+108 ;
OBR ;Observation Request segment for Lab Order
+1 ;
+2 DO OBR^LA7VORUB
+3 QUIT
+4 ;
+5 ;
OBX ;Observation/Result segment for Lab Results
+1 ;
+2 DO OBX^LA7VORUA
+3 QUIT
+4 ;
+5 ;
NTE ; Build NTE segment
+1 ;
+2 DO NTE^LA7VORUA
+3 QUIT
