BLREVTQ(BLRCMF,BLRPHASE,BLROPT,BLRPARAM,BLRIDS) ; IHS/HQT/MJL - EVENT SET QUE TO UPDATE LAB/PCC TRANSACTION ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1010,1011,1013,1015,1018,1021,1027,1033**;NOV 01, 1997
CTL ;
D:$G(BLROPTS)="" RSBLROPT ; IHS/OIT/MKK - LR*5.2*1033
;
Q:$P($G(^BLRSITE(DUZ(2),0)),U,2)=0
S BLRDH=+$H,BLRPHASE=$G(BLRPHASE)
S BLROPT=$G(BLROPT)
S:'$D(BLRQSITE) BLRQSITE=$P($G(^AUTTSITE(1,0)),U)
;
; L +^BLRSITE(BLRQSITE,20,BLRDH):2
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033
LOCKIT ; EP
L +^BLRSITE(BLRQSITE,20,BLRDH):5 I '$T H 5 G LOCKIT
; ----- END IHS/OIT/MKK - LR*5.2*1033
;
S BLRQUE=$P($G(^BLRSITE(BLRQSITE,20,BLRDH,0)),U,2)+1
S $P(^BLRSITE(BLRQSITE,20,BLRDH,0),U,2)=BLRQUE
S:BLRQUE=1 $P(^BLRSITE(BLRQSITE,20,BLRDH,0),U)=DT
L -^BLRSITE(BLRQSITE,20,BLRDH)
;
S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,0)=$G(BLRCMF)_U_$G(BLRPHASE)_U_$G(BLROPT)_U_$G(BLRPARAM)_U_$G(BLRIDS)_U_$G(DUZ(2))_U_$G(DUZ)
S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"C")=0 ;ENTRY INCOMPLETE
D SETDATA
S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"C")=1 ;ENTRY COMPLETE
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1021 - cmi/anch/maw REF LAB
D ACC^BLRRLEVT ;cmi/maw 11/5/2007 moved for lr p23
;D ACC ;cmi/maw added for ref lab
;----- END IHS MODIFICATIONS LR*5.2*1021 - cmi/anch/maw end REF LAB
;
Q
;
;SET UP THE EVENT IN THE 'BLR MASTER CONTROL' FILE
SETDATA ;
I BLROPT="ADDORD",$D(BLRTSTS) M ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTSTS")=BLRTSTS Q
;
I BLROPT="ADDACC" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=+$G(LRTS,$G(LRTSTS))
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033
; Moved code to separate subroutines. See below.
I BLRPHASE="R" D RESULTS Q ; IHS/OIT/MKK - LR*5.2*1033 - RESULTS BEING ENTERED
;
I BLRPHASE="D" D DELETION Q ; IHS/OIT/MKK - LR*5.2*1033 - DELETION PHASE
; ----- END IHS/OIT/MKK - LR*5.2*1033
;
I BLROPT="ADDCOL" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRPSN")=$G(LRPSN,$G(LRSN))
;
Q
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1021
ACC ;EP - cmi/flag/maw added the following for ref lab accessions
;cmi/anch/maw REF LAB
;Q
;
I BLRPHASE="O" D ;cmi/maw 5/30/2007 added for institution entry of file 44 so that it gets correct accession area from file 60 otherwise it gets duz(2)
. Q:'$G(LROLLOC)
. Q:'$P($G(^SC(LROLLOC,0)),U,4)
. S BLRALTDZ=$P($G(^SC(LROLLOC,0)),U,4)
. Q:'+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
. S LRDUZ(2)=BLRALTDZ
Q:BLRPHASE'="A" ;quit if not an accession
;
K BLRRL,BLRRLC ;kill off existing BLRRL array
S BLRRL("LRTS")=$S(+$G(LRTS):+LRTS,1:$G(LRTSORU))
Q:$G(BLRRL("LRTS"))="" ;1/23/2006 don't proceed without a test
;
;cmi/anch/maw 2/24/2006 added look for LRPHMAN before asking for comments
;cmi/anch/maw 2/28/2006 added AAA tag for allowing edit of ask at accession questions
AAA I '$O(BLRRLC(0)),$P($G(XQY0),U)'="LRPHMAN" S BLRRLSUC=$$COM^BLRRLCOM(BLRRL("LRTS")) ;cmi/anch/maw modified due to routine collect no LRTS 9/8/2004
I $O(BLRRLC(0)) D
. S DIR(0)="Y",DIR("A")="Are the responses to the Ask At Accession questions correct "
. S DIR("B")="Y"
. D ^DIR
. I '$G(Y) D G AAA
.. D DISAAQ(.BLRCNT,BLRRL("LRTS"),.BLRRLC)
;cmi/anch/maw 2/28/2005 end of mods
;I '$O(BLRRLC(0)) S BLRRLSUC=$$COM^BLRRLCOM(+LRTS) maw orig 9/8/2004
Q:$G(BLRRL("LRTS"))="" ;1/23/2006 don't proceed without a test
S BLRRL("LOCI")=$G(LROLLOC) ;cmi/maw 5/29/2007 added for internal location pointer to file 44
S BLRRL("ALTDUZ2")=$G(BLRALTDZ) ;cmi/maw 5/29/2007 setup alternate duz2 if they select the prompt in blrsite to look at ordering location
I $G(BLRALTDZ),$P($G(^BLRSITE(BLRALTDZ,"RL")),U,10)="D" K BLRALTDZ,BLRRL("ALTDUZ2") ;don't need variables if they use a true multidivisional site
I $G(BLRALTDZ),$P($G(^BLRSITE(BLRALTDZ,"RL")),U,10)="" K BLRALTDZ,BLRRL("ALTDUZ2") ;don't need variables if they use a true multidivisional site
S BLRRL("RL")=+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")) ;ref lab site maw modified 5/29/2007
Q:'BLRRL("RL")
S BLRRL("BI")=$P($G(^BLRRL(BLRRL("RL"),0)),U,10) ;bi or unidirectional
S BLRRL("RLE")=$P($G(^BLRRL(BLRRL("RL"),0)),U) ;get external name
;cmi/anch/maw 3/3/2006 lets try this for account number
S BLRRL("CLIENT")=$O(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RLCA","B",""))
I $G(BLRRL("CLIENT"))="" S BLRRL("CLIENT")=$P($G(^BLRRL(BLRRL("RL"),0)),U,13)
;cmi/anch/maw 3/3/2006 end of mods
I $G(BLRRL("BI")) Q:$P($G(^BLRRL(BLRRL("RL"),0)),U,6)="" ;no orders 5/31/06
S BLRRL("PAT")=$G(DFN) ;patient
S BLRRL("ACC")=$G(LRACC) ;accession number
S BLRRL("UID")=$G(LRUID) ;unique id
S BLRRL("CDT")=$G(LRCDT) ;collection date
S BLRRL("ACCA")=$P(BLRRL("ACC")," ") ;get accession abbreviation
Q:$G(BLRRL("ACCA"))=""
S BLR("ACCAREA")=$O(^LRO(68,"B",BLRRL("ACCA"),0)) ;get ien of accession area
Q:BLR("ACCAREA")="" ;don't proceed if not an SO area
Q:'$D(^BLRRL("ACC",BLR("ACCAREA"),BLRRL("RL"))) ;quit when not a sendout area
S BLRRL("ORDPRV")=$G(LRPRAC) ;ordering provider
;the following must be setup in an array for GIS software
;do something here to check for mult tests under ac #
;or each acc # unique
S (BLRTSTDA,BLRRL("TSTDA"))=+$G(LRTS)
K BLRRL(BLRTSTDA) ;kill off array from previous accession
K BLRRL("ORDPUPIN"),BLRRL("ORDPNM") ;maw 5/10/06
I BLRRL("ORDPRV")]"" D ;setup provider array
. S BLRRL("ORDPUPIN")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),9999999.08) ;maw 5/10/06
. S BLRRL("ORDPNM")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),.01)
. S BLRRL("ORDPNM")=$P(BLRRL("ORDPNM"),",")_"^"_$P($P(BLRRL("ORDPNM"),",",2)," ")
. S BLRRL(BLRTSTDA,"ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM")
. S BLRRL("ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM")
S BLRTSTI=+$G(LRTS) ;get test ien
Q:'$D(^LAB(60,BLRTSTI,8,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)) ;quit if no accession area
S BLRAREA=$P($G(^LAB(60,BLRTSTI,8,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U,2) ;get acc area
Q:BLRAREA="" ;quit if accession area field is null
Q:BLRAREA'=BLR("ACCAREA") ;quit if test acc area is not SO area
S BLRRL(BLRTSTDA,"CDT")=$G(LRCDT) ;collection date
S BLRRL("TNAME")=$P($G(^LAB(60,BLRTSTI,0)),U) ;get test name
S BLRRL("ABBR")=$P($G(^LRO(68,BLRAREA,0)),U,11) ;get area abbr
S BLRRL("TST")=BLRTSTI ;get test ien
S BLRRL("TCODE")=$$CODE(BLRRL("RL"),BLRRL("TST")) ;lookup test code
I $G(BLRRL("TCODE"))=0 K BLRRL(BLRTSTDA) Q ;quit if no test code
S BLRRL(BLRTSTDA,"ACC")=$G(LRACC) ;setup acc array for OBR
S BLRRL(BLRTSTDA,"UID")=$G(LRUID)
S BLRRL("TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME") ;test arry
S BLRRL(BLRTSTDA,"TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME") ;test arry
S BLRRL("URG")=$G(LRURG)
S BLRRL("LOC")=$G(LRLLOC)
S BLRRL("ODT")=$G(LRODT)
S BLRRL(BLRTSTDA,"SAMP")=$G(LRSAMP)
S BLRRL("SAMP")=$G(LRSAMP)
S BLRRL(BLRTSTDA,"SRC")=$G(LRSPEC)
S BLRRL("SRC")=$G(LRSPEC)
I $G(LRSPEC) S (BLRRL(BLRTSTDA,"SRC"),BLRRL("SRC"))=$P($G(^LAB(61,LRSPEC,0)),U)
S BLRRL("ORD")=$G(LRORD)
S BLRRL(BLRTSTDA,"ORD")=$G(LRORD)
S BLRCM=0 F S BLRCM=$O(BLRRLC(BLRTSTDA,BLRCM)) Q:'BLRCM D
. S BLRRL(BLRTSTDA,"COMMENT",BLRCM)=$G(BLRRLC(BLRTSTDA,BLRCM))
. S BLRRL("COMMENT",BLRCM)=$G(BLRRLC(BLRTSTDA,BLRCM))
;cmi/maw 10/31/07 ask what type of billing here
;S DIR(0)="S^C:Client;T^Third Party;P:Patient"
;S DIR("A")="Which Party is Responsible for Billing: "
;S DIR("B")="Client"
;D ^DIR
;S BLRRL("BILL TYPE")=Y
;I $D(DIRUT) S BLRRL("BILL TYPE")="Client"
;K DIR
;cmi/maw 10/31/07 end of mods
D TMPSET(.BLRRL)
I $P($G(XQY0),U)="LRPHMAN" D ;cmi/anch/maw added for ward collection list 2/23/2006
. D PRT^BLRSHPM
S X="BLR REFLAB ACCESSION A TEST",DIC=101 D EN^XQOR ;call accession protocol
K BLRRL,BLRRLC(BLRTSTDA),LRTEST
Q
;
TMPSET(BLRSHP) ;-- setup the array for the shipping manifest
N BLRDA,BLRDATA
S BLRDA=0 F S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA="" D
. Q:BLRDA?.N
. ;cmi/anch/maw 7/24/2007 right here you could store by order number if passed in at the top
. S BLRDATA=$G(BLRSHP(BLRDA))
. I '$D(^TMP("BLRRL",$J,BLRDA)) S ^TMP("BLRRL",$J,"COMMON",BLRDA)=BLRDATA
N BLRDA,BLRDATA,BLRIEN
S BLRDA=0 F S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA="" D
. Q:BLRDA'?.N
. S BLRIEN=0 F S BLRIEN=$O(BLRSHP(BLRDA,BLRIEN)) Q:BLRIEN="" D
.. Q:BLRIEN="COMMENT"
.. S BLRDATA=$G(BLRSHP(BLRDA,BLRIEN))
.. I '$D(^TMP("BLRRL",$J,BLRDA,BLRIEN)) S ^TMP("BLRRL",$J,BLRDA,BLRIEN)=BLRDATA
N BLRDA,BLRIEN,BLROEN,BLRDATA
S BLRDA=0 F S BLRDA=$O(BLRSHP(BLRDA)) Q:BLRDA="" D
. Q:'BLRDA
. S BLRIEN=0 F S BLRIEN=$O(BLRSHP(BLRDA,"COMMENT",BLRIEN)) Q:'BLRIEN D
.. S BLRDATA=$G(BLRSHP(BLRDA,"COMMENT",BLRIEN))
.. I '$D(^TMP("BLRRL",$J,BLRDA,"COMMENT",BLRIEN)) S ^TMP("BLRRL",$J,BLRDA,"COMMENT",BLRIEN)=BLRDATA
Q
;
CODE(RL,TST) ;lookup the test code via prefix and test
K BLRTCODE
I '$D(^BLRRL(RL,1,0)) Q 0
S BLRRDA=0 F S BLRRDA=$O(^BLRRL("ALP",TST,RL,BLRRDA)) Q:'BLRRDA!($G(BLRTCODE)]"") D
. S BLRTCODE=$P($G(^BLRRL(RL,1,BLRRDA,0)),U,3)
. Q:$G(BLRTCODE)]""
I $G(BLRTCODE)="" Q 0
Q BLRTCODE
;cmi/anch/maw end REF LAB
;
DISAAQ(BLRCNT,TIEN,AAQ) ;-- display the ask at order questions
N A,BLRCNT
S BLRCNT=0
S A=0 F S A=$O(AAQ(TIEN,A)) Q:'A D
. S BLRCNT=BLRCNT+1
. W !,A_") ",$P(AAQ(TIEN,A),U,2),?50,$P(AAQ(TIEN,A),U,3)
W !
N RES
K DIR
S DIR(0)="N^1:"_BLRCNT
S DIR("A")="Edit Which Ask At Accession Question "
D ^DIR
Q:$D(DIRUT)
S RES=+Y
K DIR
S DIR(0)="F",DIR("A")=$P(AAQ(TIEN,RES),U,2)
S DIR("B")=$P(AAQ(TIEN,RES),U,3)
D ^DIR
Q:$D(DIRUT)
S $P(BLRRLC(TIEN,RES),U,3)=Y
Q
;
;----- END IHS MODIFICATIONS LR*5.2*1021
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
; Code moved to here to keep logic above from being obscured.
RESULTS ; EP
;M ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRCOM")=^LR(LRDFN,LRSS,9999999-$S($D(LRCDT):LRCDT,1:LRI),1)
M ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRCOM")=^LR(LRDFN,LRSS,9999999-$S($D(LRCDT):LRCDT,$D(LRI):LRI,1:LRIDT),1) ;IHS/ITSC/TPF 08/25/02 FIXED PROBLEM AT TALEQUAW **1015**
;
;AFTER MERGING THE TESTS IN, KILL THE B X-REF WE DONT NEED IT
K ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRCOM","B")
;
I $D(LRORDCOM) S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRORDCOM")=LRORDCOM
I $D(LRDFN) S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN
I $D(LRSPEC) S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRSPEC")=LRSPEC S:$D(SEX) ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"SEX")=SEX S:$D(AGE) ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"AGE")=AGE
;
I BLROPT="BBANK" D Q
. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN,^("LRCDT")=9999999-LRI,^("LRIDT")=LRI,^("BLRTEST")=LRT,^("BLRTESTN")=$P(LRT(LRT),U),^("DR")=$G(DR)
;
I BLROPT="MICRO" D Q
. ;----- BEGIN IHS MODIFICATIONS LR*5.2*1016 IHS TESTING CHANGE
. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRSAMP")=$G(LRSAMP)
. ;----- END IHS MODIFICATIONS
. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRAA")=LRAA,^("LRAD")=LRAD,^("LRAN")=LRAN,^("LRSS")=LRSS,^("LRODT")=LRODT,^("LRCDT")=LRCDT,^("LRSN")=LRSN
. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN,^("LRIDT")=LRIDT,^("BLRTEST")=$S($D(LRTS):LRTS,1:LRTEST)
. S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN,^("LRIDT")=LRIDT,^("BLRTEST")=+$S($D(LRTS):LRTS,1:LRTEST) ;IHS/ITSC/TPF 9/24/02 **1014**
;
M:$D(LRSB) ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRSB")=LRSB
;
S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRAA")=LRAA,^("LRAD")=LRAD,^("LRAN")=LRAN,^("LRSS")=LRSS,^("LRODT")=LRODT,^("LRCDT")=$G(LRCDT),^("LRSN")=LRSN
S:BLROPT="BYPASS" ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$G(LRTY,$G(LRTNUM))
S:BLROPT="ACCORD" ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$G(LRTNUM)
Q
;
DELETION ; EP
S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRODTM")=$P($S($D(LROD0):LROD0,1:^LRO(69,LRODT,1,LRSN,0)),U,5)
;I $G(BLRPARAM)["TESTS" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$P(T(J),U,3),^("LRSN")=+T(J) Q
;----- BEGIN IHS MODIFCATIONS LR*5.2*1016 IHS TESTING CHANGE
I $G(BLRPARAM)["TESTS" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$P($G(T(J)),U,3),^("LRSN")=+$G(T(J)) Q
;
I BLROPT="DELACC" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRACCN")=^LRO(68,$P(BLRIDS,","),1,$P(BLRIDS,",",2),1,$P(BLRIDS,",",3),.2),^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=LRTSTS Q
M:$D(T) ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"T")=T
;
Q
;
RSBLROPT ; EP -- Set/Reset BLROPT variable
Q:$L($G(LRACC))<1 ; If Accession null, skip
;
Q:$L($O(^BLRTXLOG("D",LRACC,0))) ; If Accession in 9009022, skip
;
; S BLROPT="BYPASS" ; Hard set BLROPT
;
Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
BLREVTQ(BLRCMF,BLRPHASE,BLROPT,BLRPARAM,BLRIDS) ; IHS/HQT/MJL - EVENT SET QUE TO UPDATE LAB/PCC TRANSACTION ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1010,1011,1013,1015,1018,1021,1027,1033**;NOV 01, 1997
CTL ;
+1 ; IHS/OIT/MKK - LR*5.2*1033
IF $GET(BLROPTS)=""
DO RSBLROPT
+2 ;
+3 IF $PIECE($GET(^BLRSITE(DUZ(2),0)),U,2)=0
QUIT
+4 SET BLRDH=+$HOROLOG
SET BLRPHASE=$GET(BLRPHASE)
+5 SET BLROPT=$GET(BLROPT)
+6 IF '$DATA(BLRQSITE)
SET BLRQSITE=$PIECE($GET(^AUTTSITE(1,0)),U)
+7 ;
+8 ; L +^BLRSITE(BLRQSITE,20,BLRDH):2
+9 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033
LOCKIT ; EP
+1 LOCK +^BLRSITE(BLRQSITE,20,BLRDH):5
IF '$TEST
HANG 5
GOTO LOCKIT
+2 ; ----- END IHS/OIT/MKK - LR*5.2*1033
+3 ;
+4 SET BLRQUE=$PIECE($GET(^BLRSITE(BLRQSITE,20,BLRDH,0)),U,2)+1
+5 SET $PIECE(^BLRSITE(BLRQSITE,20,BLRDH,0),U,2)=BLRQUE
+6 IF BLRQUE=1
SET $PIECE(^BLRSITE(BLRQSITE,20,BLRDH,0),U)=DT
+7 LOCK -^BLRSITE(BLRQSITE,20,BLRDH)
+8 ;
+9 SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,0)=$GET(BLRCMF)_U_$GET(BLRPHASE)_U_$GET(BLROPT)_U_$GET(BLRPARAM)_U_$GET(BLRIDS)_U_$GET(DUZ(2))_U_$GET(DUZ)
+10 ;ENTRY INCOMPLETE
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"C")=0
+11 DO SETDATA
+12 ;ENTRY COMPLETE
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"C")=1
+13 ;
+14 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1021 - cmi/anch/maw REF LAB
+15 ;cmi/maw 11/5/2007 moved for lr p23
DO ACC^BLRRLEVT
+16 ;D ACC ;cmi/maw added for ref lab
+17 ;----- END IHS MODIFICATIONS LR*5.2*1021 - cmi/anch/maw end REF LAB
+18 ;
+19 QUIT
+20 ;
+21 ;SET UP THE EVENT IN THE 'BLR MASTER CONTROL' FILE
SETDATA ;
+1 IF BLROPT="ADDORD"
IF $DATA(BLRTSTS)
MERGE ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTSTS")=BLRTSTS
QUIT
+2 ;
+3 IF BLROPT="ADDACC"
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=+$GET(LRTS,$GET(LRTSTS))
+4 ;
+5 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033
+6 ; Moved code to separate subroutines. See below.
+7 ; IHS/OIT/MKK - LR*5.2*1033 - RESULTS BEING ENTERED
IF BLRPHASE="R"
DO RESULTS
QUIT
+8 ;
+9 ; IHS/OIT/MKK - LR*5.2*1033 - DELETION PHASE
IF BLRPHASE="D"
DO DELETION
QUIT
+10 ; ----- END IHS/OIT/MKK - LR*5.2*1033
+11 ;
+12 IF BLROPT="ADDCOL"
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRPSN")=$GET(LRPSN,$GET(LRSN))
+13 ;
+14 QUIT
+15 ;
+16 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1021
ACC ;EP - cmi/flag/maw added the following for ref lab accessions
+1 ;cmi/anch/maw REF LAB
+2 ;Q
+3 ;
+4 ;cmi/maw 5/30/2007 added for institution entry of file 44 so that it gets correct accession area from file 60 otherwise it gets duz(2)
IF BLRPHASE="O"
Begin DoDot:1
+5 IF '$GET(LROLLOC)
QUIT
+6 IF '$PIECE($GET(^SC(LROLLOC,0)),U,4)
QUIT
+7 SET BLRALTDZ=$PIECE($GET(^SC(LROLLOC,0)),U,4)
+8 IF '+$GET(^BLRSITE($SELECT($GET(BLRALTDZ)
QUIT
+9 SET LRDUZ(2)=BLRALTDZ
End DoDot:1
+10 ;quit if not an accession
IF BLRPHASE'="A"
QUIT
+11 ;
+12 ;kill off existing BLRRL array
KILL BLRRL,BLRRLC
+13 SET BLRRL("LRTS")=$SELECT(+$GET(LRTS):+LRTS,1:$GET(LRTSORU))
+14 ;1/23/2006 don't proceed without a test
IF $GET(BLRRL("LRTS"))=""
QUIT
+15 ;
+16 ;cmi/anch/maw 2/24/2006 added look for LRPHMAN before asking for comments
+17 ;cmi/anch/maw 2/28/2006 added AAA tag for allowing edit of ask at accession questions
AAA ;cmi/anch/maw modified due to routine collect no LRTS 9/8/2004
IF '$ORDER(BLRRLC(0))
IF $PIECE($GET(XQY0),U)'="LRPHMAN"
SET BLRRLSUC=$$COM^BLRRLCOM(BLRRL("LRTS"))
+1 IF $ORDER(BLRRLC(0))
Begin DoDot:1
+2 SET DIR(0)="Y"
SET DIR("A")="Are the responses to the Ask At Accession questions correct "
+3 SET DIR("B")="Y"
+4 DO ^DIR
+5 IF '$GET(Y)
Begin DoDot:2
+6 DO DISAAQ(.BLRCNT,BLRRL("LRTS"),.BLRRLC)
End DoDot:2
GOTO AAA
End DoDot:1
+7 ;cmi/anch/maw 2/28/2005 end of mods
+8 ;I '$O(BLRRLC(0)) S BLRRLSUC=$$COM^BLRRLCOM(+LRTS) maw orig 9/8/2004
+9 ;1/23/2006 don't proceed without a test
IF $GET(BLRRL("LRTS"))=""
QUIT
+10 ;cmi/maw 5/29/2007 added for internal location pointer to file 44
SET BLRRL("LOCI")=$GET(LROLLOC)
+11 ;cmi/maw 5/29/2007 setup alternate duz2 if they select the prompt in blrsite to look at ordering location
SET BLRRL("ALTDUZ2")=$GET(BLRALTDZ)
+12 ;don't need variables if they use a true multidivisional site
IF $GET(BLRALTDZ)
IF $PIECE($GET(^BLRSITE(BLRALTDZ,"RL")),U,10)="D"
KILL BLRALTDZ,BLRRL("ALTDUZ2")
+13 ;don't need variables if they use a true multidivisional site
IF $GET(BLRALTDZ)
IF $PIECE($GET(^BLRSITE(BLRALTDZ,"RL")),U,10)=""
KILL BLRALTDZ,BLRRL("ALTDUZ2")
+14 ;ref lab site maw modified 5/29/2007
SET BLRRL("RL")=+$GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
+15 IF 'BLRRL("RL")
QUIT
+16 ;bi or unidirectional
SET BLRRL("BI")=$PIECE($GET(^BLRRL(BLRRL("RL"),0)),U,10)
+17 ;get external name
SET BLRRL("RLE")=$PIECE($GET(^BLRRL(BLRRL("RL"),0)),U)
+18 ;cmi/anch/maw 3/3/2006 lets try this for account number
+19 SET BLRRL("CLIENT")=$ORDER(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RLCA","B",""))
+20 IF $GET(BLRRL("CLIENT"))=""
SET BLRRL("CLIENT")=$PIECE($GET(^BLRRL(BLRRL("RL"),0)),U,13)
+21 ;cmi/anch/maw 3/3/2006 end of mods
+22 ;no orders 5/31/06
IF $GET(BLRRL("BI"))
IF $PIECE($GET(^BLRRL(BLRRL("RL"),0)),U,6)=""
QUIT
+23 ;patient
SET BLRRL("PAT")=$GET(DFN)
+24 ;accession number
SET BLRRL("ACC")=$GET(LRACC)
+25 ;unique id
SET BLRRL("UID")=$GET(LRUID)
+26 ;collection date
SET BLRRL("CDT")=$GET(LRCDT)
+27 ;get accession abbreviation
SET BLRRL("ACCA")=$PIECE(BLRRL("ACC")," ")
+28 IF $GET(BLRRL("ACCA"))=""
QUIT
+29 ;get ien of accession area
SET BLR("ACCAREA")=$ORDER(^LRO(68,"B",BLRRL("ACCA"),0))
+30 ;don't proceed if not an SO area
IF BLR("ACCAREA")=""
QUIT
+31 ;quit when not a sendout area
IF '$DATA(^BLRRL("ACC",BLR("ACCAREA"),BLRRL("RL")))
QUIT
+32 ;ordering provider
SET BLRRL("ORDPRV")=$GET(LRPRAC)
+33 ;the following must be setup in an array for GIS software
+34 ;do something here to check for mult tests under ac #
+35 ;or each acc # unique
+36 SET (BLRTSTDA,BLRRL("TSTDA"))=+$GET(LRTS)
+37 ;kill off array from previous accession
KILL BLRRL(BLRTSTDA)
+38 ;maw 5/10/06
KILL BLRRL("ORDPUPIN"),BLRRL("ORDPNM")
+39 ;setup provider array
IF BLRRL("ORDPRV")]""
Begin DoDot:1
+40 ;maw 5/10/06
SET BLRRL("ORDPUPIN")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),9999999.08)
+41 SET BLRRL("ORDPNM")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),.01)
+42 SET BLRRL("ORDPNM")=$PIECE(BLRRL("ORDPNM"),",")_"^"_$PIECE($PIECE(BLRRL("ORDPNM"),",",2)," ")
+43 SET BLRRL(BLRTSTDA,"ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM")
+44 SET BLRRL("ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM")
End DoDot:1
+45 ;get test ien
SET BLRTSTI=+$GET(LRTS)
+46 ;quit if no accession area
IF '$DATA(^LAB(60,BLRTSTI,8,$SELECT($GET(BLRALTDZ)
QUIT
+47 ;get acc area
SET BLRAREA=$PIECE($GET(^LAB(60,BLRTSTI,8,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U,2)
+48 ;quit if accession area field is null
IF BLRAREA=""
QUIT
+49 ;quit if test acc area is not SO area
IF BLRAREA'=BLR("ACCAREA")
QUIT
+50 ;collection date
SET BLRRL(BLRTSTDA,"CDT")=$GET(LRCDT)
+51 ;get test name
SET BLRRL("TNAME")=$PIECE($GET(^LAB(60,BLRTSTI,0)),U)
+52 ;get area abbr
SET BLRRL("ABBR")=$PIECE($GET(^LRO(68,BLRAREA,0)),U,11)
+53 ;get test ien
SET BLRRL("TST")=BLRTSTI
+54 ;lookup test code
SET BLRRL("TCODE")=$$CODE(BLRRL("RL"),BLRRL("TST"))
+55 ;quit if no test code
IF $GET(BLRRL("TCODE"))=0
KILL BLRRL(BLRTSTDA)
QUIT
+56 ;setup acc array for OBR
SET BLRRL(BLRTSTDA,"ACC")=$GET(LRACC)
+57 SET BLRRL(BLRTSTDA,"UID")=$GET(LRUID)
+58 ;test arry
SET BLRRL("TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME")
+59 ;test arry
SET BLRRL(BLRTSTDA,"TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME")
+60 SET BLRRL("URG")=$GET(LRURG)
+61 SET BLRRL("LOC")=$GET(LRLLOC)
+62 SET BLRRL("ODT")=$GET(LRODT)
+63 SET BLRRL(BLRTSTDA,"SAMP")=$GET(LRSAMP)
+64 SET BLRRL("SAMP")=$GET(LRSAMP)
+65 SET BLRRL(BLRTSTDA,"SRC")=$GET(LRSPEC)
+66 SET BLRRL("SRC")=$GET(LRSPEC)
+67 IF $GET(LRSPEC)
SET (BLRRL(BLRTSTDA,"SRC"),BLRRL("SRC"))=$PIECE($GET(^LAB(61,LRSPEC,0)),U)
+68 SET BLRRL("ORD")=$GET(LRORD)
+69 SET BLRRL(BLRTSTDA,"ORD")=$GET(LRORD)
+70 SET BLRCM=0
FOR
SET BLRCM=$ORDER(BLRRLC(BLRTSTDA,BLRCM))
IF 'BLRCM
QUIT
Begin DoDot:1
+71 SET BLRRL(BLRTSTDA,"COMMENT",BLRCM)=$GET(BLRRLC(BLRTSTDA,BLRCM))
+72 SET BLRRL("COMMENT",BLRCM)=$GET(BLRRLC(BLRTSTDA,BLRCM))
End DoDot:1
+73 ;cmi/maw 10/31/07 ask what type of billing here
+74 ;S DIR(0)="S^C:Client;T^Third Party;P:Patient"
+75 ;S DIR("A")="Which Party is Responsible for Billing: "
+76 ;S DIR("B")="Client"
+77 ;D ^DIR
+78 ;S BLRRL("BILL TYPE")=Y
+79 ;I $D(DIRUT) S BLRRL("BILL TYPE")="Client"
+80 ;K DIR
+81 ;cmi/maw 10/31/07 end of mods
+82 DO TMPSET(.BLRRL)
+83 ;cmi/anch/maw added for ward collection list 2/23/2006
IF $PIECE($GET(XQY0),U)="LRPHMAN"
Begin DoDot:1
+84 DO PRT^BLRSHPM
End DoDot:1
+85 ;call accession protocol
SET X="BLR REFLAB ACCESSION A TEST"
SET DIC=101
DO EN^XQOR
+86 KILL BLRRL,BLRRLC(BLRTSTDA),LRTEST
+87 QUIT
+88 ;
TMPSET(BLRSHP) ;-- setup the array for the shipping manifest
+1 NEW BLRDA,BLRDATA
+2 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+3 IF BLRDA?.N
QUIT
+4 ;cmi/anch/maw 7/24/2007 right here you could store by order number if passed in at the top
+5 SET BLRDATA=$GET(BLRSHP(BLRDA))
+6 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA))
SET ^TMP("BLRRL",$JOB,"COMMON",BLRDA)=BLRDATA
End DoDot:1
+7 NEW BLRDA,BLRDATA,BLRIEN
+8 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+9 IF BLRDA'?.N
QUIT
+10 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(BLRSHP(BLRDA,BLRIEN))
IF BLRIEN=""
QUIT
Begin DoDot:2
+11 IF BLRIEN="COMMENT"
QUIT
+12 SET BLRDATA=$GET(BLRSHP(BLRDA,BLRIEN))
+13 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA,BLRIEN))
SET ^TMP("BLRRL",$JOB,BLRDA,BLRIEN)=BLRDATA
End DoDot:2
End DoDot:1
+14 NEW BLRDA,BLRIEN,BLROEN,BLRDATA
+15 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+16 IF 'BLRDA
QUIT
+17 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(BLRSHP(BLRDA,"COMMENT",BLRIEN))
IF 'BLRIEN
QUIT
Begin DoDot:2
+18 SET BLRDATA=$GET(BLRSHP(BLRDA,"COMMENT",BLRIEN))
+19 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRIEN))
SET ^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRIEN)=BLRDATA
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
CODE(RL,TST) ;lookup the test code via prefix and test
+1 KILL BLRTCODE
+2 IF '$DATA(^BLRRL(RL,1,0))
QUIT 0
+3 SET BLRRDA=0
FOR
SET BLRRDA=$ORDER(^BLRRL("ALP",TST,RL,BLRRDA))
IF 'BLRRDA!($GET(BLRTCODE)]"")
QUIT
Begin DoDot:1
+4 SET BLRTCODE=$PIECE($GET(^BLRRL(RL,1,BLRRDA,0)),U,3)
+5 IF $GET(BLRTCODE)]""
QUIT
End DoDot:1
+6 IF $GET(BLRTCODE)=""
QUIT 0
+7 QUIT BLRTCODE
+8 ;cmi/anch/maw end REF LAB
+9 ;
DISAAQ(BLRCNT,TIEN,AAQ) ;-- display the ask at order questions
+1 NEW A,BLRCNT
+2 SET BLRCNT=0
+3 SET A=0
FOR
SET A=$ORDER(AAQ(TIEN,A))
IF 'A
QUIT
Begin DoDot:1
+4 SET BLRCNT=BLRCNT+1
+5 WRITE !,A_") ",$PIECE(AAQ(TIEN,A),U,2),?50,$PIECE(AAQ(TIEN,A),U,3)
End DoDot:1
+6 WRITE !
+7 NEW RES
+8 KILL DIR
+9 SET DIR(0)="N^1:"_BLRCNT
+10 SET DIR("A")="Edit Which Ask At Accession Question "
+11 DO ^DIR
+12 IF $DATA(DIRUT)
QUIT
+13 SET RES=+Y
+14 KILL DIR
+15 SET DIR(0)="F"
SET DIR("A")=$PIECE(AAQ(TIEN,RES),U,2)
+16 SET DIR("B")=$PIECE(AAQ(TIEN,RES),U,3)
+17 DO ^DIR
+18 IF $DATA(DIRUT)
QUIT
+19 SET $PIECE(BLRRLC(TIEN,RES),U,3)=Y
+20 QUIT
+21 ;
+22 ;----- END IHS MODIFICATIONS LR*5.2*1021
+23 ;
+24 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+25 ; Code moved to here to keep logic above from being obscured.
RESULTS ; EP
+1 ;M ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRCOM")=^LR(LRDFN,LRSS,9999999-$S($D(LRCDT):LRCDT,1:LRI),1)
+2 ;IHS/ITSC/TPF 08/25/02 FIXED PROBLEM AT TALEQUAW **1015**
MERGE ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRCOM")=^LR(LRDFN,LRSS,9999999-$SELECT($DATA(LRCDT):LRCDT,$DATA(LRI):LRI,1:LRIDT),1)
+3 ;
+4 ;AFTER MERGING THE TESTS IN, KILL THE B X-REF WE DONT NEED IT
+5 KILL ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRCOM","B")
+6 ;
+7 IF $DATA(LRORDCOM)
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRORDCOM")=LRORDCOM
+8 IF $DATA(LRDFN)
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN
+9 IF $DATA(LRSPEC)
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRSPEC")=LRSPEC
IF $DATA(SEX)
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"SEX")=SEX
IF $DATA(AGE)
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"AGE")=AGE
+10 ;
+11 IF BLROPT="BBANK"
Begin DoDot:1
+12 SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN
SET ^("LRCDT")=9999999-LRI
SET ^("LRIDT")=LRI
SET ^("BLRTEST")=LRT
SET ^("BLRTESTN")=$PIECE(LRT(LRT),U)
SET ^("DR")=$GET(DR)
End DoDot:1
QUIT
+13 ;
+14 IF BLROPT="MICRO"
Begin DoDot:1
+15 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1016 IHS TESTING CHANGE
+16 SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRSAMP")=$GET(LRSAMP)
+17 ;----- END IHS MODIFICATIONS
+18 SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRAA")=LRAA
SET ^("LRAD")=LRAD
SET ^("LRAN")=LRAN
SET ^("LRSS")=LRSS
SET ^("LRODT")=LRODT
SET ^("LRCDT")=LRCDT
SET ^("LRSN")=LRSN
+19 SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN
SET ^("LRIDT")=LRIDT
SET ^("BLRTEST")=$SELECT($DATA(LRTS):LRTS,1:LRTEST)
+20 ;IHS/ITSC/TPF 9/24/02 **1014**
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRDFN")=LRDFN
SET ^("LRIDT")=LRIDT
SET ^("BLRTEST")=+$SELECT($DATA(LRTS):LRTS,1:LRTEST)
End DoDot:1
QUIT
+21 ;
+22 IF $DATA(LRSB)
MERGE ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRSB")=LRSB
+23 ;
+24 SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"LRAA")=LRAA
SET ^("LRAD")=LRAD
SET ^("LRAN")=LRAN
SET ^("LRSS")=LRSS
SET ^("LRODT")=LRODT
SET ^("LRCDT")=$GET(LRCDT)
SET ^("LRSN")=LRSN
+25 IF BLROPT="BYPASS"
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$GET(LRTY,$GET(LRTNUM))
+26 IF BLROPT="ACCORD"
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$GET(LRTNUM)
+27 QUIT
+28 ;
DELETION ; EP
+1 SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRODTM")=$PIECE($SELECT($DATA(LROD0):LROD0,1:^LRO(69,LRODT,1,LRSN,0)),U,5)
+2 ;I $G(BLRPARAM)["TESTS" S ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$P(T(J),U,3),^("LRSN")=+T(J) Q
+3 ;----- BEGIN IHS MODIFCATIONS LR*5.2*1016 IHS TESTING CHANGE
+4 IF $GET(BLRPARAM)["TESTS"
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=$PIECE($GET(T(J)),U,3)
SET ^("LRSN")=+$GET(T(J))
QUIT
+5 ;
+6 IF BLROPT="DELACC"
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRACCN")=^LRO(68,$PIECE(BLRIDS,","),1,$PIECE(BLRIDS,",",2),1,$PIECE(BLRIDS,",",3),.2)
SET ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"BLRTEST")=LRTSTS
QUIT
+7 IF $DATA(T)
MERGE ^BLRSITE(BLRQSITE,20,BLRDH,1,BLRQUE,"T")=T
+8 ;
+9 QUIT
+10 ;
RSBLROPT ; EP -- Set/Reset BLROPT variable
+1 ; If Accession null, skip
IF $LENGTH($GET(LRACC))<1
QUIT
+2 ;
+3 ; If Accession in 9009022, skip
IF $LENGTH($ORDER(^BLRTXLOG("D",LRACC,0)))
QUIT
+4 ;
+5 ; S BLROPT="BYPASS" ; Hard set BLROPT
+6 ;
+7 QUIT
+8 ; ----- END IHS/MSC/MKK - LR*5.2*1033
