LRUFILE ;AVAMC/REG - FILE OUTLINE ;8/16/95 15:42 ;
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
ASK D END F LRA=1:1 S DIC="^DIC(",DIC(0)="AEQM",DIC("S")="I Y>59.9999&(Y<70)" D ^DIC K DIC Q:Y<1 S LRG(LRA)=+Y
G:LRA=1 END W !!,"Brief listing: " S %=1 D YN^LRU G:%<1 END S LRB="" S:%=1 LRB=1
DEV S ZTRTN="QUE^LRUFILE" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO S X="T",%DT="" D ^%DT,D^LRU,L^LRU,S^LRU S LRH(0)=Y F A=0:0 S A=$O(LRG(A)) Q:'A S F=LRG(A) D REST
W:IO'=IO(0) @IOF D END^LRUTL,END Q
REST S Z(4)=1,LRFNAM=$O(^DD(F,0,"NM",0)) W @IOF,!,LRH(0),?25,LRFNAM," (",F,")",?73,"Pg ",Z(4),!,LR("%")
FF S W=1,E=0,I=0 F S V=1,I=$O(^DD(F,I)) D UP:I'>0 Q:F=-1 I V D WR,DN:$P(^DD(F,I,0),"^",2)
Q
DN S E=E+1,F(E)=F_"^"_I,X=I,F=+$P(^DD(F,I,0),"^",2),I=0,W=W+2 Q:'LRB W " (Subfile ",F,")" Q
UP G UP1:E=0 S F=+F(E),I=$P(F(E),"^",2) K F(E) S V=0,W=W-2,E=E-1 Q
WR D:$Y>60 HDR S X=^DD(F,I,0) W !?W,I,?W+4," ",$P(X,"^") Q:LRB W "^",$P(X,"^",2,5) Q
UP1 S F=-1 Q
HDR S Z(4)=Z(4)+1 W @IOF,!,LRH(0),?25,LRFNAM," (",F,")",?73,"Pg ",Z(4),!,LR("%") Q
LIST ;print all file titles from one number to another
BEG R !,"Start with file number: ",LR:DTIME G:LR=""!(LR["^") END I LR'=+LR D HELP G BEG
S LR=LR-.0000001
E R !,"End with file number: ",LR(1):DTIME G:LR(1)=""!(LR["^") END I LR(1)'=+LR(1) D HELP G E
S LR(1)=LR(1)+.0000001
S ZTRTN="QUE1^LRUFILE" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE1 U IO D S^LRU,H
F LR(2)=LR:0 S LR(2)=$O(^DIC(LR(2))) Q:LR(2)>LR(1)!('LR(2)) D:$Y>(IOSL-7) H I $D(^DIC(LR(2),0)) W !?10,LR(2),?20,$P(^(0),"^")
W:IO'=IO(0) @IOF D END^LRUTL,END Q
;
H S X="N",%DT="T" D ^%DT,D^LRU K %DT S LRQ=LRQ+1 W @IOF,!,Y,?30,"TABLE OF CONTENTS FOR FILES",?(IOM-8),"Pg: ",LRQ,!?30,LRQ(1),!! Q
;
HELP W $C(7),!!,"Enter a number. No other characters allowed.",! Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUFILE 1800 printed Dec 13, 2024@02:21:32 Page 2
LRUFILE ;AVAMC/REG - FILE OUTLINE ;8/16/95 15:42 ;
+1 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
ASK DO END
FOR LRA=1:1
SET DIC="^DIC("
SET DIC(0)="AEQM"
SET DIC("S")="I Y>59.9999&(Y<70)"
DO ^DIC
KILL DIC
if Y<1
QUIT
SET LRG(LRA)=+Y
+1 if LRA=1
GOTO END
WRITE !!,"Brief listing: "
SET %=1
DO YN^LRU
if %<1
GOTO END
SET LRB=""
if %=1
SET LRB=1
DEV SET ZTRTN="QUE^LRUFILE"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
SET X="T"
SET %DT=""
DO ^%DT
DO D^LRU
DO L^LRU
DO S^LRU
SET LRH(0)=Y
FOR A=0:0
SET A=$ORDER(LRG(A))
if 'A
QUIT
SET F=LRG(A)
DO REST
+1 if IO'=IO(0)
WRITE @IOF
DO END^LRUTL
DO END
QUIT
REST SET Z(4)=1
SET LRFNAM=$ORDER(^DD(F,0,"NM",0))
WRITE @IOF,!,LRH(0),?25,LRFNAM," (",F,")",?73,"Pg ",Z(4),!,LR("%")
FF SET W=1
SET E=0
SET I=0
FOR
SET V=1
SET I=$ORDER(^DD(F,I))
if I'>0
DO UP
if F=-1
QUIT
IF V
DO WR
if $PIECE(^DD(F,I,0),"^",2)
DO DN
+1 QUIT
DN SET E=E+1
SET F(E)=F_"^"_I
SET X=I
SET F=+$PIECE(^DD(F,I,0),"^",2)
SET I=0
SET W=W+2
if 'LRB
QUIT
WRITE " (Subfile ",F,")"
QUIT
UP if E=0
GOTO UP1
SET F=+F(E)
SET I=$PIECE(F(E),"^",2)
KILL F(E)
SET V=0
SET W=W-2
SET E=E-1
QUIT
WR if $Y>60
DO HDR
SET X=^DD(F,I,0)
WRITE !?W,I,?W+4," ",$PIECE(X,"^")
if LRB
QUIT
WRITE "^",$PIECE(X,"^",2,5)
QUIT
UP1 SET F=-1
QUIT
HDR SET Z(4)=Z(4)+1
WRITE @IOF,!,LRH(0),?25,LRFNAM," (",F,")",?73,"Pg ",Z(4),!,LR("%")
QUIT
LIST ;print all file titles from one number to another
BEG READ !,"Start with file number: ",LR:DTIME
if LR=""!(LR["^")
GOTO END
IF LR'=+LR
DO HELP
GOTO BEG
+1 SET LR=LR-.0000001
E READ !,"End with file number: ",LR(1):DTIME
if LR(1)=""!(LR["^")
GOTO END
IF LR(1)'=+LR(1)
DO HELP
GOTO E
+1 SET LR(1)=LR(1)+.0000001
+2 SET ZTRTN="QUE1^LRUFILE"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE1 USE IO
DO S^LRU
DO H
+1 FOR LR(2)=LR:0
SET LR(2)=$ORDER(^DIC(LR(2)))
if LR(2)>LR(1)!('LR(2))
QUIT
if $Y>(IOSL-7)
DO H
IF $DATA(^DIC(LR(2),0))
WRITE !?10,LR(2),?20,$PIECE(^(0),"^")
+2 if IO'=IO(0)
WRITE @IOF
DO END^LRUTL
DO END
QUIT
+3 ;
H SET X="N"
SET %DT="T"
DO ^%DT
DO D^LRU
KILL %DT
SET LRQ=LRQ+1
WRITE @IOF,!,Y,?30,"TABLE OF CONTENTS FOR FILES",?(IOM-8),"Pg: ",LRQ,!?30,LRQ(1),!!
QUIT
+1 ;
HELP WRITE $CHAR(7),!!,"Enter a number. No other characters allowed.",!
QUIT
+1 ;
END DO V^LRU
QUIT
