LRPHLIS1 ;SLC/CJS - PRINT COLLECTION LIST (CONT.) ; 3/28/89 19:39
;;5.2;LAB SERVICE;**1,161**;Sep 27, 1994
L1 ;
D PSET^LRLABLD ; Setup barcode variables
S LRLLOC=LRSTA,LRODT=DT
F S LRLLOC=$O(^LRO(69.1,"LRPH",1,LRLLOC)) Q:LRLLOC="" Q:(LRLLOC]LRFIN&(LRFIN'="")) D L2
K LRBAR0,LRBAR1
D KVA^VADPT
Q
;
L2 D HEAD:LRLL=1 D WARDHD:LRLL=2
S LRRB=""
F S LRRB=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB)) Q:LRRB="" D L3
Q
;
L3 S LRDFN=0
F S LRDFN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN)),LRPORD=0 Q:LRDFN<1 D L4
Q
;
L4 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRINFW=$S($D(^(.091)):$P(^(.091),U),1:"")
D
. N LRRB,LRLLOC,I ; Protect these variables, used in loop below.
. D PT^LRX
I $D(LRMULTI),$D(LRDIV) S LRDIVLOC=$S($D(^LR(LRDFN,.2)):^(.2),1:"") I LRDIVLOC,$P($G(^SC(LRDIVLOC,0)),U,4)'=LRDIV Q ;multidivison
S LRSN=0
F S LRSN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN)) Q:LRSN<1 S LRTJ=^(LRSN) D L5:LRLL=1,B5:LRLL=2
Q
;
L5 S LRTVOL=0,LRTOP=$P(^LAB(62,+LRTJ,0),U,3),LRURG=$S($D(^LAB(62.05,+$P(LRTJ,U,2),0)):$P(^(0),U),1:"ROUTINE"),LRODT=$P(LRTJ,U,3)
S LRAA=0
F S LRAA=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA)) Q:LRAA<1 D L6
K LRBAR
Q
;
L6 S LRORD=$S($D(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:""),LRAD=$P(^LRO(68,LRAA,0),U,3),LRAD=$S(LRAD="Y":$E(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$E(DT,1,5)_"00","Q"[LRAD:$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
I LRORD'=LRPORD S LRPORD=LRORD W !!?5,$S(LRRB=0:"",1:LRRB),?15,$E(PNM,1,28) W:$L(LRINFW) " INF WARN: ",LRINFW W ?45,SSN,?60,"Order #: ",LRORD
S LRWLEC=0 S LRAN=0 F S LRAN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN)) Q:LRAN<1 S LRWLEC=LRWLEC+1 W:LRWLEC>1 !! S LRACC=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)):^(.2),1:"") S LRTVOL=0 D REM,L7
Q
L7 S T=0 F S T=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,T)) Q:T<1 S LRTV=^(T) D S7 W !,?21,$E($P(^LAB(60,+LRTV,0),U),1,20) W:LRVOL>0 ?42,$J(LRVOL,6,1),"ML"
W ?52,LRTOP,?65,LRACC W:LRTVOL>0 !,?65,$J(LRTVOL,6,1),"ML T" Q
S7 S LRVOL=0,LRSSP=0
F S LRSSP=$O(^LAB(60,+LRTV,3,LRSSP)) Q:LRSSP<1 I +LRTJ=+^(LRSSP,0) S LRVOL=$P(^(0),U,4),LRTVOL=LRTVOL+LRVOL Q
Q
;
B5 S LRODT=$P(LRTJ,U,3)
Q:$D(^LRO(69,LRODT,1,LRSN,0))[0
S LRAA=0
F S LRAA=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA)) Q:LRAA<1 D
. D LBLTYP^LRLABLD ; Get lab routine to use
. D LRBAR^LRLABLD
. D B6
K LRBAR
Q
;
B6 Q:$P(^LRO(68,LRAA,0),U,12) S LRAD=$P(^(0),U,3),LRAD=$S(LRAD="Y":$E(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$E(DT,1,5)_"00","Q"[LRAD:$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
S LRAN=0
F S LRAN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN)) Q:LRAN<1 D B7
Q
;
B7 S:$L($G(LRRB)) LRRBX=LRRB
S LRACC=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)):^(.2),1:"") Q:LRACC']"" S LRCE=^(.1)
D GO^LRLABLD
S:$D(LRRBX) LRRB=LRRBX K LRRBX
Q
;
LRTOP S:$D(^LRO(68,LRAA,1,LRLBLD,1,LRAN,5,1,0)) LRTOP=+^(0),LRTOP=$S($D(^LAB(61,LRTOP,0)):$P(^(0),U),1:"") Q
Q
;
HEAD S N=$P(^LAB(69.9,1,5),"^",15) W @IOF,!!,?34,"COLLECTION LIST ",LRDT0,!,?34,N,$S(N=1:"ST",N=2:"ND",N=3:"RD",1:"TH")," PRINTING"
W !,"Ward",!,?5,"Bed",?15,"Name",?45,"SSN",?65,"Accession",!,LRLLOC
Q
;
REM S LREM=0,T=0 F S T=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,T)) Q:T<1 S LREM=LREM+2
I $Y>(IOSL-LREM-4) D HEAD W !!?5,$S(LRRB=0:"",1:LRRB),?15,$E(PNM,1,28) W:$L(LRINFW) " PT INFO : ",LRINFW W ?45,SSN,?60,"Order #: ",LRORD,!
Q
;
WARDHD ;
N LRAA,LRACC,LRAD,LRAN,LRBAR,LRBARID,LRCE,LRDAT,LRINFW,LRPREF,LRRB,LRTOP,LRTS,LRUID,LRURG0,LRURGA,LRXL
N I,N,PNM,SSN
Q:'$D(LRLLOC)#2
S PNM=LRLLOC,LRDAT="XX/XX/XX",SSN="XXX-XX-XXXX",LRACC=LRLLOC
S (LRAA,LRAD)=0,LRAN="0000",LRCE="000"
S LRRB=1,LRPREF="XXXXX",LRTOP=" ",LRTS(1)="DON'T USE",LRTS(2)="NEW LOCATION"
S LRURG0=9
D LBLTYP^LRLABLD ; Get lab routine to use
D LRBAR^LRLABLD
D UID^LRLABLD,BARID^LRLABLD
S LRURGA=$$URGA^LRLABLD(LRURG0)
S LRINFW=" ",I=1,N=1,LRXL=0
D @LRLABEL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPHLIS1 3970 printed Sep 23, 2025@19:55:02 Page 2
LRPHLIS1 ;SLC/CJS - PRINT COLLECTION LIST (CONT.) ; 3/28/89 19:39
+1 ;;5.2;LAB SERVICE;**1,161**;Sep 27, 1994
L1 ;
+1 ; Setup barcode variables
DO PSET^LRLABLD
+2 SET LRLLOC=LRSTA
SET LRODT=DT
+3 FOR
SET LRLLOC=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC))
if LRLLOC=""
QUIT
if (LRLLOC]LRFIN&(LRFIN'=""))
QUIT
DO L2
+4 KILL LRBAR0,LRBAR1
+5 DO KVA^VADPT
+6 QUIT
+7 ;
L2 if LRLL=1
DO HEAD
if LRLL=2
DO WARDHD
+1 SET LRRB=""
+2 FOR
SET LRRB=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB))
if LRRB=""
QUIT
DO L3
+3 QUIT
+4 ;
L3 SET LRDFN=0
+1 FOR
SET LRDFN=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN))
SET LRPORD=0
if LRDFN<1
QUIT
DO L4
+2 QUIT
+3 ;
L4 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
SET LRINFW=$SELECT($DATA(^(.091)):$PIECE(^(.091),U),1:"")
+1 Begin DoDot:1
+2 ; Protect these variables, used in loop below.
NEW LRRB,LRLLOC,I
+3 DO PT^LRX
End DoDot:1
+4 ;multidivison
IF $DATA(LRMULTI)
IF $DATA(LRDIV)
SET LRDIVLOC=$SELECT($DATA(^LR(LRDFN,.2)):^(.2),1:"")
IF LRDIVLOC
IF $PIECE($GET(^SC(LRDIVLOC,0)),U,4)'=LRDIV
QUIT
+5 SET LRSN=0
+6 FOR
SET LRSN=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN))
if LRSN<1
QUIT
SET LRTJ=^(LRSN)
if LRLL=1
DO L5
if LRLL=2
DO B5
+7 QUIT
+8 ;
L5 SET LRTVOL=0
SET LRTOP=$PIECE(^LAB(62,+LRTJ,0),U,3)
SET LRURG=$SELECT($DATA(^LAB(62.05,+$PIECE(LRTJ,U,2),0)):$PIECE(^(0),U),1:"ROUTINE")
SET LRODT=$PIECE(LRTJ,U,3)
+1 SET LRAA=0
+2 FOR
SET LRAA=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA))
if LRAA<1
QUIT
DO L6
+3 KILL LRBAR
+4 QUIT
+5 ;
L6 SET LRORD=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:"")
SET LRAD=$PIECE(^LRO(68,LRAA,0),U,3)
SET LRAD=$SELECT(LRAD="Y":$EXTRACT(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$EXTRACT(DT,1,5)_"00","Q"[LRAD:$EXTRACT(DT,1,3)_"0000"+(($EXTRACT(DT,4,5)-1)\3*300+100),1:DT)
+1 IF LRORD'=LRPORD
SET LRPORD=LRORD
WRITE !!?5,$SELECT(LRRB=0:"",1:LRRB),?15,$EXTRACT(PNM,1,28)
if $LENGTH(LRINFW)
WRITE " INF WARN: ",LRINFW
WRITE ?45,SSN,?60,"Order #: ",LRORD
+2 SET LRWLEC=0
SET LRAN=0
FOR
SET LRAN=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN))
if LRAN<1
QUIT
SET LRWLEC=LRWLEC+1
if LRWLEC>1
WRITE !!
SET LRACC=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)):^(.2),1:"")
SET LRTVOL=0
DO REM
DO L7
+3 QUIT
L7 SET T=0
FOR
SET T=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,T))
if T<1
QUIT
SET LRTV=^(T)
DO S7
WRITE !,?21,$EXTRACT($PIECE(^LAB(60,+LRTV,0),U),1,20)
if LRVOL>0
WRITE ?42,$JUSTIFY(LRVOL,6,1),"ML"
+1 WRITE ?52,LRTOP,?65,LRACC
if LRTVOL>0
WRITE !,?65,$JUSTIFY(LRTVOL,6,1),"ML T"
QUIT
S7 SET LRVOL=0
SET LRSSP=0
+1 FOR
SET LRSSP=$ORDER(^LAB(60,+LRTV,3,LRSSP))
if LRSSP<1
QUIT
IF +LRTJ=+^(LRSSP,0)
SET LRVOL=$PIECE(^(0),U,4)
SET LRTVOL=LRTVOL+LRVOL
QUIT
+2 QUIT
+3 ;
B5 SET LRODT=$PIECE(LRTJ,U,3)
+1 if $DATA(^LRO(69,LRODT,1,LRSN,0))[0
QUIT
+2 SET LRAA=0
+3 FOR
SET LRAA=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA))
if LRAA<1
QUIT
Begin DoDot:1
+4 ; Get lab routine to use
DO LBLTYP^LRLABLD
+5 DO LRBAR^LRLABLD
+6 DO B6
End DoDot:1
+7 KILL LRBAR
+8 QUIT
+9 ;
B6 if $PIECE(^LRO(68,LRAA,0),U,12)
QUIT
SET LRAD=$PIECE(^(0),U,3)
SET LRAD=$SELECT(LRAD="Y":$EXTRACT(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$EXTRACT(DT,1,5)_"00","Q"[LRAD:$EXTRACT(DT,1,3)_"0000"+(($EXTRACT(DT,4,5)-1)\3*300+100),1:DT)
+1 SET LRAN=0
+2 FOR
SET LRAN=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN))
if LRAN<1
QUIT
DO B7
+3 QUIT
+4 ;
B7 if $LENGTH($GET(LRRB))
SET LRRBX=LRRB
+1 SET LRACC=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)):^(.2),1:"")
if LRACC']""
QUIT
SET LRCE=^(.1)
+2 DO GO^LRLABLD
+3 if $DATA(LRRBX)
SET LRRB=LRRBX
KILL LRRBX
+4 QUIT
+5 ;
LRTOP if $DATA(^LRO(68,LRAA,1,LRLBLD,1,LRAN,5,1,0))
SET LRTOP=+^(0)
SET LRTOP=$SELECT($DATA(^LAB(61,LRTOP,0)):$PIECE(^(0),U),1:"")
QUIT
+1 QUIT
+2 ;
HEAD SET N=$PIECE(^LAB(69.9,1,5),"^",15)
WRITE @IOF,!!,?34,"COLLECTION LIST ",LRDT0,!,?34,N,$SELECT(N=1:"ST",N=2:"ND",N=3:"RD",1:"TH")," PRINTING"
+1 WRITE !,"Ward",!,?5,"Bed",?15,"Name",?45,"SSN",?65,"Accession",!,LRLLOC
+2 QUIT
+3 ;
REM SET LREM=0
SET T=0
FOR
SET T=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,T))
if T<1
QUIT
SET LREM=LREM+2
+1 IF $Y>(IOSL-LREM-4)
DO HEAD
WRITE !!?5,$SELECT(LRRB=0:"",1:LRRB),?15,$EXTRACT(PNM,1,28)
if $LENGTH(LRINFW)
WRITE " PT INFO : ",LRINFW
WRITE ?45,SSN,?60,"Order #: ",LRORD,!
+2 QUIT
+3 ;
WARDHD ;
+1 NEW LRAA,LRACC,LRAD,LRAN,LRBAR,LRBARID,LRCE,LRDAT,LRINFW,LRPREF,LRRB,LRTOP,LRTS,LRUID,LRURG0,LRURGA,LRXL
+2 NEW I,N,PNM,SSN
+3 if '$DATA(LRLLOC)#2
QUIT
+4 SET PNM=LRLLOC
SET LRDAT="XX/XX/XX"
SET SSN="XXX-XX-XXXX"
SET LRACC=LRLLOC
+5 SET (LRAA,LRAD)=0
SET LRAN="0000"
SET LRCE="000"
+6 SET LRRB=1
SET LRPREF="XXXXX"
SET LRTOP=" "
SET LRTS(1)="DON'T USE"
SET LRTS(2)="NEW LOCATION"
+7 SET LRURG0=9
+8 ; Get lab routine to use
DO LBLTYP^LRLABLD
+9 DO LRBAR^LRLABLD
+10 DO UID^LRLABLD
DO BARID^LRLABLD
+11 SET LRURGA=$$URGA^LRLABLD(LRURG0)
+12 SET LRINFW=" "
SET I=1
SET N=1
SET LRXL=0
+13 DO @LRLABEL
+14 QUIT
