BLRRLEV2 ;IHS/OIT/MKK - BLR Reference Lab Event, part 2 ; 22-Oct-2013 09:22 ; MAW
;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
;
; Code had to be moved here from BLRRLEVT because BLRRLEVT became too large.
;
EEP ; EP - Ersatz EP
D EEP^BLRGMENU
;
Q
;
;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 ; EP
I '$O(BLRRLC(0)),$P($G(XQY0),U)'="LRPHMAN" S BLRRLSUC=$$COM^BLRRLCOM(BLRRL("LRTS"),0) ;cmi/anch/maw modified due to routine collect no LRTS 9/8/2004
I ('$G(LRQUIET))&$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^BLRRLEVT(.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("LOC")=$G(LRLLOC)
S BLRRL("LOC")=$S($G(LROLLOC):$P($G(^SC(LROLLOC,0)),U),1:"") ;4/3/2008 added for pointer to hosp location file
;S BLRRL("BI")=$P($G(^BLRRL(BLRRL("RL"),0)),U,10) ;bi or unidirectional 2/25/2008 orig line
S BLRRL("BI")=$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL",0)),U,18) ;NEW cmi/maw 2/25/2008 bi or unidirectional
S BLRRL("RLE")=$P($G(^BLRRL(BLRRL("RL"),0)),U) ;get external name
;I $G(BLRRL("BI")) Q:$P($G(^BLRRL(BLRRL("RL"),0)),U,6)="" ;no orders 5/31/06
;I $G(BLRRL("BI")) Q:$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"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
I $G(BLRRL("ACCA"))="" W !,"No valid accession area prefix" Q
S BLR("ACCAREA")=$O(^LRO(68,"B",BLRRL("ACCA"),0)) ;get ien of accession area
I BLR("ACCAREA")="" W !,"Accession Area is not a sendout area" ;don't proceed if not an SO area
;todo see why this is failing
I '$D(^BLRSITE("ACC",BLR("ACCAREA"),DUZ(2),BLRRL("RL"))) D Q ;2/25/2008 moved to BLR MASTER CONTROL FILE quit when not a sendout area
. W !,"Accession area is not setup in the BLR MASTER CONTROL file"
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
S (BLRRL("UPINNPI"),BLRRL(BLRTSTDA,"UPINNPI"))="U" ;upin or NPI
I BLRRL("ORDPRV")]"" D ;setup provider array
. S BLRRL("ORDPUPIN")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),9999999.08) ;maw 5/10/06
. S BLRRL("ORDPNPI")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),41.99) ;cmi/maw 2/26/2008 NPI
. 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") ;cmi/maw 3/4/09 labcorp
. S $P(BLRRL(BLRTSTDA,"ORDP"),U,8)="U" ;cmi/maw 3/12/09 labcorp
. S BLRRL("ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM") ;cmi/maw 3/4/09 labcorp
. S $P(BLRRL("ORDP"),U,8)="U" ;cmi/maw 3/12/09 labcorp
. ;cmi/maw 2/27/2008 added NPI based on parameter set in BLR MASTER CONTROL file
. I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,19)="N" D
.. S (BLRRL("UPINNPI"),BLRRL(BLRTSTDA,"UPINNPI"))="N"
.. S BLRRL(BLRTSTDA,"ORDP")=BLRRL("ORDPNPI")_"^"_BLRRL("ORDPNM") ;cmi/maw 3/4/09 labcorp
.. S $P(BLRRL(BLRTSTDA,"ORDP"),U,8)="N" ;cmi/maw 3/12/09 labcorp
.. S BLRRL("ORDP")=BLRRL("ORDPNPI")_"^"_BLRRL("ORDPNM") ;cmi/maw 3/4/09 labcorp
.. S $P(BLRRL("ORDP"),U,8)="N" ;cmi/maw 3/12/09 labcorp
S BLRTSTI=+$G(LRTS) ;get test ien
I '$D(^LAB(60,BLRTSTI,8,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)) D Q ;quit if no accession area
. W !,"Institution "_$P($G(^DIC(4,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U)_" is not setup in the Accession Area multiple of file 60"
S BLRAREA=$P($G(^LAB(60,BLRTSTI,8,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U,2) ;get acc area
I BLRAREA="" W !,"Accession Area field is not setup in file 60 for "_$P($G(^DIC(4,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U) Q ;quit if accession area field is null
;todo see why the below code does not work
I BLRAREA'=BLR("ACCAREA") W !,"Accession Area in file 60 is not a sendout accession area" Q ;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("TCODEE")=$$CODE^BLRRLEVT(BLRRL("RL"),BLRRL("TST")) ;lookup test code
S BLRRL("TCODE")=$P(BLRRL("TCODEE"),U) ;test code
S BLRRL("SHIPCOND")=$P(BLRRL("TCODEE"),U,2) ;shipping condition
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
I $G(BLRRL("RLE"))="LABCORP" D
. S BLRRL("TCNM")=BLRRL("TCNM")_"^L"
. S BLRRL(BLRTSTDA,"TCNM")=BLRRL(BLRTSTDA,"TCNM")_"^L"
S BLRRL("URGHL")=$S($G(LRURG):$P($G(^LAB(62.05,LRURG,0)),U,4),1:"")
S BLRRL("URG")=$G(LRURG)
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/anch/maw 3/3/2006 lets try this for account number
;cmi/maw 2/25/2008 code added to get multiple account numbers
;S BLRRL("BILL TYPE")="Client"
;I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)'="C" D BILL^BLRRLHL
I +$G(LRQUIET) D
.I $G(BLRBT)="T" S BLRRL("BILL TYPE")="T" D BILL^BLRAG05C ; IHS/MSC/SAT - LR*5.2*1031
.S BLRRL("BILL TYPE")=$S($G(BLRBT)="C":"C",$G(BLRBT)="P":"P",1:"")
I '+$G(LRQUIET) I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)'="C" D BILL^BLRRLHL ; IHS/MSC/SAT - LR*5.2*1031
;
;cmi/anch/maw 3/3/2006 end of mods
I '$G(BLRRLCLA) D CLIENT^BLRRLHL
I '$G(BLRRL("CLIENT")) S BLRRL("CLIENT")=$G(BLRRLCLT)
I '$G(BLRRL("CLIENT")) 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)
I $G(BLRRL("BILL TYPE"))="" S BLRRL("BILL TYPE")=$G(BLRRLBTP)
D TMPSET(.BLRRL)
I +$G(BLRAGUI)!($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,PAT
Q
;
TMPSET(BLRSHP) ;-- setup the array for the shipping manifest
N BLRDA,BLRDATA,BLRIEN,BLROEN
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
;
K 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
;
K BLRDA,BLRDATA,BLRIEN,BLROEN
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 BLROEN=0 F S BLROEN=$O(BLRSHP(BLRDA,BLRIEN,BLROEN)) Q:'BLROEN D
... S BLRDATA=$G(BLRSHP(BLRDA,BLRIEN,BLROEN))
... I '$D(^TMP("BLRRL",$J,BLRDA,BLRIEN,BLROEN)) S ^TMP("BLRRL",$J,BLRDA,BLRIEN,BLROEN)=BLRDATA
;
K 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
BLRRLEV2 ;IHS/OIT/MKK - BLR Reference Lab Event, part 2 ; 22-Oct-2013 09:22 ; MAW
+1 ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
+2 ;
+3 ; Code had to be moved here from BLRRLEVT because BLRRLEVT became too large.
+4 ;
EEP ; EP - Ersatz EP
+1 DO EEP^BLRGMENU
+2 ;
+3 QUIT
+4 ;
+5 ;cmi/anch/maw 2/24/2006 added look for LRPHMAN before asking for comments
+6 ;cmi/anch/maw 2/28/2006 added AAA tag for allowing edit of ask at accession questions
AAA ; EP
+1 ;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"),0)
+2 IF ('$GET(LRQUIET))&$ORDER(BLRRLC(0))
Begin DoDot:1
+3 SET DIR(0)="Y"
SET DIR("A")="Are the responses to the Ask At Accession questions correct "
+4 SET DIR("B")="Y"
+5 DO ^DIR
+6 IF '$GET(Y)
Begin DoDot:2
+7 DO DISAAQ^BLRRLEVT(.BLRCNT,BLRRL("LRTS"),.BLRRLC)
End DoDot:2
GOTO AAA
End DoDot:1
+8 ;cmi/anch/maw 2/28/2005 end of mods
+9 ;I '$O(BLRRLC(0)) S BLRRLSUC=$$COM^BLRRLCOM(+LRTS) maw orig 9/8/2004
+10 ;1/23/2006 don't proceed without a test
IF $GET(BLRRL("LRTS"))=""
QUIT
+11 ;cmi/maw 5/29/2007 added for internal location pointer to file 44
SET BLRRL("LOCI")=$GET(LROLLOC)
+12 SET BLRRL("LOC")=$GET(LRLLOC)
+13 ;4/3/2008 added for pointer to hosp location file
SET BLRRL("LOC")=$SELECT($GET(LROLLOC):$PIECE($GET(^SC(LROLLOC,0)),U),1:"")
+14 ;S BLRRL("BI")=$P($G(^BLRRL(BLRRL("RL"),0)),U,10) ;bi or unidirectional 2/25/2008 orig line
+15 ;NEW cmi/maw 2/25/2008 bi or unidirectional
SET BLRRL("BI")=$PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL",0)),U,18)
+16 ;get external name
SET BLRRL("RLE")=$PIECE($GET(^BLRRL(BLRRL("RL"),0)),U)
+17 ;I $G(BLRRL("BI")) Q:$P($G(^BLRRL(BLRRL("RL"),0)),U,6)="" ;no orders 5/31/06
+18 ;I $G(BLRRL("BI")) Q:$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"),0)),U,6)="" ;no orders 5/31/06
+19 ;patient
SET BLRRL("PAT")=$GET(DFN)
+20 ;accession number
SET BLRRL("ACC")=$GET(LRACC)
+21 ;unique id
SET BLRRL("UID")=$GET(LRUID)
+22 ;collection date
SET BLRRL("CDT")=$GET(LRCDT)
+23 ;get accession abbreviation
SET BLRRL("ACCA")=$PIECE(BLRRL("ACC")," ")
+24 IF $GET(BLRRL("ACCA"))=""
WRITE !,"No valid accession area prefix"
QUIT
+25 ;get ien of accession area
SET BLR("ACCAREA")=$ORDER(^LRO(68,"B",BLRRL("ACCA"),0))
+26 ;don't proceed if not an SO area
IF BLR("ACCAREA")=""
WRITE !,"Accession Area is not a sendout area"
+27 ;todo see why this is failing
+28 ;2/25/2008 moved to BLR MASTER CONTROL FILE quit when not a sendout area
IF '$DATA(^BLRSITE("ACC",BLR("ACCAREA"),DUZ(2),BLRRL("RL")))
Begin DoDot:1
+29 WRITE !,"Accession area is not setup in the BLR MASTER CONTROL file"
End DoDot:1
QUIT
+30 ;ordering provider
SET BLRRL("ORDPRV")=$GET(LRPRAC)
+31 ;the following must be setup in an array for GIS software
+32 ;do something here to check for mult tests under ac #
+33 ;or each acc # unique
+34 SET (BLRTSTDA,BLRRL("TSTDA"))=+$GET(LRTS)
+35 ;kill off array from previous accession
KILL BLRRL(BLRTSTDA)
+36 ;maw 5/10/06
KILL BLRRL("ORDPUPIN"),BLRRL("ORDPNM")
+37 ;upin or NPI
SET (BLRRL("UPINNPI"),BLRRL(BLRTSTDA,"UPINNPI"))="U"
+38 ;setup provider array
IF BLRRL("ORDPRV")]""
Begin DoDot:1
+39 ;maw 5/10/06
SET BLRRL("ORDPUPIN")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),9999999.08)
+40 ;cmi/maw 2/26/2008 NPI
SET BLRRL("ORDPNPI")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),41.99)
+41 SET BLRRL("ORDPNM")=$$VAL^XBDIQ1(200,BLRRL("ORDPRV"),.01)
+42 SET BLRRL("ORDPNM")=$PIECE(BLRRL("ORDPNM"),",")_"^"_$PIECE($PIECE(BLRRL("ORDPNM"),",",2)," ")
+43 ;cmi/maw 3/4/09 labcorp
SET BLRRL(BLRTSTDA,"ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM")
+44 ;cmi/maw 3/12/09 labcorp
SET $PIECE(BLRRL(BLRTSTDA,"ORDP"),U,8)="U"
+45 ;cmi/maw 3/4/09 labcorp
SET BLRRL("ORDP")=BLRRL("ORDPUPIN")_"^"_BLRRL("ORDPNM")
+46 ;cmi/maw 3/12/09 labcorp
SET $PIECE(BLRRL("ORDP"),U,8)="U"
+47 ;cmi/maw 2/27/2008 added NPI based on parameter set in BLR MASTER CONTROL file
+48 IF $PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,19)="N"
Begin DoDot:2
+49 SET (BLRRL("UPINNPI"),BLRRL(BLRTSTDA,"UPINNPI"))="N"
+50 ;cmi/maw 3/4/09 labcorp
SET BLRRL(BLRTSTDA,"ORDP")=BLRRL("ORDPNPI")_"^"_BLRRL("ORDPNM")
+51 ;cmi/maw 3/12/09 labcorp
SET $PIECE(BLRRL(BLRTSTDA,"ORDP"),U,8)="N"
+52 ;cmi/maw 3/4/09 labcorp
SET BLRRL("ORDP")=BLRRL("ORDPNPI")_"^"_BLRRL("ORDPNM")
+53 ;cmi/maw 3/12/09 labcorp
SET $PIECE(BLRRL("ORDP"),U,8)="N"
End DoDot:2
End DoDot:1
+54 ;get test ien
SET BLRTSTI=+$GET(LRTS)
+55 ;quit if no accession area
IF '$DATA(^LAB(60,BLRTSTI,8,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0))
Begin DoDot:1
+56 WRITE !,"Institution "_$PIECE($GET(^DIC(4,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U)_" is not setup in the Accession Area multiple of file 60"
End DoDot:1
QUIT
+57 ;get acc area
SET BLRAREA=$PIECE($GET(^LAB(60,BLRTSTI,8,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U,2)
+58 ;quit if accession area field is null
IF BLRAREA=""
WRITE !,"Accession Area field is not setup in file 60 for "_$PIECE($GET(^DIC(4,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U)
QUIT
+59 ;todo see why the below code does not work
+60 ;quit if test acc area is not SO area
IF BLRAREA'=BLR("ACCAREA")
WRITE !,"Accession Area in file 60 is not a sendout accession area"
QUIT
+61 ;collection date
SET BLRRL(BLRTSTDA,"CDT")=$GET(LRCDT)
+62 ;get test name
SET BLRRL("TNAME")=$PIECE($GET(^LAB(60,BLRTSTI,0)),U)
+63 ;get area abbr
SET BLRRL("ABBR")=$PIECE($GET(^LRO(68,BLRAREA,0)),U,11)
+64 ;get test ien
SET BLRRL("TST")=BLRTSTI
+65 ;lookup test code
SET BLRRL("TCODEE")=$$CODE^BLRRLEVT(BLRRL("RL"),BLRRL("TST"))
+66 ;test code
SET BLRRL("TCODE")=$PIECE(BLRRL("TCODEE"),U)
+67 ;shipping condition
SET BLRRL("SHIPCOND")=$PIECE(BLRRL("TCODEE"),U,2)
+68 ;quit if no test code
IF $GET(BLRRL("TCODE"))=0
KILL BLRRL(BLRTSTDA)
QUIT
+69 ;setup acc array for OBR
SET BLRRL(BLRTSTDA,"ACC")=$GET(LRACC)
+70 SET BLRRL(BLRTSTDA,"UID")=$GET(LRUID)
+71 ;test arry
SET BLRRL("TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME")
+72 ;test arry
SET BLRRL(BLRTSTDA,"TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME")
+73 IF $GET(BLRRL("RLE"))="LABCORP"
Begin DoDot:1
+74 SET BLRRL("TCNM")=BLRRL("TCNM")_"^L"
+75 SET BLRRL(BLRTSTDA,"TCNM")=BLRRL(BLRTSTDA,"TCNM")_"^L"
End DoDot:1
+76 SET BLRRL("URGHL")=$SELECT($GET(LRURG):$PIECE($GET(^LAB(62.05,LRURG,0)),U,4),1:"")
+77 SET BLRRL("URG")=$GET(LRURG)
+78 SET BLRRL("ODT")=$GET(LRODT)
+79 SET BLRRL(BLRTSTDA,"SAMP")=$GET(LRSAMP)
+80 SET BLRRL("SAMP")=$GET(LRSAMP)
+81 SET BLRRL(BLRTSTDA,"SRC")=$GET(LRSPEC)
+82 SET BLRRL("SRC")=$GET(LRSPEC)
+83 IF $GET(LRSPEC)
SET (BLRRL(BLRTSTDA,"SRC"),BLRRL("SRC"))=$PIECE($GET(^LAB(61,LRSPEC,0)),U)
+84 SET BLRRL("ORD")=$GET(LRORD)
+85 SET BLRRL(BLRTSTDA,"ORD")=$GET(LRORD)
+86 SET BLRCM=0
FOR
SET BLRCM=$ORDER(BLRRLC(BLRTSTDA,BLRCM))
IF 'BLRCM
QUIT
Begin DoDot:1
+87 SET BLRRL(BLRTSTDA,"COMMENT",BLRCM)=$GET(BLRRLC(BLRTSTDA,BLRCM))
+88 SET BLRRL("COMMENT",BLRCM)=$GET(BLRRLC(BLRTSTDA,BLRCM))
End DoDot:1
+89 ;cmi/anch/maw 3/3/2006 lets try this for account number
+90 ;cmi/maw 2/25/2008 code added to get multiple account numbers
+91 ;S BLRRL("BILL TYPE")="Client"
+92 ;I $P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)'="C" D BILL^BLRRLHL
+93 IF +$GET(LRQUIET)
Begin DoDot:1
+94 ; IHS/MSC/SAT - LR*5.2*1031
IF $GET(BLRBT)="T"
SET BLRRL("BILL TYPE")="T"
DO BILL^BLRAG05C
+95 SET BLRRL("BILL TYPE")=$SELECT($GET(BLRBT)="C":"C",$GET(BLRBT)="P":"P",1:"")
End DoDot:1
+96 ; IHS/MSC/SAT - LR*5.2*1031
IF '+$GET(LRQUIET)
IF $PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,15)'="C"
DO BILL^BLRRLHL
+97 ;
+98 ;cmi/anch/maw 3/3/2006 end of mods
+99 IF '$GET(BLRRLCLA)
DO CLIENT^BLRRLHL
+100 IF '$GET(BLRRL("CLIENT"))
SET BLRRL("CLIENT")=$GET(BLRRLCLT)
+101 IF '$GET(BLRRL("CLIENT"))
SET BLRRL("CLIENT")=$ORDER(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RLCA","B",""))
+102 IF $GET(BLRRL("CLIENT"))=""
SET BLRRL("CLIENT")=$PIECE($GET(^BLRRL(BLRRL("RL"),0)),U,13)
+103 IF $GET(BLRRL("BILL TYPE"))=""
SET BLRRL("BILL TYPE")=$GET(BLRRLBTP)
+104 DO TMPSET(.BLRRL)
+105 ;cmi/anch/maw added for ward collection list 2/23/2006
IF +$GET(BLRAGUI)!($PIECE($GET(XQY0),U)="LRPHMAN")
Begin DoDot:1
+106 DO PRT^BLRSHPM
End DoDot:1
+107 ;call accession protocol
SET X="BLR REFLAB ACCESSION A TEST"
SET DIC=101
DO EN^XQOR
+108 KILL BLRRL,BLRRLC(BLRTSTDA),LRTEST,PAT
+109 QUIT
+110 ;
TMPSET(BLRSHP) ;-- setup the array for the shipping manifest
+1 NEW BLRDA,BLRDATA,BLRIEN,BLROEN
+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 ;
+8 KILL BLRDA,BLRDATA,BLRIEN
+9 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+10 IF BLRDA'?.N
QUIT
+11 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(BLRSHP(BLRDA,BLRIEN))
IF BLRIEN=""
QUIT
Begin DoDot:2
+12 IF BLRIEN="COMMENT"
QUIT
+13 SET BLRDATA=$GET(BLRSHP(BLRDA,BLRIEN))
+14 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA,BLRIEN))
SET ^TMP("BLRRL",$JOB,BLRDA,BLRIEN)=BLRDATA
End DoDot:2
End DoDot:1
+15 ;
+16 KILL BLRDA,BLRDATA,BLRIEN,BLROEN
+17 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+18 IF BLRDA'?.N
QUIT
+19 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(BLRSHP(BLRDA,BLRIEN))
IF BLRIEN=""
QUIT
Begin DoDot:2
+20 IF BLRIEN="COMMENT"
QUIT
+21 SET BLROEN=0
FOR
SET BLROEN=$ORDER(BLRSHP(BLRDA,BLRIEN,BLROEN))
IF 'BLROEN
QUIT
Begin DoDot:3
+22 SET BLRDATA=$GET(BLRSHP(BLRDA,BLRIEN,BLROEN))
+23 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA,BLRIEN,BLROEN))
SET ^TMP("BLRRL",$JOB,BLRDA,BLRIEN,BLROEN)=BLRDATA
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;
+25 KILL BLRDA,BLRIEN,BLROEN,BLRDATA
+26 SET BLRDA=0
FOR
SET BLRDA=$ORDER(BLRSHP(BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+27 IF 'BLRDA
QUIT
+28 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(BLRSHP(BLRDA,"COMMENT",BLRIEN))
IF 'BLRIEN
QUIT
Begin DoDot:2
+29 SET BLRDATA=$GET(BLRSHP(BLRDA,"COMMENT",BLRIEN))
+30 IF '$DATA(^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRIEN))
SET ^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRIEN)=BLRDATA
End DoDot:2
End DoDot:1
+31 ;
+32 QUIT
