- LRLLS2 ; IHS/DIR/FJE - LOAD LIST FIX UP 2/5/91 14:40 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;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
- S LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX W !,PNM,?40,HRCN Q ;IHS/ANMC/CLS 08/18/96
- 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
- LRLLS2 ; IHS/DIR/FJE - LOAD LIST FIX UP 2/5/91 14:40 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;**116**;Sep 27, 1994
- +4 ;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 ;S LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX W !,PNM,?40,SSN Q
- +2 ;IHS/ANMC/CLS 08/18/96
- SET LRDPF=$PIECE(X,U,2)
- SET DFN=$PIECE(X,U,3)
- DO PT^LRX
- WRITE !,PNM,?40,HRCN
- QUIT
- +3 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
