- LRLL2 ;SLC/RWF - LOAD LIST BUILD ;Sep 13, 2021@18:20
- ;;5.2;LAB SERVICE;**99,116,552**;Sep 27, 1994;Build 2
- ;
- A W " BUILDING",! S LRTRACNT=$S(LRTYPE:LRTRAY,1:LRCUP+1)+LRTRACNT,LREND=0
- ;LR*5.2*552: Start at null instead of zero since zero is a valid urgency in this case.
- N LRUS S LRUS=""
- F S LRUS=$O(^TMP($J,-1,LRUS)) Q:LRUS=""!LREND F LRAN=0:0 S LRAN=$O(^TMP($J,-1,LRUS,LRAN)) Q:LRAN=""!LREND D FILL
- S LRPTRAY=LRTRAY,LRPCUP=LRCUP F LRTI=0:0 X LRTRANS Q:'$D(LRCTRL(LRTRAY,LRCUP))!(LRPTRAY'=LRTRAY) D CONTROL^LRLL4 S LRTI=1
- S:'LRTI LRTRAY=LRPTRAY,LRCUP=LRPCUP
- F LRIIX=0:0 S LRIIX=$O(^LRO(68.2,LRINST,10,LRPROF,5,LRIIX)) Q:LRIIX<1 S LRIFN=+^(LRIIX,0),LRCT=LRIFN D CTRLTST^LRLL3 S LRTST=$P(X,U,2,99) D GNCUP,LRCTRL^LRLL4
- D MOVE:'LRFULL!((LRCUP=LRMAXCUP)!(LRCUP<LRPCUP)) W !,"BUILD DONE"
- ;F LRAA=0:0 S LRAA=$O(LRAA(LRAA)) Q:LRAA'>0 S ^LRO(68,LRAA,.7)=0
- Q
- GNCUP ;from LRLL1
- X LRTRANS S:$S(LRTYPE:LRTRAY,1:LRCUP)'<LRTRACNT LREND=1 G GNCUP:$D(^TMP($J,LRTRAY,LRCUP))!$D(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)) ;GET NEXT LRCUP
- Q
- FILL D GNCUP Q:LREND I LRCUP<LRPCUP D MOVE
- I $D(LRCTRL(LRTRAY,LRCUP)) D CONTROL^LRLL4 S LRPCUP=LRCUP G FILL
- W "." S ^TMP($J,LRTRAY,LRCUP)=^TMP($J,-1,LRUS,LRAN)
- F I=0:0 S I=$O(^TMP($J,-1,LRUS,LRAN,I)) Q:I="" S ^TMP($J,LRTRAY,LRCUP,I)=^TMP($J,-1,LRUS,LRAN,I)
- S LRPCUP=LRCUP Q
- MOVE S LRLL1=$O(^TMP($J,0)) Q:LRLL1="" S LRCNT=LRCNT+1
- S ^LRO(68.2,LRINST,1,0)="^68.21^"_LRLL1_U_LRLL1,^(LRLL1,0)=LRLL1_U_DT_U_DUZ_U_LRAA
- S ^LRO(68.2,LRINST,1,LRLL1,1,0)="^68.22PA^1^1"
- F LRLL2=0:0 S LRLL2=$O(^TMP($J,LRLL1,LRLL2)) Q:LRLL2="" S LRLLX=^(LRLL2) D MV1
- K ^TMP($J,LRLL1) S LRPCUP=LRCUP W !,"B" Q
- MV1 S ^LRO(68.2,LRINST,1,LRLL1,1,LRLL2,0)=LRLLX
- F LRLL3=0:0 S LRLL3=$O(^TMP($J,LRLL1,LRLL2,LRLL3)) Q:LRLL3="" S LRTX=^(LRLL3) D MV2
- K ^TMP($J,LRLL1,LRLL2) Q
- MV2 Q:'LRAD S ^LRO(68.2,LRINST,1,LRLL1,1,LRLL2,1,0)="^68.222^"_LRLL3_"^1",^(LRLL3,0)=LRTX,$P(^LRO(68,LRAA,1,LRAD,1,$P(LRLLX,U,3),4,LRLL3,0),U,3)=LRINST_";"_LRLL1_";"_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, from LRLL4
- Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) I 'LRLLP(1) Q:'$P(^(3),U,3)
- K LRTSL S E=0,LRUS=$S($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,3)'=LRAD: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,LRAD,1,LRAN,4,I1)) Q:I1<1 S T1=^(I1,0) D TC1 Q:E
- Q:'$D(LRTSL)!E X LRURX I $T S ^TMP($J,-1,LRUS,LRAN)=LRAA_U_LRAD_U_LRAN_U_LRPROF 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,LRAD,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,LRAD,1,"E",LRTK,LRAN)) Q:LRAN<1 I $D(^LRO(68,LRAA,1,LRAD,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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLL2 2983 printed Feb 18, 2025@23:42:09 Page 2
- LRLL2 ;SLC/RWF - LOAD LIST BUILD ;Sep 13, 2021@18:20
- +1 ;;5.2;LAB SERVICE;**99,116,552**;Sep 27, 1994;Build 2
- +2 ;
- A WRITE " BUILDING",!
- SET LRTRACNT=$SELECT(LRTYPE:LRTRAY,1:LRCUP+1)+LRTRACNT
- SET LREND=0
- +1 ;LR*5.2*552: Start at null instead of zero since zero is a valid urgency in this case.
- +2 NEW LRUS
- SET LRUS=""
- +3 FOR
- SET LRUS=$ORDER(^TMP($JOB,-1,LRUS))
- if LRUS=""!LREND
- QUIT
- FOR LRAN=0:0
- SET LRAN=$ORDER(^TMP($JOB,-1,LRUS,LRAN))
- if LRAN=""!LREND
- QUIT
- DO FILL
- +4 SET LRPTRAY=LRTRAY
- SET LRPCUP=LRCUP
- FOR LRTI=0:0
- XECUTE LRTRANS
- if '$DATA(LRCTRL(LRTRAY,LRCUP))!(LRPTRAY'=LRTRAY)
- QUIT
- DO CONTROL^LRLL4
- SET LRTI=1
- +5 if 'LRTI
- SET LRTRAY=LRPTRAY
- SET LRCUP=LRPCUP
- +6 FOR LRIIX=0:0
- SET LRIIX=$ORDER(^LRO(68.2,LRINST,10,LRPROF,5,LRIIX))
- if LRIIX<1
- QUIT
- SET LRIFN=+^(LRIIX,0)
- SET LRCT=LRIFN
- DO CTRLTST^LRLL3
- SET LRTST=$PIECE(X,U,2,99)
- DO GNCUP
- DO LRCTRL^LRLL4
- +7 if 'LRFULL!((LRCUP=LRMAXCUP)!(LRCUP<LRPCUP))
- DO MOVE
- WRITE !,"BUILD DONE"
- +8 ;F LRAA=0:0 S LRAA=$O(LRAA(LRAA)) Q:LRAA'>0 S ^LRO(68,LRAA,.7)=0
- +9 QUIT
- GNCUP ;from LRLL1
- +1 ;GET NEXT LRCUP
- XECUTE LRTRANS
- if $SELECT(LRTYPE
- SET LREND=1
- if $DATA(^TMP($JOB,LRTRAY,LRCUP))!$DATA(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0))
- GOTO GNCUP
- +2 QUIT
- FILL DO GNCUP
- if LREND
- QUIT
- IF LRCUP<LRPCUP
- DO MOVE
- +1 IF $DATA(LRCTRL(LRTRAY,LRCUP))
- DO CONTROL^LRLL4
- SET LRPCUP=LRCUP
- GOTO FILL
- +2 WRITE "."
- SET ^TMP($JOB,LRTRAY,LRCUP)=^TMP($JOB,-1,LRUS,LRAN)
- +3 FOR I=0:0
- SET I=$ORDER(^TMP($JOB,-1,LRUS,LRAN,I))
- if I=""
- QUIT
- SET ^TMP($JOB,LRTRAY,LRCUP,I)=^TMP($JOB,-1,LRUS,LRAN,I)
- +4 SET LRPCUP=LRCUP
- QUIT
- MOVE SET LRLL1=$ORDER(^TMP($JOB,0))
- if LRLL1=""
- QUIT
- SET LRCNT=LRCNT+1
- +1 SET ^LRO(68.2,LRINST,1,0)="^68.21^"_LRLL1_U_LRLL1
- SET ^(LRLL1,0)=LRLL1_U_DT_U_DUZ_U_LRAA
- +2 SET ^LRO(68.2,LRINST,1,LRLL1,1,0)="^68.22PA^1^1"
- +3 FOR LRLL2=0:0
- SET LRLL2=$ORDER(^TMP($JOB,LRLL1,LRLL2))
- if LRLL2=""
- QUIT
- SET LRLLX=^(LRLL2)
- DO MV1
- +4 KILL ^TMP($JOB,LRLL1)
- SET LRPCUP=LRCUP
- WRITE !,"B"
- QUIT
- MV1 SET ^LRO(68.2,LRINST,1,LRLL1,1,LRLL2,0)=LRLLX
- +1 FOR LRLL3=0:0
- SET LRLL3=$ORDER(^TMP($JOB,LRLL1,LRLL2,LRLL3))
- if LRLL3=""
- QUIT
- SET LRTX=^(LRLL3)
- DO MV2
- +2 KILL ^TMP($JOB,LRLL1,LRLL2)
- QUIT
- MV2 if 'LRAD
- QUIT
- SET ^LRO(68.2,LRINST,1,LRLL1,1,LRLL2,1,0)="^68.222^"_LRLL3_"^1"
- SET ^(LRLL3,0)=LRTX
- SET $PIECE(^LRO(68,LRAA,1,LRAD,1,$PIECE(LRLLX,U,3),4,LRLL3,0),U,3)=LRINST_";"_LRLL1_";"_LRLL2
- +1 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, from LRLL4
- +1 if '$DATA(^LRO(68,LRAA,1,LRAD,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,LRAD,1,LRAN,0),U,3)'=LRAD: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,LRAD,1,LRAN,4,I1))
- if I1<1
- QUIT
- SET T1=^(I1,0)
- DO TC1
- if E
- QUIT
- +4 if '$DATA(LRTSL)!E
- QUIT
- XECUTE LRURX
- IF $TEST
- SET ^TMP($JOB,-1,LRUS,LRAN)=LRAA_U_LRAD_U_LRAN_U_LRPROF
- 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,LRAD,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,LRAD,1,"E",LRTK,LRAN))
- if LRAN<1
- QUIT
- IF $DATA(^LRO(68,LRAA,1,LRAD,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
