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

LA7CORU.m

Go to the documentation of this file. 
  1. LA7CORU ;VA/DALOI/JMC - Builder of HL7 Lab Results OBR/OBX/NTE ; 22-Oct-2013 09:22 ; MAW
  1.  ;;5.2;AUTOMATED LAB INSTRUMENTS;**1002,27,46,61,1018,64,71,1027,68,1033**;NOV 01, 1997
  1.  ;
  1.  ; Cloned from LA7VORU
  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,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.  S LRDFN=LA("LRDFN"),LRSS=LA("SUB"),LRIDT=LA("LRIDT")
  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 LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,LADFINST,ORC
  1.  ;
  1.  S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
  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^LA7CORC(.LA7X,LA7FS,LA7ECH)
  1.  ;
  1.  ; Host UID
  1.  K LA7X
  1.  M LA7X=LA("HUID")
  1.  S ORC(3)=ORC(2)
  1.  I $G(LA7INPT),$G(LRSS)="MI" D
  1.  . Q:'$G(LA7ORCSN)
  1.  . S $P(ORC(3),$E(LA7ECH))=$S(LA7ORCSN>1:LA7UID_$$SUFFIX^LA7CORUB(LA7ORCSN),1:LA7UID)
  1.  . S $P(ORC(3),$E(LA7ECH),2)="LR"
  1.  . I $G(LA7INPT),$G(LRSS)'="MI" S $P(ORC(3),$E(LA7ECH),3)="2.16.840.1.113883.3.72.5.24"
  1.  . I $G(LA7INPT),$G(LRSS)'="MI" S $P(ORC(3),$E(LA7ECH),4)="ISO"
  1.  I $G(LA7INPT),$G(LA7ADDON) D
  1.  . Q:'$G(LA7ORCSN)
  1.  . S $P(ORC(3),$E(LA7ECH))=$S(LA7ORCSN>1:LA7UID_$$SUFFIX^LA7CORUB(LA7ORCSN),1:LA7UID)
  1.  . S $P(ORC(3),$E(LA7ECH),2)="LR"
  1.  ;S ORC(3)=$$ORC3^LA7CORC(.LA7X,LA7FS,LA7ECH)
  1.  S ORC(4)=ORC(3)  ;ihs/cmi/maw mu2
  1.  ;
  1.  ; Return shipping manifest if found
  1.  S LA7SM="",LA7696=0
  1.  I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
  1.  I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
  1.  I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
  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.  ; 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.  I LA7Y="" S LA7Y=LADFINST
  1.  S LA7OP=LA7X
  1.  ;S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH,$S($G(LA7INTYP)=30:2,$G(LA7NVAF)=1:0,1:1))
  1.  S ORC(12)=$$ORC12^LA7CORC(LA7X,LA7Y,LA7FS,LA7ECH,2)
  1.  S $P(ORC(12),$E(LA7ECH),9)="NPI"_$E(LA7ECH,4)_"2.16.840.1.113883.4.6"_$E(LA7ECH,4)_"ISO"
  1.  S $P(ORC(12),$E(LA7ECH),10)="L"
  1.  S $P(ORC(12),$E(LA7ECH),13)="NPI"
  1.  S $P(ORC(12),$E(LA7ECH),14)=LA7FAC_$E(LA7ECH,4)_"2.16.840.1.113883.3.72.5.26"_$E(LA7ECH,4)_"ISO"
  1.  S $P(ORC(12),$E(LA7ECH),21)=$P(ORC(12),$E(LA7ECH),6)
  1.  I $G(LA7INPT) S $P(ORC(12),$E(LA7ECH),7)=""  ;mu2 inpatient
  1.  ;
  1.  ;provider call back number
  1.  ;S ORC(14)=$$ORC14^LA7CORC(LA7X,LA7Y,LA7FS,LA7ECH)
  1.  S ORC(14)=$$OBR17^LA7COBR(LA7FS,LA7ECH)  ;MU2 order call back number
  1.  ;
  1.  ; Enterer's location
  1.  ;not used in MU2
  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^LA7CORC(LA7X,LA7FS,LA7ECH)
  1.  . S $P(ORC(21),$E(LA7ECH,1),6)="NIST Sending App"_$E(LA7ECH,4)_"2.16.840.1.113883.3.72.5.21"_$E(LA7ECH,4)_"ISO"
  1.  . S $P(ORC(21),$E(LA7ECH,1),10)=$P($G(^DIC(4,LA7X,99)),U)
  1.  . S ORC(22)=$$ORC22^LA7CORC(LA7X,$P(LA763(0),"^"),LA7FS,LA7ECH)
  1.  ;
  1.  S ORC(23)=$$ORC23^LA7CORC(DUZ(2),DT,LA7FS,LA7ECH)
  1.  S ORC(24)=$$ORC24^LA7CORC(LA7OP,DT,LA7FS,LA7ECH)
  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 FILE6249^LA7VHLU(LA76249P,.LA7DATA)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. OBR ;Observation Request segment for Lab Order
  1.  ;
  1.  D OBR^LA7CORUB
  1.  Q
  1.  ;
  1.  ;
  1. OBX ;Observation/Result segment for Lab Results
  1.  ;
  1.  N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
  1.  ;
  1.  S LA7VTIEN=0
  1.  F  S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN  D
  1.  . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
  1.  . ; Build OBX segment
  1.  . K LA7DATA
  1.  . D OBX^LA7COBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF))
  1.  . ; If OBX failed to build then don't store
  1.  . I '$D(LA7DATA) Q
  1.  . ;
  1.  . D FILESEG^LA7VHLU(GBL,.LA7DATA)
  1.  . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
  1.  . ;
  1.  . ; Send performing lab comment and interpretation from file #60
  1.  . S LA7NTESN=0
  1.  . I LA7NVAF=1 D PLC^LA7VORUA
  1.  . D INTRP^LA7VORUA
  1.  . ;
  1.  . ; Mark result as sent - set to 1, if corrected results set to 2
  1.  . I LA("SUB")="CH" D
  1.  . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
  1.  . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. NTE ; Build NTE segment
  1.  ;
  1.  D NTE^LA7CORUA
  1.  Q
  1.  ;
  1. TQ1(FS,ECH,ACC,LDFN,LIDT) ; build the TQ1 segment for MU2
  1.  N SPM,CS,RS,SC,TQ1
  1.  S CS=$E(ECH,1,1)
  1.  S RS=$E(ECH,2,2)
  1.  S SC=$E(ECH,3,3)
  1.  F I=1:1:14 S TQ1(I)=""
  1.  S TQ1="TQ1"
  1.  S TQ1(1)=1
  1.  S TQ1(7)=$$FMTHL7^XLFDT($P($G(^LR(LDFN,LRSS,LIDT,0)),U))
  1.  S TQ1(8)=$$FMTHL7^XLFDT($P($G(^LR(LDFN,LRSS,LIDT,0)),U,3))
  1.  F J=1:1:14 S $P(TQ1,FS,J+1)=TQ1(J)
  1.  Q TQ1
  1.  ;
  1. SPM(FS,ECH,ACC) ; build the SPM segment for MU2
  1.  N SPM,CS,RS,SC
  1.  S CS=$E(ECH,1,1)
  1.  S RS=$E(ECH,2,2)
  1.  S SC=$E(ECH,4,4)
  1.  F I=1:1:29 S SPM(I)=""
  1.  S SPM="SPM"
  1.  S SPM(1)=1
  1.  S SPM(2)=$$SPM2^LA7MUSPM(CS,SC,ACC)
  1.  S SPM(4)=$$SPM4^LA7MUSPM(CS,ACC,LRSPEC)
  1.  N ROI
  1.  S ROI=$O(^BLRRLO("ACC",ACC,0))
  1.  I ROI S SPM(5)=$$SPM5^LA7MUSPM(CS,ACC,LRSPEC,ROI)  ;TODO
  1.  I $G(LRSAMP) S SPM(6)=$$SPM6^LA7MUSPM(CS,ACC,LRSPEC)  ;TODO  LOOK AT FILE 62
  1.  I $G(LRSAMP) S SPM(7)=$$SPM7^LA7MUSPM(CS,ACC,LRSPEC)  ;TODO  LOOK AT FILE 62
  1.  I $G(LRSAMP) S SPM(8)=$$SPM8^LA7MUSPM(CS,ACC,LRSPEC)  ;TODO  LOOK AT FILE 62
  1.  I ROI S SPM(9)=$$SPM9^LA7MUSPM(CS,ACC,LRSPEC,ROI)  ;TODO
  1.  S SPM(11)=$$SPM11^LA7MUSPM(CS,ACC,LRSPEC)  ;TODO  FILE 61 TIME ASPECT FIELD
  1.  S SPM(12)=$$SPM12^LA7MUSPM(CS,SC,ACC,LRSPEC)  ;TODO  LOOKS LIKE HARD CODE RIGHT NOW
  1.  S SPM(17)=$$SPM17^LA7MUSPM(CS,LRDFN,LRIDT)
  1.  S SPM(18)=$$SPM18^LA7MUSPM(CS,LRDFN,LRIDT)
  1.  S SPM(21)=$$SPM21^LA7MUSPM(CS,ACC,LRSPEC)
  1.  F J=1:1:29 S $P(SPM,FS,J+1)=SPM(J)
  1.  Q SPM
  1.  ;