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