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

BLRRIIN1.m

Go to the documentation of this file.
  1. BLRRIIN1 ;cmi/anch/maw - Process Incoming UI Msgs, continued 12/3/1997 ;JUL 06, 2010 3:14 PM
  1. ;;5.2;IHS LABORATORY;**1021,1027**;NOV 01, 1997
  1. ;;5.2;LR;**17,23,27,1021**;Oct 20, 2005
  1. ;
  1. ;cmi/maw for RML INBOUND HL7 MESSAGE
  1. ;;5.2;LAB MESSAGING;**17,23,27**;Sep 27, 1994
  1. ;This routine is a continuation of LA7UIIN and is only
  1. ;called from there. It is called with each message found
  1. ;in the incoming queue.
  1. QUIT
  1. ;
  1. NXTMSG ; EP
  1. S (LA7CNT,LA7QUIT)=0
  1. S (LA7AN,LA7INST,LA7OBR,LA7UID)=""
  1. S DT=$$DT^XLFDT
  1. I '$O(^LAHM(62.49,LA76249,150,0)) D Q ; Message built but no text.
  1. . D CREATE^LA7LOG(6)
  1. MSH S LA7MSH=$G(^($O(^LAHM(62.49,LA76249,150,0)),0))
  1. I $E(LA7MSH,1,3)'="MSH" D QUIT ;bad first line of message
  1. . D CREATE^LA7LOG(7)
  1. S LA7FS=$E(LA7MSH,4)
  1. S LA7CS=$E(LA7MSH,5)
  1. I LA7FS=""!(LA7CS="") D QUIT ;no field or component seperator
  1. . D CREATE^LA7LOG(8)
  1. S LA762495=0
  1. OBR F S LA762495=$O(^LAHM(62.49,LA76249,150,LA762495)) Q:'LA762495!($E($G(^(+LA762495,0)),1,3)="OBR") ;find the OBR segment
  1. S DT=$$DT^XLFDT
  1. I 'LA762495,$L($G(LA7OBR)) Q ; No more OBR's, found at least 1.
  1. S LA7OBR=$G(^LAHM(62.49,LA76249,150,+LA762495,0))
  1. I $E(LA7OBR,1,3)'="OBR" D QUIT ;should only be working on OBR
  1. . D CREATE^LA7LOG(9)
  1. ;S LA7INST=$P($P(LA7OBR,LA7FS,19),LA7CS,1) ; extracting 1st piece
  1. S LA7PF=$P(LA7OBR,LA7FS,26) ;cmi/anch/maw 2/15/2007 for final reports only
  1. I $G(LA7PF)]"" Q:$G(LA7PF)="P" ;cmi/anch/maw 2/15/2007 for final reports only
  1. S LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
  1. I LA7INST="" D QUIT
  1. . D CREATE^LA7LOG(10)
  1. S LA7624=+$O(^LAB(62.4,"B",LA7INST,0))
  1. I 'LA7624 D QUIT ;instrument name not found in xref
  1. . D CREATE^LA7LOG(11)
  1. S LA7INST=$G(^LAB(62.4,LA7624,0))
  1. I LA7INST="" D QUIT ;instrument entry not found in file
  1. . D CREATE^LA7LOG(11)
  1. S LA7ENTRY=$P(LA7INST,"^",6) ;LOG,LLIST,IDENT or SEQN
  1. S:LA7ENTRY="" LA7ENTRY="LOG"
  1. ;
  1. S LA7TRAY=+$P($P(LA7OBR,LA7FS,20),LA7CS,1) ;Tray
  1. S LA7CUP=+$P($P(LA7OBR,LA7FS,20),LA7CS,2) ; Cup
  1. ;S LA7AA=+$P($P(LA7OBR,LA7FS,20),LA7CS,3) ; Accession Area
  1. S LA7AA=+$O(^LRO(68,"B","SO",0)) ; Accession Area
  1. S LA7AD=$$HDATE^INHUT(+$P(LA7OBR,LA7FS,8)) ; Accession Date
  1. S LA7AN=+$P($P(LA7OBR,LA7FS,20),LA7CS,5) ; Accession Entry
  1. ;S LA7ACC=$P($P(LA7OBR,LA7FS,3),"^") ; Accession
  1. S LA7ACC=$P($P(LA7OBR,LA7FS,3),"^") ; Accession
  1. ;S LA7ACC=$E(LA7ACC,1,2)_$E(LA7ACC,3,99)
  1. S LA7UID=LA7ACC ; Unique ID
  1. S LA7IDE=$P($P(LA7OBR,LA7FS,20),LA7CS,8) ; Sequence Number
  1. S LA7LWL=$P(LA7INST,"^",4) ; Load/Work List
  1. ;I LA7LWL="" S LA7LWL="SENDOUTS" ;maw ref lab
  1. S LA7OBR3=$P(LA7OBR,LA7FS,3) ; Sample ID or Bar code
  1. S LA7OBR(15)=$P(LA7OBR,LA7FS,16) ; Specimen source
  1. I LA7UID="",LA7OBR3?10UN S LA7UID=LA7OBR3 ; UID might come as Sample ID
  1. ; Try to figure out LRAA LRAD LRAN by using the unique ID (LRUID)
  1. ; accession may have rolled over, use UID to get current accession info.
  1. I LA7UID]"" D
  1. . N X
  1. . S X=$Q(^LRO(68,"C",LA7UID))
  1. . I $QS(X,3)'=LA7UID S LA7UID="" Q ; UID not on file.
  1. . S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
  1. ;if still not known, compute from default date and accession area
  1. I '(LA7AA*LA7AD*LA7AN) D
  1. . N X
  1. . S DT=$$DT^XLFDT
  1. . S LA7AA=+$P(LA7INST,"^",11)
  1. . S X=$P($G(^LRO(68,LA7AA,0)),U,3)
  1. . S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT) ; Calculate accession date based on accession transform.
  1. . S LA7AN=+LA7OBR3
  1. I LA7ENTRY="LOG",'$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D ;log but cont
  1. . D CREATE^LA7LOG(13)
  1. I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE ;cup=sequence number
  1. D LAGEN ;create entry in ^LAH global
  1. I $G(LA7ISQN)="" D QUIT ;couldn't create entry in ^LAH
  1. . D CREATE^LA7LOG(14)
  1. S (LA761,LA762,LA70070)="" ; specimen(topography), collection sample, HL7 specimen source
  1. I $O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) D
  1. . N X
  1. . S X=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0))
  1. . S X(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0)) ; specimen^collection sample
  1. . S LA761=$P(X(0),"^") ; specimen
  1. . S LA762=$P(X(0),"^",2) ; collection sample
  1. . I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR") ;HL7 code from Topography
  1. I $L(LA70070),$L($P(LA7OBR(15),LA7CS)) D
  1. . I LA70070=$P(LA7OBR(15),LA7CS) Q ; Message matches accession
  1. . D CREATE^LA7LOG(22) ; Log error when specimen source does not match accession segments.
  1. . S LA7QUIT=1
  1. I LA7QUIT S LA7QUIT=0 G OBR ; Something wrong, process next OBR
  1. S LA7AA(0)=$G(^LRO(68,+LA7AA,0)) ; Zeroth node of acession area.
  1. I $P(LA7AA(0),"^",2)="" G OBR ; No subscript defined for this area.
  1. I "CH"'[$P(LA7AA(0),"^",2) G OBR ; Processing of this subscript not supported.
  1. ;I $P(LA7AA(0),"^",2)="MI" D MI^LA7UIIN3 ; Process "MI" subscript results.
  1. I $P(LA7AA(0),"^",2)="CH" D NTE^BLRRIIN2 ; Process "CH" subscript results - NTE and OBX segments.
  1. I 'LA762495 Q ; No more segments to process, reached end of global array.
  1. S LA762495=LA762495-1 ; Reset subscript variable.
  1. G OBR ; Go back to find/process additional OBR segments.
  1. ;
  1. LAGEN ;subroutine to set up vars for call to ^LAGEN, build entry in LAH
  1. ;requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL
  1. ;returns LA7ISQN=subscript to store results in ^LAH global
  1. K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN
  1. K LADT,LAGEN,LA7ISQN
  1. S LA7ISQN=""
  1. S TRAY=+$G(LA7TRAY) S:'TRAY TRAY=1
  1. S CUP=+$G(LA7CUP) S:'CUP CUP=1
  1. S LWL=LA7LWL ;maw ref lab
  1. I '$D(^LRO(68.2,+LWL,0)) D QUIT
  1. . D CREATE^LA7LOG(19)
  1. ; Set accession area to area of specimen, allow multiple areas on same instrument.
  1. S WL=LA7AA
  1. I '$D(^LRO(68,+WL,0)) D QUIT
  1. . D CREATE^LA7LOG(20)
  1. S LROVER=$P(LA7INST,"^",12)
  1. S METH=$P(LA7INST,"^",10)
  1. S LOG=LA7AN
  1. S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6) ;identity field
  1. S IDE=+LA7IDE
  1. S LADT=LA7AD
  1. D @(LA7ENTRY_"^LAGEN") ;this disregards the CROSS LINK field in 62.4
  1. S LA7ISQN=$G(ISQN)
  1. Q ;quit LAGEN subroutine