source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLLS2.m@ 808

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