LRLLP5 ;SLC/RWA/MILW/MKK- EXPANDED TRAY LIST PRINT ;2/5/91 14:39 ; [ 04/14/2003 9:24 AM ]
;;5.2;LR;**1004,1018,1019**;MAR 25, 2005
;;5.2;LAB SERVICE;**116,153**;Sep 27, 1994
S:'LRTYPE LRTRAY=LRST S (LREXIT,LREND,LRPROF)=0,X=$O(^LRO(68.2,LRINST,1,LRTRAY)) I X S Y=$O(^(X,1,0)) I Y S LRPROF=+$P(^(Y,0),U,4)
S LRFSTP=1
D LOOP,END Q
Q
LOOP F S LRTRAY=$O(^LRO(68.2,LRINST,1,LRTRAY)) Q:LRTRAY<1!(LRTRAY>LRLLT)!(LREND) S LRDC=1 D CUP Q:LREND!($G(LREXIT)) S LRCUP=0
Q
CUP F II=0:0 S LRCUP=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP)) Q:LRCUP=""!($G(LREXIT)) D LP2 S LREND=$S('LRTYPE&(LRCUP>LRLLT):1,'LRTYPE&(LRCUP=LRLLT):1,1:0) Q:LREND
Q
LP2 S LRLL=$S($D(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:""),LRTEST="" I LRPROF'=+$P(LRLL,U,4) S LRPROF=+$P(LRLL,U,4) K:LRDC'=LRPROF PNM S LRDC=LRPROF
Q:LRLL="" D HED:$Y+8>IOSL!(LRDC) Q:$G(LREXIT)
I LRTYPE W ! W:'LRALTH "TRAY:",$J(LRTRAY,3)," CUP:",$J(LRCUP,3) D LRLINE Q
I 'LRTYPE W ! W:'LRALTH "SEQ: ",$J(LRCUP,4) D LRLINE Q
W ! W:'LRALTH "TRAY:",$J(LRTRAY,3)," CUP:",$J(LRCUP,3) D LRLINE Q
LRLINE S LRAA=+LRLL,LRAD=+$P(LRLL,U,2),LRAN=+$P(LRLL,U,3) D MOVE^LRLLP4:$D(^TMP($J,LRPROF))=0
S LRDFN=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:"")
I LRDFN="" K ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP) D DASH^LRX Q ; IF NOTHING THERE, GET RID OF IT
K ^TMP("LR",$J,"T"),LRTSTS S LRTEST="",LRURG=99 G BLANK:LRLL=""
S J=0 F S J=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,J)) Q:J<1 S X=$P(^(J,0),U,2),^TMP("LR",$J,"T",J)="",LRTEST=LRTEST_J_U S:X<LRURG LRURG=+X
I LRXPD K ^TMP("LR",$J,"T"),LRTSTS,LRORD D ^LREXPD
K LRTEST,LRORD F I=0:0 S I=$O(^TMP("LR",$J,"T",I)) Q:I'>0 S LRORD($S($D(^TMP($J,LRPROF,I)):^(I),1:I+999))=I
LP4 S LRACC=^LRO(68,LRAA,1,LRAD,1,LRAN,.2) W:$X=0 LRACC
I $L(LRDFN) S LRLLOC=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7),LRDOC=$P(^(0),U,8),LRCDT=$P(^(3),U,1),LRIDT=$S($D(^(3)):9999999-^(3),1:0)
S LRSPEC=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:0),LRSISPEC=+$P(^(0),U,2),LRSPEC=$S($D(^LAB(61,LRSPEC,0)):$P(^(0),U,1),1:"")
S LRSISPEC=$S($D(^LAB(62,LRSISPEC,0)):$P(^(0),U),1:"")
S X=LRDOC,LRLLOC=LRLLOC_" "_$S($D(LRURG(LRURG)):LRURG(LRURG),1:"") D DOC^LRX
S DFN=+$P(^LR(LRDFN,0),U,3),LRDPF=+$P(^(0),U,2),LRV=0,LRV=$S($D(^LR(LRDFN,"CH",LRIDT,0)):$P(^(0),U,3),1:0) D PT^LRX
;----- BEGIN IHS MODIFICATIONS LR*5.2*1019
;----- Next line needs to be commented out; it was not commented out in Patch 18
; W ?20 W:LRDPF=2 $E(PNM,1,30),?50,SSN W:LRDPF'=2 $E(PNM_" "_SSN(2),1,60) W ?64,LRACC W:LRV ?76,"Ver" W ?86,$E(LRDOC,1,20) S Y=LRCDT D ADD^LRX W ?110,Y D LEDI
;----- END IHS MODIFICATIONS LR*5.2*1019
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W ?20 W:LRDPF=2 $E(PNM,1,30),?50,HRCN W:LRDPF'=2 $E(PNM_" "_SSN(2),1,60) W ?64,LRACC W:LRV ?76,"Ver" W ?86,$E(LRDOC,1,20) S Y=LRCDT D ADD^LRX W ?110,Y D LEDI ;IHS/ANMC/CLS 08/18/96
;----- EN DIHS MODIFICATIONS
LP3 ;
I 'LRSHORT F J=0:0 S J=$O(LRORD(J)) Q:J<1 D:($Y+5)>IOSL HED,SH Q:$G(LREXIT) S I=LRORD(J) W !,?18,$E(LRLINE,1,31) W:LRLLOC]"" ?56,LRLLOC S LRLLOC="" W !,?18,$P(^LAB(60,I,0),"^",1),?50,LRSPEC D LRSPEC
Q:$G(LREXIT)
I LRSHORT W !?18,$E(LRLINE,1,31),?56,LRSPEC D LRSPEC W !?18 F J=0:0 S J=$O(LRORD(J)) Q:J<1 D:($Y+5)>IOSL HED,SH Q:$G(LREXIT) S I=LRORD(J) W:$X>19 ", " W $P(^LAB(60,I,0),"^",1) I $X>50 W !?18
Q:$G(LREXIT)
I $D(LRAA),$D(^LRO(68,+LRAA,0)),$P(^(0),U,2)="MI" W:$D(^LR(LRDFN,"MI",LRIDT,99)) !?20,^(99)
D DASH^LRX Q
LP5 S L=$P(^TMP("LR",$J,"T",I),U,5),L=$P(L,";",2) I LRIDT,$D(^LR(LRDFN,"CH",LRIDT,L)) W ?37,$J(^(L),8)
W:LRV ?45,"Ver" Q
Q
BLANK D DASH^LRX Q
HED ;
D:$E(IOST,1,2)="C-" TERM
Q:$G(LREXIT)
W:LRDC!(IOSL\2<$Y) @IOF
;W:LRDC!($Y>(IOSL-$S($E(IOST,1,2)="C-":4,1:8))) @IOF
W !!,$S(LRTYPE>0:"LOAD",1:"WORK"),"-LIST FOR ",$P(^LRO(68.2,LRINST,0),U,1),$S($D(^LRO(68.2,LRINST,10,LRPROF,0)):" (Profile: "_$P(^(0),U,1)_")",1:""),?112,LRNOW
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1019 -- LRLL variable can be null
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
; S:'$D(LRAA) LRAA=+LRLL D:LRDC LRENT2^LRWLHEAD W ! ;IHS/ANMC/CLS 08/18/96 print worklist heading on first page only
S:'$D(LRAA) LRAA=+$G(LRLL) D:LRDC LRENT2^LRWLHEAD W ! ;IHS/ANMC/CLS 08/18/96 print worklist heading on first page only
;----- END IHS MODIFCIATIONS
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1019
W !,?18,"Name",?50,"ID#",?64,"Acc #",?86,"Requested By",?110,"Coll. Date/Time"
D DASH^LRX I '$D(PNM) S LRDC=0 Q
W !,"Cont'd"
S LRDC=0
Q
SH Q:$G(LREXIT)
W ?20 W:LRDPF=2 $E(PNM,1,30),?50,SSN W:LRDPF'=2 $E(PNM_" "_SSN(2),1,60) W ?64,LRACC W:LRV ?76,"Ver" W ?86,$E(LRDOC,1,20) S Y=LRCDT D ADD^LRX W ?110,Y,!
W:LRSHORT !,?18
Q
TERM I $G(LRFSTP) K LRFSTP Q
S DIR(0)="E" D ^DIR S:$D(DIRUT) LREXIT=1 K DIR,DIRUT,Y,X
Q
END K LRFSTP,II,LREND W !
I $E(IOST,1,2)="C-",'$G(LREXIT) D TERM
W:$E(IOST,1,2)'="C-" @IOF
D ^%ZISC Q
LRSPEC ;
I $D(LRAA),$D(^LRO(68,+LRAA,0)),$P(^(0),U,2)="MI",$D(LRSISPEC),$L(LRSISPEC) S TAB=$S(LRSHORT:56,1:50) W !,?TAB,LRSISPEC K TAB
Q
LEDI ; print UID and LEDI information
N LRUIDX S LRUIDX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)) W !,?64,"UID: ",$P(LRUIDX,"^")
S Y=$P(LRUIDX,"^",2) I Y S C=$P(^DD(68.02,16.1,0),"^",2) D Y^DIQ W ?86,"Ordering Site: "_$E(Y,1,20),!
S X=$P(LRUIDX,"^",5) I X'="" W ?86,"Ordering Site UID: "_X,!
S Y=$P(LRUIDX,"^",3) I Y,Y'=$P(LRUIDX,"^",2) S C=$P(^DD(68.02,16.2,0),"^",2) D Y^DIQ W ?86,"Collecting Site: "_$E(Y,1,20),!
S X=$P(LRUIDX,"^",4) I X'="",X'=$P(LRUIDX,"^") W ?86,"Host UID: "_X
Q
LRLLP5 ;SLC/RWA/MILW/MKK- EXPANDED TRAY LIST PRINT ;2/5/91 14:39 ; [ 04/14/2003 9:24 AM ]
+1 ;;5.2;LR;**1004,1018,1019**;MAR 25, 2005
+2 ;;5.2;LAB SERVICE;**116,153**;Sep 27, 1994
+3 IF 'LRTYPE
SET LRTRAY=LRST
SET (LREXIT,LREND,LRPROF)=0
SET X=$ORDER(^LRO(68.2,LRINST,1,LRTRAY))
IF X
SET Y=$ORDER(^(X,1,0))
IF Y
SET LRPROF=+$PIECE(^(Y,0),U,4)
+4 SET LRFSTP=1
+5 DO LOOP
DO END
QUIT
+6 QUIT
LOOP FOR
SET LRTRAY=$ORDER(^LRO(68.2,LRINST,1,LRTRAY))
IF LRTRAY<1!(LRTRAY>LRLLT)!(LREND)
QUIT
SET LRDC=1
DO CUP
IF LREND!($GET(LREXIT))
QUIT
SET LRCUP=0
+1 QUIT
CUP FOR II=0:0
SET LRCUP=$ORDER(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP))
IF LRCUP=""!($GET(LREXIT))
QUIT
DO LP2
SET LREND=$SELECT('LRTYPE&(LRCUP>LRLLT):1,'LRTYPE&(LRCUP=LRLLT):1,1:0)
IF LREND
QUIT
+1 QUIT
LP2 SET LRLL=$SELECT($DATA(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:"")
SET LRTEST=""
IF LRPROF'=+$PIECE(LRLL,U,4)
SET LRPROF=+$PIECE(LRLL,U,4)
IF LRDC'=LRPROF
KILL PNM
SET LRDC=LRPROF
+1 IF LRLL=""
QUIT
IF $Y+8>IOSL!(LRDC)
DO HED
IF $GET(LREXIT)
QUIT
+2 IF LRTYPE
WRITE !
IF 'LRALTH
WRITE "TRAY:",$JUSTIFY(LRTRAY,3)," CUP:",$JUSTIFY(LRCUP,3)
DO LRLINE
QUIT
+3 IF 'LRTYPE
WRITE !
IF 'LRALTH
WRITE "SEQ: ",$JUSTIFY(LRCUP,4)
DO LRLINE
QUIT
+4 WRITE !
IF 'LRALTH
WRITE "TRAY:",$JUSTIFY(LRTRAY,3)," CUP:",$JUSTIFY(LRCUP,3)
DO LRLINE
QUIT
LRLINE SET LRAA=+LRLL
SET LRAD=+$PIECE(LRLL,U,2)
SET LRAN=+$PIECE(LRLL,U,3)
IF $DATA(^TMP($JOB,LRPROF))=0
DO MOVE^LRLLP4
+1 SET LRDFN=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:"")
+2 ; IF NOTHING THERE, GET RID OF IT
IF LRDFN=""
KILL ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP)
DO DASH^LRX
QUIT
+3 KILL ^TMP("LR",$JOB,"T"),LRTSTS
SET LRTEST=""
SET LRURG=99
IF LRLL=""
GOTO BLANK
+4 SET J=0
FOR
SET J=$ORDER(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,J))
IF J<1
QUIT
SET X=$PIECE(^(J,0),U,2)
SET ^TMP("LR",$JOB,"T",J)=""
SET LRTEST=LRTEST_J_U
IF X<LRURG
SET LRURG=+X
+5 IF LRXPD
KILL ^TMP("LR",$JOB,"T"),LRTSTS,LRORD
DO ^LREXPD
+6 KILL LRTEST,LRORD
FOR I=0:0
SET I=$ORDER(^TMP("LR",$JOB,"T",I))
IF I'>0
QUIT
SET LRORD($SELECT($DATA(^TMP($JOB,LRPROF,I)):^(I),1:I+999))=I
LP4 SET LRACC=^LRO(68,LRAA,1,LRAD,1,LRAN,.2)
IF $X=0
WRITE LRACC
+1 IF $LENGTH(LRDFN)
SET LRLLOC=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7)
SET LRDOC=$PIECE(^(0),U,8)
SET LRCDT=$PIECE(^(3),U,1)
SET LRIDT=$SELECT($DATA(^(3)):9999999-^(3),1:0)
+2 SET LRSPEC=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:0)
SET LRSISPEC=+$PIECE(^(0),U,2)
SET LRSPEC=$SELECT($DATA(^LAB(61,LRSPEC,0)):$PIECE(^(0),U,1),1:"")
+3 SET LRSISPEC=$SELECT($DATA(^LAB(62,LRSISPEC,0)):$PIECE(^(0),U),1:"")
+4 SET X=LRDOC
SET LRLLOC=LRLLOC_" "_$SELECT($DATA(LRURG(LRURG)):LRURG(LRURG),1:"")
DO DOC^LRX
+5 SET DFN=+$PIECE(^LR(LRDFN,0),U,3)
SET LRDPF=+$PIECE(^(0),U,2)
SET LRV=0
SET LRV=$SELECT($DATA(^LR(LRDFN,"CH",LRIDT,0)):$PIECE(^(0),U,3),1:0)
DO PT^LRX
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019
+7 ;----- Next line needs to be commented out; it was not commented out in Patch 18
+8 ; W ?20 W:LRDPF=2 $E(PNM,1,30),?50,SSN W:LRDPF'=2 $E(PNM_" "_SSN(2),1,60) W ?64,LRACC W:LRV ?76,"Ver" W ?86,$E(LRDOC,1,20) S Y=LRCDT D ADD^LRX W ?110,Y D LEDI
+9 ;----- END IHS MODIFICATIONS LR*5.2*1019
+10 ;
+11 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+12 ;IHS/ANMC/CLS 08/18/96
WRITE ?20
IF LRDPF=2
WRITE $EXTRACT(PNM,1,30),?50,HRCN
IF LRDPF'=2
WRITE $EXTRACT(PNM_" "_SSN(2),1,60)
WRITE ?64,LRACC
IF LRV
WRITE ?76,"Ver"
WRITE ?86,$EXTRACT(LRDOC,1,20)
SET Y=LRCDT
DO ADD^LRX
WRITE ?110,Y
DO LEDI
+13 ;----- EN DIHS MODIFICATIONS
LP3 ;
+1 IF 'LRSHORT
FOR J=0:0
SET J=$ORDER(LRORD(J))
IF J<1
QUIT
IF ($Y+5)>IOSL
DO HED
DO SH
IF $GET(LREXIT)
QUIT
SET I=LRORD(J)
WRITE !,?18,$EXTRACT(LRLINE,1,31)
IF LRLLOC]""
WRITE ?56,LRLLOC
SET LRLLOC=""
WRITE !,?18,$PIECE(^LAB(60,I,0),"^",1),?50,LRSPEC
DO LRSPEC
+2 IF $GET(LREXIT)
QUIT
+3 IF LRSHORT
WRITE !?18,$EXTRACT(LRLINE,1,31),?56,LRSPEC
DO LRSPEC
WRITE !?18
FOR J=0:0
SET J=$ORDER(LRORD(J))
IF J<1
QUIT
IF ($Y+5)>IOSL
DO HED
DO SH
IF $GET(LREXIT)
QUIT
SET I=LRORD(J)
IF $X>19
WRITE ", "
WRITE $PIECE(^LAB(60,I,0),"^",1)
IF $X>50
WRITE !?18
+4 IF $GET(LREXIT)
QUIT
+5 IF $DATA(LRAA)
IF $DATA(^LRO(68,+LRAA,0))
IF $PIECE(^(0),U,2)="MI"
IF $DATA(^LR(LRDFN,"MI",LRIDT,99))
WRITE !?20,^(99)
+6 DO DASH^LRX
QUIT
LP5 SET L=$PIECE(^TMP("LR",$JOB,"T",I),U,5)
SET L=$PIECE(L,";",2)
IF LRIDT
IF $DATA(^LR(LRDFN,"CH",LRIDT,L))
WRITE ?37,$JUSTIFY(^(L),8)
+1 IF LRV
WRITE ?45,"Ver"
QUIT
+2 QUIT
BLANK DO DASH^LRX
QUIT
HED ;
+1 IF $EXTRACT(IOST,1,2)="C-"
DO TERM
+2 IF $GET(LREXIT)
QUIT
+3 IF LRDC!(IOSL\2<$Y)
WRITE @IOF
+4 ;W:LRDC!($Y>(IOSL-$S($E(IOST,1,2)="C-":4,1:8))) @IOF
+5 WRITE !!,$SELECT(LRTYPE>0:"LOAD",1:"WORK"),"-LIST FOR ",$PIECE(^LRO(68.2,LRINST,0),U,1),$SELECT($DATA(^LRO(68.2,LRINST,10,LRPROF,0)):" (Profile: "_$PIECE(^(0),U,1)_")",1:""),?112,LRNOW
+6 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1019 -- LRLL variable can be null
+7 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+8 ; S:'$D(LRAA) LRAA=+LRLL D:LRDC LRENT2^LRWLHEAD W ! ;IHS/ANMC/CLS 08/18/96 print worklist heading on first page only
+9 ;IHS/ANMC/CLS 08/18/96 print worklist heading on first page only
IF '$DATA(LRAA)
SET LRAA=+$GET(LRLL)
IF LRDC
DO LRENT2^LRWLHEAD
WRITE !
+10 ;----- END IHS MODIFCIATIONS
+11 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1019
+12 WRITE !,?18,"Name",?50,"ID#",?64,"Acc #",?86,"Requested By",?110,"Coll. Date/Time"
+13 DO DASH^LRX
IF '$DATA(PNM)
SET LRDC=0
QUIT
+14 WRITE !,"Cont'd"
+15 SET LRDC=0
+16 QUIT
SH IF $GET(LREXIT)
QUIT
+1 WRITE ?20
IF LRDPF=2
WRITE $EXTRACT(PNM,1,30),?50,SSN
IF LRDPF'=2
WRITE $EXTRACT(PNM_" "_SSN(2),1,60)
WRITE ?64,LRACC
IF LRV
WRITE ?76,"Ver"
WRITE ?86,$EXTRACT(LRDOC,1,20)
SET Y=LRCDT
DO ADD^LRX
WRITE ?110,Y,!
+2 IF LRSHORT
WRITE !,?18
+3 QUIT
TERM IF $GET(LRFSTP)
KILL LRFSTP
QUIT
+1 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET LREXIT=1
KILL DIR,DIRUT,Y,X
+2 QUIT
END KILL LRFSTP,II,LREND
WRITE !
+1 IF $EXTRACT(IOST,1,2)="C-"
IF '$GET(LREXIT)
DO TERM
+2 IF $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
+3 DO ^%ZISC
QUIT
LRSPEC ;
+1 IF $DATA(LRAA)
IF $DATA(^LRO(68,+LRAA,0))
IF $PIECE(^(0),U,2)="MI"
IF $DATA(LRSISPEC)
IF $LENGTH(LRSISPEC)
SET TAB=$SELECT(LRSHORT:56,1:50)
WRITE !,?TAB,LRSISPEC
KILL TAB
+2 QUIT
LEDI ; print UID and LEDI information
+1 NEW LRUIDX
SET LRUIDX=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
WRITE !,?64,"UID: ",$PIECE(LRUIDX,"^")
+2 SET Y=$PIECE(LRUIDX,"^",2)
IF Y
SET C=$PIECE(^DD(68.02,16.1,0),"^",2)
DO Y^DIQ
WRITE ?86,"Ordering Site: "_$EXTRACT(Y,1,20),!
+3 SET X=$PIECE(LRUIDX,"^",5)
IF X'=""
WRITE ?86,"Ordering Site UID: "_X,!
+4 SET Y=$PIECE(LRUIDX,"^",3)
IF Y
IF Y'=$PIECE(LRUIDX,"^",2)
SET C=$PIECE(^DD(68.02,16.2,0),"^",2)
DO Y^DIQ
WRITE ?86,"Collecting Site: "_$EXTRACT(Y,1,20),!
+5 SET X=$PIECE(LRUIDX,"^",4)
IF X'=""
IF X'=$PIECE(LRUIDX,"^")
WRITE ?86,"Host UID: "_X
+6 QUIT
