LRLLS2 ;SLC/RWF/MILW/JMC- LOAD LIST FIX UP ;2/5/91 14:40 ;
;;5.2;LAB SERVICE;**116**;Sep 27, 1994
;MILW/JMC 4/16/93 Commented out line "DR2", inserted line at "DR2+1", prevent tests from being deleted fro accession file if control.
SETONE ;from LRLLS
S ^LRO(68.2,LRINST,1,LRTRAY,0)=LRTRAY_U_DT_U_DUZ_U_LRAA
S ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)=LRAA_U_LRAD_U_LRAN_U_LRWPROF
S $P(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0),U,5)=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:0)
F LRIX=0:0 S LRIX=$O(^TMP("LR",$J,"T",LRIX)) Q:LRIX="" S LRTX=^(LRIX) D MV2
Q
MV2 S ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,LRIX,0)=LRTX,$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRIX,0),U,3)=LRINST_";"_LRTRAY_";"_LRCUP
S ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,0)="^68.222^"_LRIX_"^1"
Q
WHATEST ;from LRLLS
K X,G2 S G2=0 F I=0:0 S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<1 I '$P(^(I,0),U,3),($D(^LRO(68.2,LRINST,10,LRWPROF,1,"B",I))) S G2=G2+1,G2(G2)=I,G2(G2,0)=^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0)
I G2<1 S X=U W !,"NO TESTS FREE TO ADD" K G2 Q
S G4="$P(^LAB(60,+G2(I,0),0),U,1)",G1="What test(s) to add?" D GROUP^LRWU2
F I=0:0 S I=$O(X(I)) Q:I'>0 S ^TMP("LR",$J,"T",G2(I))=G2(I,0)
K G1,G2,G4 Q
SHOW ;from LRLLS
S LRDFN=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:-1) Q:LRDFN<1 S X=^LR(LRDFN,0)
WHO ;from LRLLS
S LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX W !,PNM,?40,SSN Q
Q
CURRENT ;from LRLLS
S X=$S($D(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:""),%=0 W:X="" !,"NOTHING THERE" Q:X=""
S X=$S($D(^LRO(68,+X,1,+$P(X,U,2),1,+$P(X,U,3),0)):^(0),1:"") W:X="" !,"NO ACCESSION THERE" Q:X="" W:X'="" !,"ACCESSION: ",^(.2) S X=^LR(+X,0)
D WHO W !?10 S %=1 D YN^DICN Q
DROP ;from LRLLS
Q:$D(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0))[0 S X=^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0),LRDWL=+$P(X,U,1),LRDWDT=+$P(X,U,2),LRDWLE=+$P(X,U,3)
I '$D(^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,0)) K ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP) Q
S LRDPF=$P(^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,0),U,2),LRDFN=+^(0) W !,$S($D(^(.2)):^(.2),1:"")
F T=0:0 S T=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,T)) Q:T<1 I $D(^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,4,T,0)) S $P(^(0),U,3)="" D:LRDPF=62.3 DR2
K ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP) K:$O(^LRO(68.2,LRINST,1,LRTRAY,1,0))=""&($D(LRHOLD)'=11) ^LRO(68.2,LRINST,1,LRTRAY) Q
DR2 ;K:$D(LRCTRL) ^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,4,T) Q ;KILL TEST FROM CONTROL
Q
CLRALL ;from LRLLS
S LRCTRL=1
F LRTRAY=0:0 S LRTRAY=$O(^LRO(68.2,LRINST,1,LRTRAY)) Q:LRTRAY<1 F LRCUP=0:0 S LRCUP=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP)) Q:LRCUP<1 W !,$J(LRTRAY,3),$J(LRCUP,4) D DROP
K ^LRO(68.2,LRINST,2) ;CLEAR THE LAST LOAD INFO
K ^LRO(68.2,LRINST,1),LRCTRL,LRINST,LRTRAY,LRCUP Q
CLRBYTRY ;clear loadlist by tray, from LRLLS
W !!,"This option will remove entries from the specified tray(s) and",!,"make the accession(s) again available for adding to a worklist or loadlist.",!
S LREND=0 D LRINST^LRLLS G END:LRINST<1
CT1 W !,"STARTING ",$S(LRTYPE:"TRAY",1:"SEQUENCE #"),": FIRST//" R X:DTIME Q:X="^"
S LRST=$S(X="":1,1:+X) G CT1:LRST<1!(LRST>99999)
CT2 W !,"LAST ",$S(LRTYPE:"TRAY",1:"SEQUENCE #"),": LAST//" R X:DTIME Q:X="^"
S LRET=$S(X="":99999,1:+X) G CT2:LRET<1!(LRET>99999) S LRCTRL=1
W !,"UNLOADING THE FOLLOWING ACCESSIONS"
F LRTRAY=$S(LRTYPE:LRST,1:1)-.01:0 S LRTRAY=$O(^LRO(68.2,LRINST,1,LRTRAY)) Q:(LRTRAY<1)!(LRTRAY>LRET) D CT2A
END K LRCTRL,LRST,LRET,LRINST,LRTRAY,LRCUP
K A,DIC,I,K,LRAD,LRDFN,LRDPF,LRDWDT,LRDWL,LRDWLE,LREND,LRFULL,LRINSTIT,LRMAXCUP,LRTRANS,LRTYPE,T,X,Y,Z
Q
CT2A W:LRTYPE !,"TRAY ",LRTRAY F LRCUP=$S(LRTYPE:0,1:LRST-.01):0 S LRCUP=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP)) Q:LRCUP<1!(LRCUP>$S('LRTYPE:LRET,1:99999)) W:'LRTYPE !,"SEQ# ",LRCUP D DROP
K:LRTYPE ^LRO(68.2,LRINST,1,LRTRAY)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLLS2 3737 printed Dec 13, 2024@02:16:25 Page 2
LRLLS2 ;SLC/RWF/MILW/JMC- LOAD LIST FIX UP ;2/5/91 14:40 ;
+1 ;;5.2;LAB SERVICE;**116**;Sep 27, 1994
+2 ;MILW/JMC 4/16/93 Commented out line "DR2", inserted line at "DR2+1", prevent tests from being deleted fro accession file if control.
SETONE ;from LRLLS
+1 SET ^LRO(68.2,LRINST,1,LRTRAY,0)=LRTRAY_U_DT_U_DUZ_U_LRAA
+2 SET ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)=LRAA_U_LRAD_U_LRAN_U_LRWPROF
+3 SET $PIECE(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0),U,5)=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:0)
+4 FOR LRIX=0:0
SET LRIX=$ORDER(^TMP("LR",$JOB,"T",LRIX))
if LRIX=""
QUIT
SET LRTX=^(LRIX)
DO MV2
+5 QUIT
MV2 SET ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,LRIX,0)=LRTX
SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRIX,0),U,3)=LRINST_";"_LRTRAY_";"_LRCUP
+1 SET ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,0)="^68.222^"_LRIX_"^1"
+2 QUIT
WHATEST ;from LRLLS
+1 KILL X,G2
SET G2=0
FOR I=0:0
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<1
QUIT
IF '$PIECE(^(I,0),U,3)
IF ($DATA(^LRO(68.2,LRINST,10,LRWPROF,1,"B",I)))
SET G2=G2+1
SET G2(G2)=I
SET G2(G2,0)=^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0)
+2 IF G2<1
SET X=U
WRITE !,"NO TESTS FREE TO ADD"
KILL G2
QUIT
+3 SET G4="$P(^LAB(60,+G2(I,0),0),U,1)"
SET G1="What test(s) to add?"
DO GROUP^LRWU2
+4 FOR I=0:0
SET I=$ORDER(X(I))
if I'>0
QUIT
SET ^TMP("LR",$JOB,"T",G2(I))=G2(I,0)
+5 KILL G1,G2,G4
QUIT
SHOW ;from LRLLS
+1 SET LRDFN=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:-1)
if LRDFN<1
QUIT
SET X=^LR(LRDFN,0)
WHO ;from LRLLS
+1 SET LRDPF=$PIECE(X,U,2)
SET DFN=$PIECE(X,U,3)
DO PT^LRX
WRITE !,PNM,?40,SSN
QUIT
+2 QUIT
CURRENT ;from LRLLS
+1 SET X=$SELECT($DATA(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:"")
SET %=0
if X=""
WRITE !,"NOTHING THERE"
if X=""
QUIT
+2 SET X=$SELECT($DATA(^LRO(68,+X,1,+$PIECE(X,U,2),1,+$PIECE(X,U,3),0)):^(0),1:"")
if X=""
WRITE !,"NO ACCESSION THERE"
if X=""
QUIT
if X'=""
WRITE !,"ACCESSION: ",^(.2)
SET X=^LR(+X,0)
+3 DO WHO
WRITE !?10
SET %=1
DO YN^DICN
QUIT
DROP ;from LRLLS
+1 if $DATA(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0))[0
QUIT
SET X=^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)
SET LRDWL=+$PIECE(X,U,1)
SET LRDWDT=+$PIECE(X,U,2)
SET LRDWLE=+$PIECE(X,U,3)
+2 IF '$DATA(^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,0))
KILL ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP)
QUIT
+3 SET LRDPF=$PIECE(^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,0),U,2)
SET LRDFN=+^(0)
WRITE !,$SELECT($DATA(^(.2)):^(.2),1:"")
+4 FOR T=0:0
SET T=$ORDER(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,T))
if T<1
QUIT
IF $DATA(^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,4,T,0))
SET $PIECE(^(0),U,3)=""
if LRDPF=62.3
DO DR2
+5 KILL ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP)
if $ORDER(^LRO(68.2,LRINST,1,LRTRAY,1,0))=""&($DATA(LRHOLD)'=11)
KILL ^LRO(68.2,LRINST,1,LRTRAY)
QUIT
DR2 ;K:$D(LRCTRL) ^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,4,T) Q ;KILL TEST FROM CONTROL
+1 QUIT
CLRALL ;from LRLLS
+1 SET LRCTRL=1
+2 FOR LRTRAY=0:0
SET LRTRAY=$ORDER(^LRO(68.2,LRINST,1,LRTRAY))
if LRTRAY<1
QUIT
FOR LRCUP=0:0
SET LRCUP=$ORDER(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP))
if LRCUP<1
QUIT
WRITE !,$JUSTIFY(LRTRAY,3),$JUSTIFY(LRCUP,4)
DO DROP
+3 ;CLEAR THE LAST LOAD INFO
KILL ^LRO(68.2,LRINST,2)
+4 KILL ^LRO(68.2,LRINST,1),LRCTRL,LRINST,LRTRAY,LRCUP
QUIT
CLRBYTRY ;clear loadlist by tray, from LRLLS
+1 WRITE !!,"This option will remove entries from the specified tray(s) and",!,"make the accession(s) again available for adding to a worklist or loadlist.",!
+2 SET LREND=0
DO LRINST^LRLLS
if LRINST<1
GOTO END
CT1 WRITE !,"STARTING ",$SELECT(LRTYPE:"TRAY",1:"SEQUENCE #"),": FIRST//"
READ X:DTIME
if X="^"
QUIT
+1 SET LRST=$SELECT(X="":1,1:+X)
if LRST<1!(LRST>99999)
GOTO CT1
CT2 WRITE !,"LAST ",$SELECT(LRTYPE:"TRAY",1:"SEQUENCE #"),": LAST//"
READ X:DTIME
if X="^"
QUIT
+1 SET LRET=$SELECT(X="":99999,1:+X)
if LRET<1!(LRET>99999)
GOTO CT2
SET LRCTRL=1
+2 WRITE !,"UNLOADING THE FOLLOWING ACCESSIONS"
+3 FOR LRTRAY=$SELECT(LRTYPE:LRST,1:1)-.01:0
SET LRTRAY=$ORDER(^LRO(68.2,LRINST,1,LRTRAY))
if (LRTRAY<1)!(LRTRAY>LRET)
QUIT
DO CT2A
END KILL LRCTRL,LRST,LRET,LRINST,LRTRAY,LRCUP
+1 KILL A,DIC,I,K,LRAD,LRDFN,LRDPF,LRDWDT,LRDWL,LRDWLE,LREND,LRFULL,LRINSTIT,LRMAXCUP,LRTRANS,LRTYPE,T,X,Y,Z
+2 QUIT
CT2A if LRTYPE
WRITE !,"TRAY ",LRTRAY
FOR LRCUP=$SELECT(LRTYPE:0,1:LRST-.01):0
SET LRCUP=$ORDER(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP))
if LRCUP<1!(LRCUP>$SELECT('LRTYPE
QUIT
if 'LRTYPE
WRITE !,"SEQ# ",LRCUP
DO DROP
+1 if LRTYPE
KILL ^LRO(68.2,LRINST,1,LRTRAY)
+2 QUIT
