source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRLLS2.m@ 1487

Last change on this file since 1487 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1LRLLS2 ;SLC/RWF/MILW/JMC- LOAD LIST FIX UP ;2/5/91 14:40 ;
2 ;;5.2;LAB SERVICE;**116**;Sep 27, 1994
3 ;MILW/JMC 4/16/93 Commented out line "DR2", inserted line at "DR2+1", prevent tests from being deleted fro accession file if control.
4SETONE ;from LRLLS
5 S ^LRO(68.2,LRINST,1,LRTRAY,0)=LRTRAY_U_DT_U_DUZ_U_LRAA
6 S ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)=LRAA_U_LRAD_U_LRAN_U_LRWPROF
7 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)
8 F LRIX=0:0 S LRIX=$O(^TMP("LR",$J,"T",LRIX)) Q:LRIX="" S LRTX=^(LRIX) D MV2
9 Q
10MV2 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
11 S ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,0)="^68.222^"_LRIX_"^1"
12 Q
13WHATEST ;from LRLLS
14 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)
15 I G2<1 S X=U W !,"NO TESTS FREE TO ADD" K G2 Q
16 S G4="$P(^LAB(60,+G2(I,0),0),U,1)",G1="What test(s) to add?" D GROUP^LRWU2
17 F I=0:0 S I=$O(X(I)) Q:I'>0 S ^TMP("LR",$J,"T",G2(I))=G2(I,0)
18 K G1,G2,G4 Q
19SHOW ;from LRLLS
20 S LRDFN=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:-1) Q:LRDFN<1 S X=^LR(LRDFN,0)
21WHO ;from LRLLS
22 S LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX W !,PNM,?40,SSN Q
23 Q
24CURRENT ;from LRLLS
25 S X=$S($D(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:""),%=0 W:X="" !,"NOTHING THERE" Q:X=""
26 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)
27 D WHO W !?10 S %=1 D YN^DICN Q
28DROP ;from LRLLS
29 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)
30 I '$D(^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,0)) K ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP) Q
31 S LRDPF=$P(^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,0),U,2),LRDFN=+^(0) W !,$S($D(^(.2)):^(.2),1:"")
32 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
33 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
34DR2 ;K:$D(LRCTRL) ^LRO(68,LRDWL,1,LRDWDT,1,LRDWLE,4,T) Q ;KILL TEST FROM CONTROL
35 Q
36CLRALL ;from LRLLS
37 S LRCTRL=1
38 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
39 K ^LRO(68.2,LRINST,2) ;CLEAR THE LAST LOAD INFO
40 K ^LRO(68.2,LRINST,1),LRCTRL,LRINST,LRTRAY,LRCUP Q
41CLRBYTRY ;clear loadlist by tray, from LRLLS
42 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.",!
43 S LREND=0 D LRINST^LRLLS G END:LRINST<1
44CT1 W !,"STARTING ",$S(LRTYPE:"TRAY",1:"SEQUENCE #"),": FIRST//" R X:DTIME Q:X="^"
45 S LRST=$S(X="":1,1:+X) G CT1:LRST<1!(LRST>99999)
46CT2 W !,"LAST ",$S(LRTYPE:"TRAY",1:"SEQUENCE #"),": LAST//" R X:DTIME Q:X="^"
47 S LRET=$S(X="":99999,1:+X) G CT2:LRET<1!(LRET>99999) S LRCTRL=1
48 W !,"UNLOADING THE FOLLOWING ACCESSIONS"
49 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
50END K LRCTRL,LRST,LRET,LRINST,LRTRAY,LRCUP
51 K A,DIC,I,K,LRAD,LRDFN,LRDPF,LRDWDT,LRDWL,LRDWLE,LREND,LRFULL,LRINSTIT,LRMAXCUP,LRTRANS,LRTYPE,T,X,Y,Z
52 Q
53CT2A 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
54 K:LRTYPE ^LRO(68.2,LRINST,1,LRTRAY)
55 Q
Note: See TracBrowser for help on using the repository browser.