- 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 Jan 18, 2025@02:42:15 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