Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LA7VORU

LA7VORU.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. EN(LA) ; called from IN^LA7VMSG(...)
  1. ; variables
  1. ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
  1. ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
  1. ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
  1. ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
  1. ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
  1. ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
  1. ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
  1. ; LA("LRDFN") - IEN in LAB DATA file (#63)
  1. ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
  1. ; LA("AUTO-INST") - Auto-Instrument
  1. ;
  1. N LA763,LA7NLT,LA7NVAF,LA7RS,LA7X,PRIMARY
  1. ;
  1. S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
  1. I $G(PRIMARY)'="" D
  1. . S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
  1. . S PRIMARY=$P(PRIMARY,U,3)
  1. . S LA("AUTO-INST")="LA7V HOST "_PRIMARY
  1. ;
  1. I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q
  1. . ; need to add error logging when no entry in 63.
  1. ;
  1. ; Check for date report completed.
  1. S LRDFN=LA("LRDFN"),LRSS=LA("SUB"),LRIDT=LA("LRIDT")
  1. I '$$OK2SEND^LA7SRR D CREATE^LA7LOG(122) Q
  1. ;
  1. ; Get zeroth node of entry in #63.
  1. S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
  1. S LA7NLT=$G(LA("NLT"))
  1. ;
  1. S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
  1. S LA7NTESN=0
  1. D ORC
  1. ;
  1. I $G(LA("SUB"))="CH" D CH
  1. I $G(LA("SUB"))="MI" D MI^LA7VORU1
  1. I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
  1. Q
  1. ;
  1. ;
  1. CH ; Build segments for "CH" subscript
  1. ;
  1. D OBR
  1. D NTE
  1. S LA7OBXSN=0
  1. D OBX
  1. ;
  1. Q
  1. ;
  1. ;
  1. ORC ; Build ORC segment
  1. ;
  1. N LA76205,LA763,LA7696,LA7DATA,LA7PLOBR,LA7SM,LA7X,LA7Y,LADFINST,ORC
  1. N LA7HIT,LA7696TX
  1. ;
  1. S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
  1. ;
  1. ; Retrieve placer's OBR information stored in #69.6
  1. D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
  1. ;
  1. ; Default institution from Kernel
  1. S LADFINST=+$$KSP^XUPARAM("INST")
  1. ;
  1. S ORC(0)="ORC"
  1. ;
  1. ; Order control
  1. S ORC(1)=$$ORC1^LA7VORC("RE")
  1. ;
  1. ; Remote UID
  1. K LA7X
  1. M LA7X=LA("RUID")
  1. S ORC(2)=$$ORC2^LA7VORC(.LA7X,LA7FS,LA7ECH)
  1. ;
  1. ; Host UID
  1. K LA7X
  1. M LA7X=LA("HUID")
  1. S ORC(3)=$$ORC3^LA7VORC(.LA7X,LA7FS,LA7ECH)
  1. ;
  1. ; Return shipping manifest if found
  1. ;LA*5.2*101: Determine correct shipping manifest identifier for
  1. ; test if UID is on more than one shipping manifest.
  1. S LA7SM="",(LA7HIT,LA7696)=0
  1. I LA("SITE")'="",LA("RUID")'="",LA("NLT")'="" D
  1. . F S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),LA7696)) Q:LA7696="" Q:LA7HIT D
  1. . . S LA7696TX=0
  1. . . F S LA7696TX=$O(^LRO(69.6,LA7696,2,LA7696TX)) Q:'LA7696TX Q:LA7HIT D
  1. . . . I $P($G(^LRO(69.6,LA7696,2,LA7696TX,0)),"^",2)=LA("NLT") D
  1. . . . . S LA7HIT=1
  1. . . . . S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
  1. ;end of LA*5.2*101
  1. I LA7SM'="" D
  1. . S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
  1. . D SETID^LA7VHLU1(LA76249,LA7ID,LA7SM,0)
  1. . D SETID^LA7VHLU1(LA76249,"",LA7SM,0)
  1. ;
  1. ; Order status
  1. ; DoD/CHCS requires ORC-5 valued otherwise will not process message
  1. I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
  1. ;
  1. ; Test urgency - lookup ordered test in "ORUT" node
  1. K LA7X
  1. I LA("NLT")'="" D
  1. . S LA7X=$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORUT","B",LA("NLT"),""))
  1. . I LA7X<1 Q
  1. . S LA76205=$P($G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORUT",LA7X,0)),"^",2)
  1. . S ORC(7)=$$ORC7^LA7VORC("","",LA76205,LA7FS,LA7ECH)
  1. ;
  1. ; Ordering provider
  1. K LA7X,LA7Y
  1. S (LA7X,LA7Y)=""
  1. ; "CH" and "MI" subscript store requesting provider and requesting div/location.
  1. I "CHMI"[LA("SUB") D
  1. . N LA7J
  1. . S LA7J=$P(LA763(0),"^",13)
  1. . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
  1. . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
  1. . I LA("SUB")="CH" S LA7X=$P(LA763(0),"^",10)
  1. . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",7)
  1. ;
  1. ; Other subscripts only store requesting provider
  1. I "CYEMSP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
  1. ;
  1. ; Send back ordering provider stored in #69.6 if available.
  1. I LA7INTYP=10,$G(LA7PLOBR("OBR-17"))'="" S LA7X=LA7PLOBR("OBR-17")
  1. ;
  1. I LA7Y="" S LA7Y=LADFINST
  1. S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$S($G(LA7INTYP)=30:2,$G(LA7NVAF)=1:0,1:1))
  1. ;
  1. ; Enterer's location
  1. S LA7X=""
  1. I "CHMI"[LA("SUB") S LA7X=$P(LA763(0),"^",13)
  1. I LA7X'="" S ORC(13)=$$ORC13^LA7VORC(LA7X,LA7FS,LA7ECH)
  1. ;
  1. ; Entering organization
  1. S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
  1. ;
  1. ; Ordering facility/address
  1. S LA7X=$P($G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")),"^",3)
  1. I 'LA7X,"CHMI"[LA("SUB") S LA7X=$P(LA763(0),"^",14)
  1. I LA7X D
  1. . S ORC(21)=$$ORC21^LA7VORC(LA7X,LA7FS,LA7ECH)
  1. . S ORC(22)=$$ORC22^LA7VORC(LA7X,$P(LA763(0),"^"),LA7FS,LA7ECH)
  1. ;
  1. D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
  1. D FILESEG^LA7VHLU(GBL,.LA7DATA)
  1. ;
  1. ; Check for flag to only build message but do not file
  1. I '$G(LA7NOMSG) D
  1. . D FILE6249^LA7VHLU(LA76249P,.LA7DATA)
  1. . I LA("HUID")'="" D
  1. . . D SETID^LA7VHLU1(LA76249,LA7ID,LA("HUID"),0)
  1. . . D SETID^LA7VHLU1(LA76249,"",LA("HUID"),0)
  1. . I LA("RUID")'="" D
  1. . . D SETID^LA7VHLU1(LA76249,LA7ID,LA("RUID"),0)
  1. . . D SETID^LA7VHLU1(LA76249,"",LA("RUID"),0)
  1. ;
  1. Q
  1. ;
  1. ;
  1. OBR ;Observation Request segment for Lab Order
  1. ;
  1. D OBR^LA7VORUB
  1. Q
  1. ;
  1. ;
  1. OBX ;Observation/Result segment for Lab Results
  1. ;
  1. D OBX^LA7VORUA
  1. Q
  1. ;
  1. ;
  1. NTE ; Build NTE segment
  1. ;
  1. D NTE^LA7VORUA
  1. Q