- 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 Jan 18, 2025@03:16:44 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