- 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