- LRLL1 ;SLC/RWF - LOAD LIST SCAN. ;2/19/91 10:42 ;
- ;;5.2;LAB SERVICE;**116**;Sep 27, 1994
- L1 ;
- L +^LRO(68.2,LRINST,3) I $S($D(^LRO(68.2,LRINST,3)):^(3),1:0) W !,"Waiting for another build to finish.",$C(7),!!?5,"Type '^' to stop waiting." L -^LRO(68.2,LRINST,3) R X:DTIME G L1:X'[U Q
- G QUEUE:$D(IO("Q")) S (LRPCUP,LRAN,LRCNT)=0
- S ^LRO(68.2,LRINST,3)=1
- LP D BUILD
- I $D(LRALL) S LRPROF=$O(^LRO(68.2,LRINST,10,LRPROF)) I LRPROF>0 D PROF^LRLL3 G LP
- S ^LRO(68.2,LRINST,3)=0 L -^LRO(68.2,LRINST,3) I LRCNT=0 W !,"NO ENTRYS ADDED",$C(7) G END
- S ^LRO(68.2,LRINST,2)=DT_U_$P(^LRO(68.2,LRINST,2),U,2,3)_U_LRTRAY_U_LRCUP
- W !!,"LOAD LIST IS NOW SET UP"
- K LRCTRL,LRDSPEC,^TMP($J) D EN1^LRLLP G END ;GO PRINT
- BUILD W !!,"STARTING PROFILE ",$P(^LRO(68.2,LRINST,10,LRPROF,0),U,1)," SCAN",!
- I '$D(LRSTAR) S LRAD1=LRAD,LRAN=LRST-.01 F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)),LRADD=1 Q:LRAN<1!(LRAN>LRLLT) I $D(^(LRAN,0))#2 S LRDFN=+^(0),LRDPF=$P(^(0),U,2),LRIDT=9999999-$S($D(^(3)):^(3),1:0) D TCHK
- I $D(LRSTAR) S LRAD1=$E(LRSTAR,1,3)-1_"0000" S A=0 F S LRAD1=$O(^LRO(68,LRAA,1,LRAD1)) Q:LRAD1<1!(LRAD1>LRWDTL) D AC
- I $O(^TMP($J,-1,0))="" W !,"NO ENTRY FOUND!",! Q
- F LRIIX=0:0 S LRIIX=$O(^LRO(68.2,LRINST,10,LRPROF,4,LRIIX)) Q:LRIIX<1 S LRIFN=+^(LRIIX,0),LRCT=LRIFN D CTRLTST^LRLL3 S LRTST=$P(X,U,2,99) D GNCUP^LRLL2,LRCTRL^LRLL4
- W !,"SCAN DONE." D ^LRLL2
- Q
- TC1 IF '$P(T1,U,3),'$P(T1,U,5),$D(LRTP(+T1)),(LRTP(+T1)=LRSP!(LRTP(+T1)=""))
- S:'$T&('LRSPLIT) E=1 I $T S LRTSL(I1)=T1,LRUS=$S(LRUS>$P(T1,U,2):+$P(T1,U,2),1:LRUS) Q
- Q
- TCHK ;CHECK THAT TEST ORDERED IS IN PROFILE
- Q:'$D(^LRO(68,LRAA,1,LRAD1,1,LRAN,3)) I 'LRLLP(1) Q:'$P(^(3),U,3)
- K LRTSL S E=0,LRUS=$S($P(^LRO(68,LRAA,1,LRAD1,1,LRAN,0),U,3)'=LRAD1:LRHOLD,1:99),LRSP=$S($D(^(5,1,0)):+^(0),1:0) Q:$D(LRDSPEC(LRSP))
- S I1=0 F S I1=$O(^LRO(68,LRAA,1,LRAD1,1,LRAN,4,I1)) Q:I1<1 S T1=^(I1,0) I '$L($P(^(0),U,3)) D TC1 Q:E
- Q:'$D(LRTSL)!E X LRURX I $T S ^TMP($J,-1,LRUS,LRAN)=LRAA_U_LRAD1_U_LRAN_U_LRPROF_U_LRSP S I=0 F S I=$O(LRTSL(I)) Q:I<1 S ^TMP($J,-1,LRUS,LRAN,I)=LRTSL(I)
- Q
- AC S LRTK=LRSTAR-.00001 F S LRTK=$O(^LRO(68,LRAA,1,LRAD1,1,"E",LRTK)) Q:LRTK<1!(+LRLST>1&(LRTK\1>+LRLST)) D AC1
- Q
- AC1 S LRAN=0 F S LRAN=$O(^LRO(68,LRAA,1,LRAD1,1,"E",LRTK,LRAN)) Q:LRAN<1 I $D(^LRO(68,LRAA,1,LRAD1,1,LRAN,0))#2 S LRADD=1,LRDFN=+^(0),LRDPF=$P(^(0),U,2),LRIDT=9999999-$S($D(^(3)):^(3),1:0) D TCHK
- Q
- QUEUE L -^LRO(68.2,LRINST,3) W ! S IOP="Q" D ^%ZIS I POP K IO("Q") G L1
- I '$D(IO("Q")) G L1
- S ZTRTN="DQ^LRLL1",ZTDESC="Load list",ZTSAVE("LR*")="" D ^%ZTLOAD K ZTSK S IOP=IO(0) D ^%ZIS D KILL^LRLLP Q
- DQ S U="^" U IO I $S($D(^LRO(68.2,LRINST,3)):^(3),1:0) S ZTDTH="120S",ZTIO="",ZTDESC="REQUEUE OF LOAD/WORK LIST " D REQ^%ZTLOAD Q
- L +^LRO(68.2,LRINST,3):2 I '$T S ZTDTH="120S",ZTIO="",ZTDESC="REQUEUE OF LOAD/WORK LIST" D REQ^%ZTLOAD Q
- S:$D(ZTQUEUED) ZTREQ="@" G L1
- LOCK L -^LRO(68.2,LRINST,3) L +^LRO(68,LRAA,.7) I '$D(LRAA(LRAA)),$S($D(^LRO(68,LRAA,.7)):^(.7),1:0) W:'$D(ZTQUEUED) !,"Waiting for access to the accession area" L -^LRO(68,LRAA,.7) H 30 G LOCK
- S ^LRO(68,LRAA,.7)=1,LRAA(LRAA)="" L -^LRO(68,LRAA,.7) Q
- END ;from LRLL
- K LRAA,LRDEF,LRTRANS,LRTYPE,LRURX,LRTP,LRST,LRDSPEC,LRFULL,LRHOLD,LRINST,LRLLINIT,LRLLP,LRLLT,LRMAXCUP,LRPROF,X,Y,LRAA,LRAD,LRADD,LRAD1
- K LRIIX,LRPTRAY,LRLL1,LRLLX,LRPCUP,B,DOUT,E,I1,J1,LRCNT,LRCT,LRIFN,LRIO,LRLL2,LRLL3,LRLST,LRNOLABL,LRODT,LRPGM,LRSP,LRSPLIT,LRSTART,LRTI,LRTIME,LRTK,LRTRACNT,LRTST,LRUS,LRWDTL,T1
- D KILL^LRLL Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLL1 3469 printed Jan 18, 2025@03:16:57 Page 2
- LRLL1 ;SLC/RWF - LOAD LIST SCAN. ;2/19/91 10:42 ;
- +1 ;;5.2;LAB SERVICE;**116**;Sep 27, 1994
- L1 ;
- +1 LOCK +^LRO(68.2,LRINST,3)
- IF $SELECT($DATA(^LRO(68.2,LRINST,3)):^(3),1:0)
- WRITE !,"Waiting for another build to finish.",$CHAR(7),!!?5,"Type '^' to stop waiting."
- LOCK -^LRO(68.2,LRINST,3)
- READ X:DTIME
- if X'[U
- GOTO L1
- QUIT
- +2 if $DATA(IO("Q"))
- GOTO QUEUE
- SET (LRPCUP,LRAN,LRCNT)=0
- +3 SET ^LRO(68.2,LRINST,3)=1
- LP DO BUILD
- +1 IF $DATA(LRALL)
- SET LRPROF=$ORDER(^LRO(68.2,LRINST,10,LRPROF))
- IF LRPROF>0
- DO PROF^LRLL3
- GOTO LP
- +2 SET ^LRO(68.2,LRINST,3)=0
- LOCK -^LRO(68.2,LRINST,3)
- IF LRCNT=0
- WRITE !,"NO ENTRYS ADDED",$CHAR(7)
- GOTO END
- +3 SET ^LRO(68.2,LRINST,2)=DT_U_$PIECE(^LRO(68.2,LRINST,2),U,2,3)_U_LRTRAY_U_LRCUP
- +4 WRITE !!,"LOAD LIST IS NOW SET UP"
- +5 ;GO PRINT
- KILL LRCTRL,LRDSPEC,^TMP($JOB)
- DO EN1^LRLLP
- GOTO END
- BUILD WRITE !!,"STARTING PROFILE ",$PIECE(^LRO(68.2,LRINST,10,LRPROF,0),U,1)," SCAN",!
- +1 IF '$DATA(LRSTAR)
- SET LRAD1=LRAD
- SET LRAN=LRST-.01
- FOR
- SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
- SET LRADD=1
- if LRAN<1!(LRAN>LRLLT)
- QUIT
- IF $DATA(^(LRAN,0))#2
- SET LRDFN=+^(0)
- SET LRDPF=$PIECE(^(0),U,2)
- SET LRIDT=9999999-$SELECT($DATA(^(3)):^(3),1:0)
- DO TCHK
- +2 IF $DATA(LRSTAR)
- SET LRAD1=$EXTRACT(LRSTAR,1,3)-1_"0000"
- SET A=0
- FOR
- SET LRAD1=$ORDER(^LRO(68,LRAA,1,LRAD1))
- if LRAD1<1!(LRAD1>LRWDTL)
- QUIT
- DO AC
- +3 IF $ORDER(^TMP($JOB,-1,0))=""
- WRITE !,"NO ENTRY FOUND!",!
- QUIT
- +4 FOR LRIIX=0:0
- SET LRIIX=$ORDER(^LRO(68.2,LRINST,10,LRPROF,4,LRIIX))
- if LRIIX<1
- QUIT
- SET LRIFN=+^(LRIIX,0)
- SET LRCT=LRIFN
- DO CTRLTST^LRLL3
- SET LRTST=$PIECE(X,U,2,99)
- DO GNCUP^LRLL2
- DO LRCTRL^LRLL4
- +5 WRITE !,"SCAN DONE."
- DO ^LRLL2
- +6 QUIT
- TC1 IF '$PIECE(T1,U,3)
- IF '$PIECE(T1,U,5)
- IF $DATA(LRTP(+T1))
- IF (LRTP(+T1)=LRSP!(LRTP(+T1)=""))
- +1 if '$TEST&('LRSPLIT)
- SET E=1
- IF $TEST
- SET LRTSL(I1)=T1
- SET LRUS=$SELECT(LRUS>$PIECE(T1,U,2):+$PIECE(T1,U,2),1:LRUS)
- QUIT
- +2 QUIT
- TCHK ;CHECK THAT TEST ORDERED IS IN PROFILE
- +1 if '$DATA(^LRO(68,LRAA,1,LRAD1,1,LRAN,3))
- QUIT
- IF 'LRLLP(1)
- if '$PIECE(^(3),U,3)
- QUIT
- +2 KILL LRTSL
- SET E=0
- SET LRUS=$SELECT($PIECE(^LRO(68,LRAA,1,LRAD1,1,LRAN,0),U,3)'=LRAD1:LRHOLD,1:99)
- SET LRSP=$SELECT($DATA(^(5,1,0)):+^(0),1:0)
- if $DATA(LRDSPEC(LRSP))
- QUIT
- +3 SET I1=0
- FOR
- SET I1=$ORDER(^LRO(68,LRAA,1,LRAD1,1,LRAN,4,I1))
- if I1<1
- QUIT
- SET T1=^(I1,0)
- IF '$LENGTH($PIECE(^(0),U,3))
- DO TC1
- if E
- QUIT
- +4 if '$DATA(LRTSL)!E
- QUIT
- XECUTE LRURX
- IF $TEST
- SET ^TMP($JOB,-1,LRUS,LRAN)=LRAA_U_LRAD1_U_LRAN_U_LRPROF_U_LRSP
- SET I=0
- FOR
- SET I=$ORDER(LRTSL(I))
- if I<1
- QUIT
- SET ^TMP($JOB,-1,LRUS,LRAN,I)=LRTSL(I)
- +5 QUIT
- AC SET LRTK=LRSTAR-.00001
- FOR
- SET LRTK=$ORDER(^LRO(68,LRAA,1,LRAD1,1,"E",LRTK))
- if LRTK<1!(+LRLST>1&(LRTK\1>+LRLST))
- QUIT
- DO AC1
- +1 QUIT
- AC1 SET LRAN=0
- FOR
- SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD1,1,"E",LRTK,LRAN))
- if LRAN<1
- QUIT
- IF $DATA(^LRO(68,LRAA,1,LRAD1,1,LRAN,0))#2
- SET LRADD=1
- SET LRDFN=+^(0)
- SET LRDPF=$PIECE(^(0),U,2)
- SET LRIDT=9999999-$SELECT($DATA(^(3)):^(3),1:0)
- DO TCHK
- +1 QUIT
- QUEUE LOCK -^LRO(68.2,LRINST,3)
- WRITE !
- SET IOP="Q"
- DO ^%ZIS
- IF POP
- KILL IO("Q")
- GOTO L1
- +1 IF '$DATA(IO("Q"))
- GOTO L1
- +2 SET ZTRTN="DQ^LRLL1"
- SET ZTDESC="Load list"
- SET ZTSAVE("LR*")=""
- DO ^%ZTLOAD
- KILL ZTSK
- SET IOP=IO(0)
- DO ^%ZIS
- DO KILL^LRLLP
- QUIT
- DQ SET U="^"
- USE IO
- IF $SELECT($DATA(^LRO(68.2,LRINST,3)):^(3),1:0)
- SET ZTDTH="120S"
- SET ZTIO=""
- SET ZTDESC="REQUEUE OF LOAD/WORK LIST "
- DO REQ^%ZTLOAD
- QUIT
- +1 LOCK +^LRO(68.2,LRINST,3):2
- IF '$TEST
- SET ZTDTH="120S"
- SET ZTIO=""
- SET ZTDESC="REQUEUE OF LOAD/WORK LIST"
- DO REQ^%ZTLOAD
- QUIT
- +2 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- GOTO L1
- LOCK LOCK -^LRO(68.2,LRINST,3)
- LOCK +^LRO(68,LRAA,.7)
- IF '$DATA(LRAA(LRAA))
- IF $SELECT($DATA(^LRO(68,LRAA,.7)):^(.7),1:0)
- if '$DATA(ZTQUEUED)
- WRITE !,"Waiting for access to the accession area"
- LOCK -^LRO(68,LRAA,.7)
- HANG 30
- GOTO LOCK
- +1 SET ^LRO(68,LRAA,.7)=1
- SET LRAA(LRAA)=""
- LOCK -^LRO(68,LRAA,.7)
- QUIT
- END ;from LRLL
- +1 KILL LRAA,LRDEF,LRTRANS,LRTYPE,LRURX,LRTP,LRST,LRDSPEC,LRFULL,LRHOLD,LRINST,LRLLINIT,LRLLP,LRLLT,LRMAXCUP,LRPROF,X,Y,LRAA,LRAD,LRADD,LRAD1
- +2 KILL LRIIX,LRPTRAY,LRLL1,LRLLX,LRPCUP,B,DOUT,E,I1,J1,LRCNT,LRCT,LRIFN,LRIO,LRLL2,LRLL3,LRLST,LRNOLABL,LRODT,LRPGM,LRSP,LRSPLIT,LRSTART,LRTI,LRTIME,LRTK,LRTRACNT,LRTST,LRUS,LRWDTL,T1
- +3 DO KILL^LRLL
- QUIT