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

BLRTN.m

Go to the documentation of this file. 
  1. BLRTN ; IHS/HQT/MJL - CREATE/EDIT TRANSACTIONS ; 17-Dec-2015 15:37 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1011,1012,1013,1014,1015,1018,1026,1028,1033,1038**;NOV 01, 1997;Build 6
  1.  ;        
  1. TSK ; EP - entry point for background job
  1.  L +^BLRLOCK:5 Q:'$T
  1.  S BLRQUIET=1
  1.  D INIT^BLRPARAM    ;INITIALIZE VARS
  1.  S (BLRTRY,BLRHCNT)=0
  1.  S BLRQDH=$P($G(^BLRSITE(BLRQSITE,0)),U,7)
  1.  ; S:BLRQDH="" BLRQDH=+$H,$P(^BLRSITE(BLRQSITE,0),U,7)=BLRQDH
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033
  1.  I $L(BLRQDH)'=5 D MAKEITSO^BLRUTIL6   ; If BLRQDH an invalid number, reset it
  1.  S $P(^BLRSITE(BLRQSITE,0),U,7)=BLRQDH
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1033
  1.  ;
  1.  ;ERRCHK CHECKS FOR ERRORS > THAN THE PARAMETER 'ERROR OVERFLOW LIMIT'
  1.  F  D CTL Q:BLRHCNT>600  H 1 S BLRHCNT=BLRHCNT+1 Q:BLRSTOP  Q:$$ERRCHK^BLRUTIL(+$H)  I 'BLRLOG,'BLRXPCC Q
  1.  D KILL
  1.  L -^BLRLOCK
  1.  Q
  1.  ;
  1. CTL ; EP 
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1026 -- Line too long
  1.  NEW BLRQFLAG
  1.  S BLRQFLAG="N"
  1.  F  Q:BLRQFLAG="Y"  D
  1.  . S BLRLOG=$G(^BLRSITE(BLRQSITE,0))
  1.  . S BLRXPCC=$P(BLRLOG,U,3)
  1.  . S BLRSTOP=$P(BLRLOG,U,9)
  1.  . S BLRLOG=$P(BLRLOG,U,2)
  1.  . I 'BLRLOG!(BLRSTOP)!($$ERRCHK^BLRUTIL(+$H))!('BLRQDH) S BLRQFLAG="Y"  Q
  1.  . ;
  1.  . S BLRLTA=$G(^BLRSITE(BLRQSITE,20,BLRQDH,0))
  1.  . S BLRLTP=$P(BLRLTA,U,3)
  1.  . S BLRLTA=$P(BLRLTA,U,2)
  1.  . I BLRLTA>BLRLTP!(BLRQDH=+$H) S BLRQFLAG="Y"  Q
  1.  . ;
  1.  . I $H-1=BLRQDH S BLRTRY=BLRTRY+1 I BLRTRY=1 H 1 Q
  1.  . S BLRQDH=$O(^BLRSITE(BLRQSITE,20,BLRQDH)) S:'BLRQDH BLRQDH=+$H
  1.  . I $L(BLRQDH)'=5 D MAKEITSO^BLRUTIL6      ; IHS/OIT/MKK - LR*5.2*1033
  1.  . S $P(^BLRSITE(BLRQSITE,0),U,7)=BLRQDH
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1026
  1.  ;
  1.  Q:BLRSTOP
  1.  Q:$$ERRCHK^BLRUTIL(+$H)    ;IHS/ITSC/TPF 09/24/01 CHECK FOR ERRORS OVER OVERFLOW LIMIT
  1.  I BLRLOG F BLRLTP=BLRLTP+1:1:BLRLTA S BLRX=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,0)),BLRHCNT=0 D:BLRX'="" CTL1
  1.  K BLRMOD
  1.  I BLRLOG,BLRQDH<+$H Q
  1.  I BLRXPCC D ^BLRNLINK
  1.  Q
  1.  ;
  1. CTL1 ; EP
  1.  ; Wait 60 seconds to finish setting data, if not done (something's wrong!) proceed to next queue entry.
  1.  F BLRI=1:1:60 Q:$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"C"))  H 1
  1.  ;
  1.  I BLRI=60,'$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"C")) S $P(^BLRSITE(BLRQSITE,20,BLRQDH,0),U,3)=BLRLTP K BLR Q
  1.  S BLRDIR=1,BLROKCK="CKORD",BLRBADCK="",BLRRSTAG="",BLRERR=0
  1.  ;
  1.  S BLRCMF=$P(BLRX,U),BLRPHASE=$P(BLRX,U,2),BLROPT=$P(BLRX,U,3),BLRPARAM=$P(BLRX,U,4),BLRIDS=$P(BLRX,U,5),BLRDUZ2=$P(BLRX,U,6),BLRDUZ=$P(BLRX,U,7),BLR("DUZ(2)")=BLRDUZ2,BLR("STATUS FLAG")=BLRPHASE
  1.  ;
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1026
  1.  D @$S(BLRPHASE="O":"ORDER",BLRPHASE="A":"ACCESSN",BLRPHASE="D":"DELETE^BLRTNDEL",BLRPHASE="R":"RESULT^BLRTNRES",1:"DEFAULT")
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1026
  1.  ;
  1.  S $P(^BLRSITE(BLRQSITE,20,BLRQDH,0),U,3)=BLRLTP
  1.  K BLR
  1.  Q
  1.  ;
  1. ORDER ; EP
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS -- DELACC needs to be filtered also
  1.  Q:"^^MULTI^ACCWARD^BYPASS^DELACC^FASTORD^"[(U_BLROPT_U)
  1.  ;----- END IHS MODIFICATIONS LR*5.2*1018 IHS -- DELACC needs to be filtered also
  1.  S BLRODT=$P(BLRIDS,","),BLRSEQ=$P(BLRIDS,",",2)
  1.  Q:'$P($G(^LRO(69,BLRODT,1,BLRSEQ,1)),U)
  1.  ; S ^BLRENTRY("BLROPT",BLROPT)=""
  1.  S BLRCRSBS="""AOT"",BLRODTM,BLRSEQ,BLRTEST1",BLRDIR=1,BLROKCK="CKORD",BLRBADCK=""
  1.  I BLROPT="ADDCOL" D MODSET Q
  1.  I BLROPT="ADDORD" M BLRTSTS=^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTSTS")
  1.  ; D ORDVRS,UPDTNS
  1.  D ORDVRS^BLRTNRES,UPDTNS    ; IHS/OIT/MKK - Patch 1026 Modification
  1.  K BLRTSTS
  1.  Q
  1.  ;
  1. ACCESSN ; EP
  1.  Q:"^BYPASS^"[(U_BLROPT_U)
  1.  S BLRODT=$P(BLRIDS,","),BLRSEQ=$P(BLRIDS,",",2),BLRAA=$P(BLRIDS,",",3),BLRAD=$P(BLRIDS,",",4),BLRAN=$P(BLRIDS,",",5)
  1.  S BLRCRSBS="""AOT"",BLRODTM,BLRSEQ,BLRTEST1",BLRDIR=1,BLROKCK="CKORD",BLRBADCK=""
  1.  ;
  1.  ; D ORDVRS,ACCVRS Q:BLRACCN=""
  1.  D ORDVRS^BLRTNRES,ACCVRS Q:BLRACCN=""      ; IHS/OIT/MKK - Patch 1026 Modification
  1.  I BLROPT="ADDACC" S BLRTEST=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST")) D SET1 Q
  1.  D UPDTNS
  1.  Q
  1.  ;
  1.  ;IHS/ITSC/TPF 10/25/02 GET 'SIGN OR SYMPTOM' LAB POV **1015**
  1. GETDIAG(TEST) ; EP
  1.  N TSTIEN
  1.  Q:$G(TEST)=""  ;
  1.  S TSTIEN=$O(^LRO(69,BLRODT,1,BLRSEQ,2,"B",TEST,""))
  1.  Q:TSTIEN=""
  1.  S (BLRDIAG,BLR("SIGN OR SYMPTOM"))=$G(^LRO(69,BLRODT,1,BLRSEQ,2,TSTIEN,9999999))
  1.  K:BLRDIAG="" BLR("SIGN OR SYMPTOM")
  1.  K TSTIEN
  1.  Q
  1.  ;
  1. DEFAULT ; EP
  1.  I BLRPHASE="REFILE" D
  1.  . S BLRX=$P($G(^BLRSITE(BLRQSITE,21,BLRQDH,0)),U,2)+1
  1.  . S $P(^BLRSITE(BLRQSITE,21,BLRQDH,0),U,2)=BLRX
  1.  . S ^BLRSITE(BLRQSITE,21,BLRQDH,BLRX)=BLRIDS
  1.  Q
  1.  ;
  1. ACCVRS ; EP
  1.  S BLRACCN=$G(^LRO(68,BLRAA,1,BLRAD,1,BLRAN,.2)),BLR("ACCESSION NUMBER")=BLRACCN
  1.  S BLR("VERIFIER POINTER")=""
  1.  Q
  1.  ;
  1. MODSET ; EP
  1.  S BLRPSN=^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRPSN"),BLROAOT=$P($G(^LRO(69,BLRODT,1,BLRPSN,0)),U,5),BLRODTM=BLROAOT
  1.  S BLRCTST=0 F  S BLRCTST=$O(^BLRTXLOG("AOT",BLRODTM,BLRSEQ,BLRCTST)) Q:'BLRCTST  D
  1.  .I $D(^BLRTXLOG("AOT",BLROAOT,BLRPSN,BLRCTST)) S BLRPHASE="D"
  1.  .S BLRTEST1=BLRCTST,BLR("SEQUENCE NUMBER")=$$GETIEN Q:BLRERR  S BLR("STATUS FLAG")=BLRPHASE
  1.  .S BLR("ORDER DATE")=$P($G(^LRO(69,BLRODT,1,BLRPSN,0)),U,5),BLR("ORDER SEQUENCE NUMBER")=BLRPSN,BLR("ORDER NUMBER")=$G(^LRO(69,BLRODT,1,BLRPSN,.1))
  1.  .D ^BLRNFLTL
  1.  .S BLRPHASE="O"
  1.  K BLRCTST,BLROAOT,BLRPSN
  1.  Q
  1.  ;
  1. UPDTNS ; EP
  1.  S BLRTST=0 F  S BLRTST=$O(^LRO(69,BLRODT,1,BLRSEQ,2,BLRTST)) Q:'BLRTST  D
  1.  .S BLRX=$G(^LRO(69,BLRODT,1,BLRSEQ,2,BLRTST,0)),BLRTEST=+BLRX I BLRPHASE="O",BLROPT="ADDORD",'$D(BLRTSTS(BLRTEST)) Q
  1.  .D GETDIAG(BLRTST)
  1.  .I BLRPHASE="A" D  Q
  1.  ..I BLRAD=$P(BLRX,U,3),BLRAA=$P(BLRX,U,4),BLRAN=$P(BLRX,U,5) D SET1 Q
  1.  .D SET1
  1.  Q
  1.  ;
  1.  ; This module will update the transaction for a given test, plus all
  1.  ; of its descendents' transactions. ie (subpanels, atomic tests)
  1.  ; Input - BLRTEST
  1. SET1 ; EP
  1.  S BLRLEV=1,BLRCPTL=10000,BLRTEST1=BLRTEST,BLRLEV(1)=BLRTEST,BLRLEV(1,1)="",BLRPAR="",BLRATOM=0 D SET3
  1.  F  D SET2 Q:'BLRLEV
  1.  K BLRLEV,BLRPAR
  1.  Q
  1.  ;
  1. SET2 ; EP
  1.  S BLRATOM=$O(^LAB(60,BLRLEV(BLRLEV),2,0))="" I BLRATOM,BLRLEV=1 S BLRLEV=0 Q
  1.  S:'BLRATOM BLRLEV=BLRLEV+1 S BLRLEV(BLRLEV,0)=$O(^LAB(60,BLRLEV(BLRLEV-1),2,$G(BLRLEV(BLRLEV,0),0)))
  1.  I BLRLEV(BLRLEV,0) S BLRTEST1=+^LAB(60,BLRLEV(BLRLEV-1),2,$G(BLRLEV(BLRLEV,0),0),0),BLRLEV(BLRLEV)=BLRTEST1 D SET3 Q
  1.  S BLRLEV(BLRLEV,0)=0,BLRLEV=BLRLEV-2
  1.  Q
  1.  ;
  1. SET3 ; EP
  1.  S BLRATOM=$O(^LAB(60,BLRTEST1,2,0))="",BLRL60=$G(^LAB(60,BLRTEST1,0)),BLRCST=$P(BLRL60,U,11),BLRMOD=$P(BLRL60,U,4)
  1.  S BLRCPTS="",BLRCPTP="" I BLRLEV=1,BLRCMF="C" D CPTCODE
  1.  S BLRSTR1="",BLRSPEC=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRSPEC"))
  1.  ; I BLRCMF="C",BLROPT="RECCOL"!(BLROPT="ITMCOL") S BLRSPEC=$P($G(^LRO(68,BLRAA,1,BLRAD,1,BLRAN,5,1,0)),U)
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
  1.  I BLRCMF="C",BLROPT="RECCOL"!(BLROPT="ITMCOL") D
  1.  . ; Ensure the BLRAA, BLRAD, and BLRAN variables exist BEFORE they're used
  1.  . I +$G(BLRAA)<1!(+$G(BLRAD)<1)!(+$G(BLRAN)<1) S BLRAD=$P(BLRX,U,3),BLRAA=$P(BLRX,U,4),BLRAN=$P(BLRX,U,5)
  1.  . ;
  1.  . S BLRSPEC=$P($G(^LRO(68,+BLRAA,1,+BLRAD,1,+BLRAN,5,1,0)),U)
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1038
  1.  ; 
  1.  I BLRCMF="C",BLRSPEC'="" D SET4
  1.  S BLR("CPT LAB CODE POINTER")=BLRCPTP,BLR("BILLING CPT STRING")=BLRCPTS,BLR("PANEL/TEST POINTER")=BLRTEST1,BLR("LAB TEST LIST COST")=BLRCST,BLR("LAB MODULE")=BLRMOD
  1.  S BLR("SEQUENCE NUMBER")=$$GETIEN() Q:BLRERR
  1.  I BLRCMF="C" S BLR("PARENT POINTER")=BLRLEV(BLRLEV,1) S:'BLRATOM BLRPAR=BLR("SEQUENCE NUMBER")
  1.  ;
  1.  D:BLRRSTAG'="" @BLRRSTAG
  1.  D LOINC
  1.  D ^BLRNFLTL           ;UPDATE TRANSACTION LOG
  1.  D:BLRPHASE="R" CRSFLDS
  1.  I 'BLRATOM,BLRCMF="C" S BLRLEV(BLRLEV+1,1)=BLRPAR
  1.  Q
  1.  ;
  1. SET4 ; EP
  1.  ;[LR*5.2*1028;08/20/10;IHS/OIT/MPW]I $D(^LAB(60,BLRTEST1,1,BLRSPEC)) S BLRZ=$G(^LAB(60,BLRTEST1,1,BLRSPEC,0)),BLRUNITS=$P($P(BLRZ,U,7)," ",1),BLR("SITE/SPECIMEN POINTER")=BLRSPEC,BLR("UNITS")=BLRUNITS Q
  1.  I $D(^LAB(60,BLRTEST1,1,BLRSPEC)) D  Q
  1.  .S BLRZ=$G(^LAB(60,BLRTEST1,1,BLRSPEC,0)),BLRUNITS=$P($P(BLRZ,U,7)," ",1)
  1.  .I BLRUNITS=+BLRUNITS,$D(^BLRUCUM(BLRUNITS,0)) S BLRUNITS=$P($G(^BLRUCUM(BLRUNITS,0)),U,1)
  1.  .S BLR("SITE/SPECIMEN POINTER")=BLRSPEC,BLR("UNITS")=BLRUNITS Q
  1.  .Q
  1.  S BLR("SITE/SPECIMEN POINTER")=BLRSPEC
  1.  Q
  1.  ;
  1. CPTCODE ; EP - Entry point
  1.  ; S BLRFOUND=0,(BLRXII,BLRCPTS,BLRCPTP)="" F  S BLRXII=$O(^BLRCPT("C",BLRTEST1,BLRXII)) Q:(BLRXII="")  I '$P($G(^BLRCPT(BLRXII,1)),U,2) D GETCPT Q:BLRFOUND
  1.  S BLRFOUND=0,(BLRXII,BLRCPTS,BLRCPTP)="" F  S BLRXII=$O(^BLRCPT("C",BLRTEST1,BLRXII)) Q:(BLRXII="")  I '$P($G(^BLRCPT(BLRXII,1)),U,2) D GETCPT^BLRTNCON  Q:BLRFOUND  ; IHS/MSC/MKK - LR*5.2*1038
  1.  Q
  1.  ;
  1. GETCPT ; EP
  1.  Q:BLRODTM<$P($G(^BLRCPT(BLRXII,0)),U,3)
  1.  S BLRFOUND=1,BLRCPTP=BLRXII
  1.  S BLRCPTN=0 F BLRNN=1:1 S BLRCPTN=$O(^BLRCPT(BLRXII,11,BLRCPTN)) Q:'BLRCPTN  S BLRCPDAT=$G(^BLRCPT(BLRXII,11,BLRCPTN,0)),BLRCPCD=$P(BLRCPDAT,U),BLRCPCST=$P(BLRCPDAT,U,2),BLRCPRC=$P(BLRCPDAT,U,3),BLRCPACT=$P(BLRCPDAT,U,4) D
  1.  .S (BLRCPTM,BLRCPTQ)=""
  1.  .S BLRCPMN=0 F BLRNN1=1:1 S BLRCPMN=$O(^BLRCPT(BLRXII,11,BLRCPTN,1,BLRCPMN)) Q:'BLRCPMN  S:BLRNN1>1 BLRCPTM=BLRCPTM_"," S BLRCPTM=BLRCPTM_$G(^BLRCPT(BLRXII,11,BLRCPTN,1,BLRCPMN,0))
  1.  .S BLRCPQN=0 F BLRNN1=1:1 S BLRCPQN=$O(^BLRCPT(BLRXII,11,BLRCPTN,2,BLRCPQN)) Q:'BLRCPQN  S:BLRNN1>1 BLRCPTQ=BLRCPTQ_"," S BLRCPTQ=BLRCPTQ_$G(^BLRCPT(BLRXII,11,BLRCPTN,2,BLRCPQN,0))
  1.  .S:BLRNN>1 BLRCPTS=BLRCPTS_";" S BLRCPTS=BLRCPTS_BLRCPCD_"|"_BLRCPCST_"|"_BLRCPRC_"|"_BLRCPACT_"|"_BLRCPTM_"|"_BLRCPTQ
  1.  ;
  1.  K BLRCPCD,BLRCPCST,BLRCPRC,BLRCPACT,BLRCPTN,BLRCPDAT,BLRCPTM,BLRCPMN,BLRCPTQ,BLRCPQN,BLRNN,BLRNN1
  1.  Q
  1.  ;
  1. RESVRS ; EP
  1.  S BLRCREF=$P(BLRL60,U,5)
  1.  I BLRSS=$P(BLRCREF,";"),$D(BLRRVS($P(BLRCREF,";",2))) S BLRRES=BLRRVS($P(BLRCREF,";",2)),BLRNAF=$P(BLRRES,U,2),BLRDUZ=$P(BLRRES,U,4),BLRRES=$P(BLRRES,U) D RES1
  1.  Q
  1.  ;
  1. RES1 ; EP
  1.  I BLRCMF'="C" S BLRDEL=$P($G(^BLRTXLOG(BLR("SEQUENCE NUMBER"),1)),U,2)="D" Q:BLRDEL
  1.  ;IF ERRORS OCCUR HERE BECAUSE OF SEX OR AGE UNDEF. SEE REFERENCE RANGE
  1.  I BLRSPEC'="" S BLRZ=$G(^LAB(60,BLRTEST1,1,BLRSPEC,0)) I BLRZ'="" D
  1.  .S BLRRL=$P(BLRZ,U,2),BLRRH=$P(BLRZ,U,3),BLRUNITS=$P($P(BLRZ,U,7)," ")
  1.  .;[LR*5.2*1028;08/20/10;IHS/OIT/MPW]Added next 1 line
  1.  .I BLRUNITS=+BLRUNITS,$D(^BLRUCUM(BLRUNITS,0)) S BLRUNITS=$P($G(^BLRUCUM(BLRUNITS,0)),U,1)
  1.  .S:$D(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"AGE")) AGE=$G(^("AGE"))
  1.  .S:$D(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"SEX")) SEX=$G(^("SEX"))
  1.  .X:BLRRH'?.N "S BLRRH="_BLRRH X:BLRRL'?.N "S BLRRL="_BLRRL
  1.  .S BLR("UNITS")=BLRUNITS,BLR("REFERENCE HIGH")=BLRRH,BLR("REFERENCE LOW")=BLRRL
  1.  .K AGE,SEX
  1.  .D LOINC
  1.  S BLR("RESULT")=BLRRES,BLR("RESULT N/A FLAG")=BLRNAF,BLR("STATUS FLAG")=$S(BLRRES'="":"R",1:"A")
  1.  S:$G(BLRDUZ)="" BLRDUZ=DUZ
  1.  S BLRDUZN=$S($D(^VA(200,BLRDUZ,0)):$P(^(0),U,1),1:"UNK"_BLRDUZ)
  1.  S BLR("VERIFIER POINTER")=BLRDUZ
  1.  Q
  1.  ;
  1. CRSFLDS ; EP
  1.  K BLR("REFERENCE HIGH"),BLR("REFERENCE LOW"),BLR("RESULT"),BLR("RESULT N/A FLAG")
  1.  S BLR("STATUS FLAG")="A"  ;IHS/ITSC/TPF 10/02/01 ALONG WITH CHNAGE IN LRVER3A+55 FIXES DUPLICATE ENTRIES IN LOG
  1.  Q
  1.  ;
  1. GETIEN() ; EP
  1.  S BLRERR=0 D
  1.  .I BLRCMF="C" D GETNEW Q
  1.  .S BLRCRGL="^BLRTXLOG("_BLRCRSBS_")",BLRENT=$O(@BLRCRGL@(""),BLRDIR)
  1.  .;
  1.  .S:'BLRENT BLRERR=1
  1.  .I BLRENT,BLROKCK'="" D @BLROKCK
  1.  .I 'BLRERR,BLRBADCK'="" D @BLRBADCK
  1.  .I BLRERR D EMSG Q
  1.  .S BLRIEN=BLRENT_"," Q
  1.  Q BLRENT
  1.  ;
  1. CHKDT ; EP
  1.  D:'BLRENT EMSG Q:BLRERR
  1.  S BLRCDT=$P(^BLRTXLOG(BLRENT,12),U)
  1.  I $E(BLRCDT,1,3)=$E(DT,1,3) S BLRIEN=BLRENT_"," Q
  1.  I ($E(BLRCDT,1,3)+1)'=$E(DT,1,3) S BLRERR=1,BLRDTER=1 Q  ;MORE THAN 1 YEAR AHEAD
  1.  I $E(BLRCDT,4,5)<11 S BLRERR=1,BLRDTER=1 Q
  1.  S BLRIEN=BLRENT_"," Q
  1.  Q
  1. EMSG ; EP
  1.  ; Log an error because the crossreference isn't set.
  1.  I 'BLRENT D
  1.  .S BLRERR=1,BLRERROR(1)="Something wrong -- problem with IHS Lab Transaction Log Cross Reference: "_BLRCRGL
  1.  Q
  1.  ;
  1. CKORD ; EP
  1.  S BLRERR=1
  1.  F  D  Q:'BLRENT!'BLRERR
  1.  .S BLRENT1=BLRENT F  Q:'$P(^BLRTXLOG(BLRENT1,1),U)  S BLRENT1=$P(^BLRTXLOG(BLRENT1,1),U)
  1.  .D  Q:'BLRERR
  1.  ..I $D(LRAN) D  Q
  1.  ...I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$P(^BLRTXLOG(BLRENT1,0),U,6))) S BLRERR=0 Q
  1.  ..I $D(^LRO(69,BLRODTM,1,BLRSEQ,2,"B",$P(^BLRTXLOG(BLRENT1,0),U,6))) S BLRERR=0 Q
  1.  .S BLRENT=$O(@BLRCRGL@(BLRENT),BLRDIR)
  1.  K BLRENT1
  1.  Q
  1.  ;
  1. GETNEW ; EP
  1.  S BLRENT=$G(^BLRTXLOG("SEQ"))
  1.  I 'BLRENT S BLRENT=$O(^BLRTXLOG("@"),-1) I BLRENT,'$D(^BLRTXLOG(1)) S BLRENT=0
  1.  F BLRENT=BLRENT+1:1 Q:'$D(^BLRTXLOG(BLRENT))
  1.  S BLRENTS="BLRENTS",BLRENTS(1)=BLRENT,^BLRTXLOG("SEQ")=BLRENT,BLRIEN="+1,"
  1.  Q
  1.  ;
  1. KILL ; EP
  1.  K BLR,BLRARRAY,BLREMSG,BLRENTS,BLRERR,BLRERROR,BLRFDA,BLRI,BLRICNT,BLRIEN,BLRIENS,BLRIII,BLRLOGDA,BLRQUIET,BLRSFID,BLRSIEN,BLRSTOP,BLRT,BLRTCNT,BLRVL,BLRVR,BLRVRS
  1.  K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,BLRESTR,BLRPT,BLRXQY0,BLRPC,BLRMI,BLRDTER
  1.  Q
  1.  ;THE FOLLOWING CODE SETS UP FIELDS ADDED FOR THE LOINC PROJECT
  1. LOINC ; EP
  1.  ;FOLLOWING LINES ADDED FOR LOINC PROJECT ;ITSC/TPF 2/26/02
  1.  S:$G(BLRSS)="" BLRSS=$P($G(^LRO(68,$G(BLRAA,"UNDEF"),0)),U,2)
  1.  Q:'$G(BLRTEST1)!'$G(BLRAA)!'$G(BLRAD)!'$G(BLRAN)!'$G(BLRLRDFN)!($G(BLRSS)="")
  1.  S BLR("SITE/SPECIMEN POINTER")=$P($G(^LRO(68,BLRAA,1,BLRAD,1,BLRAN,5,1,0)),U)  ;SITE/SPECIMEN
  1.  ;
  1.  D GETDIAG($S($G(BLRTEST1)'="":BLRTEST1,1:BLRTEST))  ;IHS/ITSC/TPF 10/25/02 'SIGN OR SYMPTOM' LAB POV **1015** ADDED BLRTEST1 TO CHECK FOR BB TESTS
  1.  S:$G(BLRDTC)="" BLRDTC=$P($G(^LRO(69,BLRODT,1,BLRSEQ,1)),U)
  1.  ;
  1.  S BLR("COMPLETE DATE")=$P($G(^LR(BLRLRDFN,BLRSS,9999999-BLRDTC,0)),U,3)
  1.  I $G(BLR("COMPLETE DATE"))="" S BLR("COMPLETE DATE")=$$COMPDATE(BLRLRDFN,BLRSS,9999999-BLRDTC,BLRSS)
  1.  S (SPEC,BLR("COLLECTION SAMPLE POINTER"))=$P($G(^LRO(68,BLRAA,1,BLRAD,1,BLRAN,5,1,0)),U,2)  ;COLLECTION SAMPLE  
  1.  S:$G(BLR("SITE/SPECIMEN POINTER")) (LOINC,BLR("LOINC CODE"))=$P($G(^LAB(60,BLRTEST1,1,BLR("SITE/SPECIMEN POINTER"),95.3)),U)
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
  1.  NEW IHSLOINC
  1.  S IHSLOINC=$$GET1^DIQ(60,BLRTEST1,"IHS LOINC","I")
  1.  Q:$L(IHSLOINC)<1
  1.  ;
  1.  S:$L($G(LOINC))<1 LOINC=IHSLOINC
  1.  S BLR("IHS LOINC")=IHSLOINC
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1038
  1.  ;
  1.  ;END CODE FOR LOINC PROJECT
  1.  Q
  1.  ;complete date from lab order entry and entry in lab test file do not
  1.  ;necessarily match
  1. COMPDATE(BLRLRDFN,BLRSS,BLRDTC,BLRACCN) ; EP
  1.  N SDATE,CDATE
  1.  S SDATE=BLRDTC
  1.  ;
  1.  I $D(^LR(BLRLRDFN,BLRSS,BLRDTC,0)) S TARACC=$P($G(^LR(BLRLRDFN,BLRSS,BLRDTC,0)),U,6)=BLRACCN I TARACC S CDATE=$P($G(^LR(BLRLRDFN,BLRSS,BLRDTC,0)),U,3)
  1.  ;GO FORWARD 
  1.  I $G(CDATE)="" D
  1.  .F  S SDATE=$O(^LR(BLRLRDFN,BLRSS,SDATE)) Q:+SDATE=0  I SDATE'="" S TARACC=$P($G(^LR(BLRLRDFN,BLRSS,SDATE,0)),U,6)=BLRACCN I TARACC S CDATE=$P($G(^LR(BLRLRDFN,BLRSS,SDATE,0)),U,3)
  1.  ;GO BACKWARD 
  1.  I $G(CDATE)="" D
  1.  .F  S SDATE=$O(^LR(BLRLRDFN,BLRSS,SDATE),-1) Q:+SDATE=0  I SDATE'="" S TARACC=$P($G(^LR(BLRLRDFN,BLRSS,SDATE,0)),U,6)=BLRACCN I TARACC S CDATE=$P($G(^LR(BLRLRDFN,BLRSS,SDATE,0)),U,3)
  1.  K SDATE
  1.  Q $G(CDATE)
  1.  ;