LRLABELF ;SLC/CJS/DALISC/DRH - PRINT COLLECTION LIST (CONT.) ; 3/28/89 19:39
;;5.2;LAB SERVICE;**121,161**;Sep 27, 1994
; Called by LRLABLDS,LRLABLD0
INIT ;
U IO
S (PAGE,LREND,CNT)=0,LRPRTDT=$$NOW^XLFDT
I LRPICK=1,$E(IOST,1,2)="C-" W @IOF
EN ;
S LRODT=""
F S LRODT=$O(^TMP($J,"LR",LRODT)) Q:LRODT=""!($G(LREND)) D
. S LRCT=""
. F S LRCT=$O(^TMP($J,"LR",LRODT,LRCT)) Q:LRCT=""!($G(LREND)) D
. . S LRCLOC=""
. . F S LRCLOC=$O(^TMP($J,"LR",LRODT,LRCT,LRCLOC)) Q:LRCLOC=""!($G(LREND)) D
. . . I LRPICK=1 D HEAD
. . . S LRPNM=""
. . . F S LRPNM=$O(^TMP($J,"LR",LRODT,LRCT,LRCLOC,LRPNM)) Q:LRPNM=""!($G(LREND)) D PAT
. I LRPICK=1 D
. . S PAGE=0
. . I $E(IOST,1,2)="C-" W !!
. . E W @IOF
Q
;
HEAD ;
Q:$G(LREND)
I PAGE D
. I $E(IOST,1,2)="C-" D EOP
. W @IOF
S PAGE=PAGE+1,LRHEAD=$$FMTE^XLFDT(LRODT)_" "_"Future Collection List"
W !,$$CJ^XLFSTR(LRHEAD,IOM)
S LRPAGE="Page: "_PAGE
W !,"Print Date@Time : ",$$FMTE^XLFDT(LRPRTDT),?60,LRPAGE
W !!,$$CJ^XLFSTR(LRCLOC,IOM,"-")
W !,$$CJ^XLFSTR("WARD LOC/REQ LOC ",IOM," ")
Q
HDR ;
D HEAD
PHDR W:$G(CHDR) !?20,"< CONTINUATION >"
S LRNEW=PNM
W !,PNM I $L($G(LRRB))>1 W ?32,LRRB
W ?42,SSN,?57,"Order #: ",LRCE
W:$L($G(^LR(+LRNODE0,.091))) !?4,"Pat Info: ",^(.091)
S LRPCT=$$FMTE^XLFDT(LRCT,1) S:$P(LRPCT,"@",2) LRPCT=$P(LRPCT,"@",2)_" "_$P(LRPCT,"@")
W !?5,LRPCT,?25,"[ "_LRTYPE_" ]"
N LRURG S NODE=LRNODE0,(S2,LRTVOL)=0
D T^LRLABLD0
S LRTOP=$P($G(^LAB(62,+$P(LRNODE0,U,3),0)),U,3) I $L(LRTOP) S S2=$P(^(0),U,5)
W !?28,$S(S2="":" ",LRTVOL>S2:"Large ",1:"Small "),LRTOP," ",$S($G(LRTVOL):LRTVOL,1:1)," mL ",!
Q
;
CHDR ;
W !?10,"<CONTINUE NEXT PAGE # "_PAGE+1_" >"
S CHDR=1 D PHDR S CHDR=0
Q
;
PAT ;
S LRSNN=""
F S LRSNN=$O(^TMP($J,"LR",LRODT,LRCT,LRCLOC,LRPNM,LRSNN)) Q:LRSNN=""!($G(LREND)) D
. W:LRPICK=1 !
. K LRNEW
. D PRINT
Q
PRINT ;
S LRSN=+$P(LRSNN,"*",2)
Q:'$D(^LRO(69,LRODT,1,LRSN,0))#2 S LRNODE0=^(0),LRCE=$G(^(.1)) Q:'LRCE
I LRPICK=2 D SETUP^LRLABLD0 Q ; Print labels
S LRDFN=+LRNODE0 K LRDPF
D PT^LRX Q:$G(LREND)!(+LRDPF'=2)
Q:$G(LREND)
S LRTYPE="",LRPORD=1,LRTOP=$P($G(^LAB(62,+$P(LRNODE0,U,3),0)),U)
S LRORD=$G(^LRO(69,LRODT,1,LRSN,.1))
I $L($P(LRNODE0,U,4)) S LRTYPE=$G(LRCOLTY($P(LRNODE0,U,4))) ; Collection type
I LRTYPE="" S LRTYPE="Unknown"
I $Y>(IOSL-4) D HDR
S LRSP=0 I '$D(LRNEW) D PHDR S LRNEW=LRPNM
I LRNEW'=LRPNM D PHDR
F TAB=5:35 S LRSP=$O(^LRO(69,LRODT,1,LRSN,2,LRSP)) Q:LRSP<1 D
. N LRURGA
. Q:'$D(^LRO(69,LRODT,1,LRSN,2,LRSP,0))
. S LRTEST=^LRO(69,LRODT,1,LRSN,2,LRSP,0),LRURGN=$P(LRTEST,U,2) S:'LRURGN LRURGN=9
. I $P(LRTEST,"^",11) Q ; Test cancelled
. S LRURGA=$$URGA^LRLABLD(+LRURGN)
. S LRTEST=$P($G(^LAB(60,+$P(LRTEST,U),0)),U)
. I TAB>45 S TAB=5 W ! I $Y>(IOSL-4) D HDR
. W ?TAB,$S(LRURGN<3:"** ",1:"")," (",$P(LRURGA,"^"),") ",LRTEST
Q
DEV ;
K %ZIS S %ZIS="" D ^%ZIS Q:POP
U IO D INIT W !! W:$E(IOST,1,2)'="C-" @IOF
D ^%ZISC
Q
;
EOP ; End-of-page
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="E"
D ^DIR
I $D(DIRUT) S LREND=1
Q
;
END ;
; Called by LRLABLD0, LRLABLDS
I $G(LRPICK)=1 W:$E(IOST,1,2)'="C-" @IOF
I $D(ZTQUEUED) S ZTREQ="@"
E D ^%ZISC
D KVA^VADPT
K ^TMP($J)
K A,DIR,DUOUT,DTOUT,DIRUT
K LRBARID,LRCOLTY,LREND,LRHEAD,LRNODE0,LRORD,LRPCT,LRUID
K LRPERH,LRPERT,LRSP,LRTEST,LRTYPE,LRURGN,TAB
K LRWRD,LRLOCF1,LRLOCF,LRCHLOC,LRDPF,J,S,C,%ZIS,%DT,DIC,DFN,I,L9,LRACC,LRCE,LRCLTY,LRDAT
K LRPRAC,CNT,LRCLOC,LRCT,LRNEWL,LRORDN,LRPICK,LRPNM,LRSING,LRSNN,LRTREA
K PAGE,D0,D1,LRPRTDT
K LRDFN,LRINFW,LRLABEL,LRLLOC,LRODT,LRCT0,LRPREF,LRRB,LRSN,LRSSP
K LRTJ,LRTJDATA,LRTOP,LRTS,LRTV,LRTVOL,LRURG,LRURGA,LRURG0,LN,LRSTOP,LRTIC
K LRDTC,LRTXT,LRVOL,LRXL,N,NODE,S1,S2,T,Y,Y1,Y2
K ZTSAVE,ZTIO,ZTRTN,ZTDESC
K AGE,DOB,PNM,SEX,SSN,POP,E,VA,LRY1,VAERR,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLABELF 3843 printed Dec 13, 2024@02:16:02 Page 2
LRLABELF ;SLC/CJS/DALISC/DRH - PRINT COLLECTION LIST (CONT.) ; 3/28/89 19:39
+1 ;;5.2;LAB SERVICE;**121,161**;Sep 27, 1994
+2 ; Called by LRLABLDS,LRLABLD0
INIT ;
+1 USE IO
+2 SET (PAGE,LREND,CNT)=0
SET LRPRTDT=$$NOW^XLFDT
+3 IF LRPICK=1
IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
EN ;
+1 SET LRODT=""
+2 FOR
SET LRODT=$ORDER(^TMP($JOB,"LR",LRODT))
if LRODT=""!($GET(LREND))
QUIT
Begin DoDot:1
+3 SET LRCT=""
+4 FOR
SET LRCT=$ORDER(^TMP($JOB,"LR",LRODT,LRCT))
if LRCT=""!($GET(LREND))
QUIT
Begin DoDot:2
+5 SET LRCLOC=""
+6 FOR
SET LRCLOC=$ORDER(^TMP($JOB,"LR",LRODT,LRCT,LRCLOC))
if LRCLOC=""!($GET(LREND))
QUIT
Begin DoDot:3
+7 IF LRPICK=1
DO HEAD
+8 SET LRPNM=""
+9 FOR
SET LRPNM=$ORDER(^TMP($JOB,"LR",LRODT,LRCT,LRCLOC,LRPNM))
if LRPNM=""!($GET(LREND))
QUIT
DO PAT
End DoDot:3
End DoDot:2
+10 IF LRPICK=1
Begin DoDot:2
+11 SET PAGE=0
+12 IF $EXTRACT(IOST,1,2)="C-"
WRITE !!
+13 IF '$TEST
WRITE @IOF
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
HEAD ;
+1 if $GET(LREND)
QUIT
+2 IF PAGE
Begin DoDot:1
+3 IF $EXTRACT(IOST,1,2)="C-"
DO EOP
+4 WRITE @IOF
End DoDot:1
+5 SET PAGE=PAGE+1
SET LRHEAD=$$FMTE^XLFDT(LRODT)_" "_"Future Collection List"
+6 WRITE !,$$CJ^XLFSTR(LRHEAD,IOM)
+7 SET LRPAGE="Page: "_PAGE
+8 WRITE !,"Print Date@Time : ",$$FMTE^XLFDT(LRPRTDT),?60,LRPAGE
+9 WRITE !!,$$CJ^XLFSTR(LRCLOC,IOM,"-")
+10 WRITE !,$$CJ^XLFSTR("WARD LOC/REQ LOC ",IOM," ")
+11 QUIT
HDR ;
+1 DO HEAD
PHDR if $GET(CHDR)
WRITE !?20,"< CONTINUATION >"
+1 SET LRNEW=PNM
+2 WRITE !,PNM
IF $LENGTH($GET(LRRB))>1
WRITE ?32,LRRB
+3 WRITE ?42,SSN,?57,"Order #: ",LRCE
+4 if $LENGTH($GET(^LR(+LRNODE0,.091)))
WRITE !?4,"Pat Info: ",^(.091)
+5 SET LRPCT=$$FMTE^XLFDT(LRCT,1)
if $PIECE(LRPCT,"@",2)
SET LRPCT=$PIECE(LRPCT,"@",2)_" "_$PIECE(LRPCT,"@")
+6 WRITE !?5,LRPCT,?25,"[ "_LRTYPE_" ]"
+7 NEW LRURG
SET NODE=LRNODE0
SET (S2,LRTVOL)=0
+8 DO T^LRLABLD0
+9 SET LRTOP=$PIECE($GET(^LAB(62,+$PIECE(LRNODE0,U,3),0)),U,3)
IF $LENGTH(LRTOP)
SET S2=$PIECE(^(0),U,5)
+10 WRITE !?28,$SELECT(S2="":" ",LRTVOL>S2:"Large ",1:"Small "),LRTOP," ",$SELECT($GET(LRTVOL):LRTVOL,1:1)," mL ",!
+11 QUIT
+12 ;
CHDR ;
+1 WRITE !?10,"<CONTINUE NEXT PAGE # "_PAGE+1_" >"
+2 SET CHDR=1
DO PHDR
SET CHDR=0
+3 QUIT
+4 ;
PAT ;
+1 SET LRSNN=""
+2 FOR
SET LRSNN=$ORDER(^TMP($JOB,"LR",LRODT,LRCT,LRCLOC,LRPNM,LRSNN))
if LRSNN=""!($GET(LREND))
QUIT
Begin DoDot:1
+3 if LRPICK=1
WRITE !
+4 KILL LRNEW
+5 DO PRINT
End DoDot:1
+6 QUIT
PRINT ;
+1 SET LRSN=+$PIECE(LRSNN,"*",2)
+2 if '$DATA(^LRO(69,LRODT,1,LRSN,0))#2
QUIT
SET LRNODE0=^(0)
SET LRCE=$GET(^(.1))
if 'LRCE
QUIT
+3 ; Print labels
IF LRPICK=2
DO SETUP^LRLABLD0
QUIT
+4 SET LRDFN=+LRNODE0
KILL LRDPF
+5 DO PT^LRX
if $GET(LREND)!(+LRDPF'=2)
QUIT
+6 if $GET(LREND)
QUIT
+7 SET LRTYPE=""
SET LRPORD=1
SET LRTOP=$PIECE($GET(^LAB(62,+$PIECE(LRNODE0,U,3),0)),U)
+8 SET LRORD=$GET(^LRO(69,LRODT,1,LRSN,.1))
+9 ; Collection type
IF $LENGTH($PIECE(LRNODE0,U,4))
SET LRTYPE=$GET(LRCOLTY($PIECE(LRNODE0,U,4)))
+10 IF LRTYPE=""
SET LRTYPE="Unknown"
+11 IF $Y>(IOSL-4)
DO HDR
+12 SET LRSP=0
IF '$DATA(LRNEW)
DO PHDR
SET LRNEW=LRPNM
+13 IF LRNEW'=LRPNM
DO PHDR
+14 FOR TAB=5:35
SET LRSP=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRSP))
if LRSP<1
QUIT
Begin DoDot:1
+15 NEW LRURGA
+16 if '$DATA(^LRO(69,LRODT,1,LRSN,2,LRSP,0))
QUIT
+17 SET LRTEST=^LRO(69,LRODT,1,LRSN,2,LRSP,0)
SET LRURGN=$PIECE(LRTEST,U,2)
if 'LRURGN
SET LRURGN=9
+18 ; Test cancelled
IF $PIECE(LRTEST,"^",11)
QUIT
+19 SET LRURGA=$$URGA^LRLABLD(+LRURGN)
+20 SET LRTEST=$PIECE($GET(^LAB(60,+$PIECE(LRTEST,U),0)),U)
+21 IF TAB>45
SET TAB=5
WRITE !
IF $Y>(IOSL-4)
DO HDR
+22 WRITE ?TAB,$SELECT(LRURGN<3:"** ",1:"")," (",$PIECE(LRURGA,"^"),") ",LRTEST
End DoDot:1
+23 QUIT
DEV ;
+1 KILL %ZIS
SET %ZIS=""
DO ^%ZIS
if POP
QUIT
+2 USE IO
DO INIT
WRITE !!
if $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
+3 DO ^%ZISC
+4 QUIT
+5 ;
EOP ; End-of-page
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="E"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
SET LREND=1
+5 QUIT
+6 ;
END ;
+1 ; Called by LRLABLD0, LRLABLDS
+2 IF $GET(LRPICK)=1
if $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 IF '$TEST
DO ^%ZISC
+5 DO KVA^VADPT
+6 KILL ^TMP($JOB)
+7 KILL A,DIR,DUOUT,DTOUT,DIRUT
+8 KILL LRBARID,LRCOLTY,LREND,LRHEAD,LRNODE0,LRORD,LRPCT,LRUID
+9 KILL LRPERH,LRPERT,LRSP,LRTEST,LRTYPE,LRURGN,TAB
+10 KILL LRWRD,LRLOCF1,LRLOCF,LRCHLOC,LRDPF,J,S,C,%ZIS,%DT,DIC,DFN,I,L9,LRACC,LRCE,LRCLTY,LRDAT
+11 KILL LRPRAC,CNT,LRCLOC,LRCT,LRNEWL,LRORDN,LRPICK,LRPNM,LRSING,LRSNN,LRTREA
+12 KILL PAGE,D0,D1,LRPRTDT
+13 KILL LRDFN,LRINFW,LRLABEL,LRLLOC,LRODT,LRCT0,LRPREF,LRRB,LRSN,LRSSP
+14 KILL LRTJ,LRTJDATA,LRTOP,LRTS,LRTV,LRTVOL,LRURG,LRURGA,LRURG0,LN,LRSTOP,LRTIC
+15 KILL LRDTC,LRTXT,LRVOL,LRXL,N,NODE,S1,S2,T,Y,Y1,Y2
+16 KILL ZTSAVE,ZTIO,ZTRTN,ZTDESC
+17 KILL AGE,DOB,PNM,SEX,SSN,POP,E,VA,LRY1,VAERR,X
+18 QUIT
