ZIBVLMSM ; IHS/ADC/GTH - LIST MSM VARIABLES ; [ 02/07/97 3:02 PM ]
;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
;
; This routine lists variables that begin with the string
; entered by the user. Selection of variables is case
; sensitive.
;
; This routine is specific to Micronetics. It will work
; with any M implementation that has all Type A extensions
; to the 1990 M ANSI standard implemented. The front end
; routine, XBVL, stops if any other than an MSM
; implementation is encountered.
;
; Routine provided by Don Enos, OHPRD, 5 Feb 96.
;
START ;
NEW ZIBVLC,ZIBVLDQT,ZIBVLI,ZIBVLLC,ZIBVLNS,ZIBVLQ,ZIBVLX,ZIBVLX2,ZIBVLY,ZIBVLZ
S $P(ZIBVLZ,"=",40)=""
F D LOOP Q:ZIBVLQ
Q
;
LOOP ; WRITE NAME SPACED VARIABLES UNTIL USER IS THROUGH
D READ ; get name space
Q:ZIBVLQ
Q:ZIBVLNS=""
I $D(IOF) W @IOF I 1
E W !!
W ZIBVLZ,! ; write leading === line
I ZIBVLNS="*" D ALL I 1 ; list variables
E D NMSPACE
D:ZIBVLLC>20 PAUSE ; pause if bottom of screen
I 'ZIBVLQ W ZIBVLZ,! I 1 ; write trailing === line
E W !
S ZIBVLQ=0
Q
;
NMSPACE ; LIST VARIABLES IN NAME SPACE
S ZIBVLX=$O(@ZIBVLNS,-1) ; backup to variable before name space
S:ZIBVLX="" ZIBVLX="%" ; if none start with %
I ZIBVLNS="%",$D(%) D WRITE,QUERY ;if % name space list % variable
; now list variables in name space and subnodes if arrays
; skip ZIBVL* variables
F S ZIBVLX=$O(@ZIBVLX) Q:ZIBVLX="" Q:$E(ZIBVLX,1,$L(ZIBVLNS))]ZIBVLNS I $E(ZIBVLX,1,$L(ZIBVLNS))=ZIBVLNS,$E(ZIBVLX,1,5)'="ZIBVL" D WRITE Q:ZIBVLQ D QUERY Q:ZIBVLQ
Q
;
ALL ; LIST ALL VARIABLES
S ZIBVLX="%"
I $D(%) D WRITE,QUERY ; if % exists list it
; now list all variables and subnodes if arrays
; skip ZIBVL* variables
F S ZIBVLX=$O(@ZIBVLX) Q:ZIBVLX="" I $E(ZIBVLX,1,5)'="ZIBVL" D WRITE Q:ZIBVLQ D QUERY Q:ZIBVLQ
Q
;
QUERY ; $Q THROUGH ARRAYS
S ZIBVLX2=ZIBVLX
NEW ZIBVLX
S ZIBVLX=ZIBVLX2
F S ZIBVLX=$Q(@ZIBVLX) Q:ZIBVLX="" D WRITE Q:ZIBVLQ
Q
;
WRITE ; WRITE ONE VARIABLE NAME AND VALUE
Q:'($D(@ZIBVLX)#2)
; quote non-numeric values (numeric = canonic < 16 digits)
S ZIBVLDQT=""""
I $L(@ZIBVLX)<16,@ZIBVLX=+@ZIBVLX S ZIBVLDQT=""
; figure out # of lines that will be used
S ZIBVLC=$L(ZIBVLX)+1+($L(ZIBVLDQT)*2)+$L(@ZIBVLX) F ZIBVLI=1:1 S ZIBVLC=ZIBVLC-80 Q:ZIBVLC<1
S ZIBVLLC=ZIBVLLC+ZIBVLI
I ZIBVLLC>22 S ZIBVLLC=0 D PAUSE ; pause if not enough room
Q:ZIBVLQ
W ZIBVLX,"=",ZIBVLDQT,@ZIBVLX,ZIBVLDQT,! ; write name=value
Q
;
READ ; READ USER INPUT
S ZIBVLQ=1,ZIBVLLC=0
R !,"Enter Name Space: ",ZIBVLNS:300
S:'$T ZIBVLNS="^"
Q:ZIBVLNS=""
Q:ZIBVLNS["^"
S ZIBVLQ=0
I ZIBVLNS["?" D HELP Q
I $E(ZIBVLNS,1,5)="ZIBVL" W !!,"ZIBVL is not allowed!",*7 D HELP Q
I ZIBVLNS=" " W !!,"BLANK is not allowed!",*7 D HELP Q
I $L(ZIBVLNS)>1,$E(ZIBVLNS,$L(ZIBVLNS))="*" S ZIBVLNS=$E(ZIBVLNS,1,($L(ZIBVLNS)-1))
D I ZIBVLQ S ZIBVLQ=0 D HELP W *7 Q
. Q:ZIBVLNS?1"%".AN
. Q:ZIBVLNS?1A.AN
. Q:ZIBVLNS="*"
. S ZIBVLQ=1
. Q
Q
;
HELP ; DISPLAY HELP MESSAGE
W !!,"Enter valid variable name string (e.g IO), or * for all, or RETURN or ^ to exit.",!
S ZIBVLNS=""
Q
;
PAUSE ; PAUSE FOR USER
R "Press any key to continue",ZIBVLY:300 S:'$T ZIBVLY="^"
W !
I ZIBVLY["^" S ZIBVLQ=1 Q
W:$D(IOF) @IOF
Q
ZIBVLMSM ; IHS/ADC/GTH - LIST MSM VARIABLES ; [ 02/07/97 3:02 PM ]
+1 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
+2 ;
+3 ; This routine lists variables that begin with the string
+4 ; entered by the user. Selection of variables is case
+5 ; sensitive.
+6 ;
+7 ; This routine is specific to Micronetics. It will work
+8 ; with any M implementation that has all Type A extensions
+9 ; to the 1990 M ANSI standard implemented. The front end
+10 ; routine, XBVL, stops if any other than an MSM
+11 ; implementation is encountered.
+12 ;
+13 ; Routine provided by Don Enos, OHPRD, 5 Feb 96.
+14 ;
START ;
+1 NEW ZIBVLC,ZIBVLDQT,ZIBVLI,ZIBVLLC,ZIBVLNS,ZIBVLQ,ZIBVLX,ZIBVLX2,ZIBVLY,ZIBVLZ
+2 SET $PIECE(ZIBVLZ,"=",40)=""
+3 FOR
DO LOOP
IF ZIBVLQ
QUIT
+4 QUIT
+5 ;
LOOP ; WRITE NAME SPACED VARIABLES UNTIL USER IS THROUGH
+1 ; get name space
DO READ
+2 IF ZIBVLQ
QUIT
+3 IF ZIBVLNS=""
QUIT
+4 IF $DATA(IOF)
WRITE @IOF
IF 1
+5 IF '$TEST
WRITE !!
+6 ; write leading === line
WRITE ZIBVLZ,!
+7 ; list variables
IF ZIBVLNS="*"
DO ALL
IF 1
+8 IF '$TEST
DO NMSPACE
+9 ; pause if bottom of screen
IF ZIBVLLC>20
DO PAUSE
+10 ; write trailing === line
IF 'ZIBVLQ
WRITE ZIBVLZ,!
IF 1
+11 IF '$TEST
WRITE !
+12 SET ZIBVLQ=0
+13 QUIT
+14 ;
NMSPACE ; LIST VARIABLES IN NAME SPACE
+1 ; backup to variable before name space
SET ZIBVLX=$ORDER(@ZIBVLNS,-1)
+2 ; if none start with %
IF ZIBVLX=""
SET ZIBVLX="%"
+3 ;if % name space list % variable
IF ZIBVLNS="%"
IF $DATA(%)
DO WRITE
DO QUERY
+4 ; now list variables in name space and subnodes if arrays
+5 ; skip ZIBVL* variables
+6 FOR
SET ZIBVLX=$ORDER(@ZIBVLX)
IF ZIBVLX=""
QUIT
IF $EXTRACT(ZIBVLX,1,$LENGTH(ZIBVLNS))]ZIBVLNS
QUIT
IF $EXTRACT(ZIBVLX,1,$LENGTH(ZIBVLNS))=ZIBVLNS
IF $EXTRACT(ZIBVLX,1,5)'="ZIBVL"
DO WRITE
IF ZIBVLQ
QUIT
DO QUERY
IF ZIBVLQ
QUIT
+7 QUIT
+8 ;
ALL ; LIST ALL VARIABLES
+1 SET ZIBVLX="%"
+2 ; if % exists list it
IF $DATA(%)
DO WRITE
DO QUERY
+3 ; now list all variables and subnodes if arrays
+4 ; skip ZIBVL* variables
+5 FOR
SET ZIBVLX=$ORDER(@ZIBVLX)
IF ZIBVLX=""
QUIT
IF $EXTRACT(ZIBVLX,1,5)'="ZIBVL"
DO WRITE
IF ZIBVLQ
QUIT
DO QUERY
IF ZIBVLQ
QUIT
+6 QUIT
+7 ;
QUERY ; $Q THROUGH ARRAYS
+1 SET ZIBVLX2=ZIBVLX
+2 NEW ZIBVLX
+3 SET ZIBVLX=ZIBVLX2
+4 FOR
SET ZIBVLX=$QUERY(@ZIBVLX)
IF ZIBVLX=""
QUIT
DO WRITE
IF ZIBVLQ
QUIT
+5 QUIT
+6 ;
WRITE ; WRITE ONE VARIABLE NAME AND VALUE
+1 IF '($DATA(@ZIBVLX)#2)
QUIT
+2 ; quote non-numeric values (numeric = canonic < 16 digits)
+3 SET ZIBVLDQT=""""
+4 IF $LENGTH(@ZIBVLX)<16
IF @ZIBVLX=+@ZIBVLX
SET ZIBVLDQT=""
+5 ; figure out # of lines that will be used
+6 SET ZIBVLC=$LENGTH(ZIBVLX)+1+($LENGTH(ZIBVLDQT)*2)+$LENGTH(@ZIBVLX)
FOR ZIBVLI=1:1
SET ZIBVLC=ZIBVLC-80
IF ZIBVLC<1
QUIT
+7 SET ZIBVLLC=ZIBVLLC+ZIBVLI
+8 ; pause if not enough room
IF ZIBVLLC>22
SET ZIBVLLC=0
DO PAUSE
+9 IF ZIBVLQ
QUIT
+10 ; write name=value
WRITE ZIBVLX,"=",ZIBVLDQT,@ZIBVLX,ZIBVLDQT,!
+11 QUIT
+12 ;
READ ; READ USER INPUT
+1 SET ZIBVLQ=1
SET ZIBVLLC=0
+2 READ !,"Enter Name Space: ",ZIBVLNS:300
+3 IF '$TEST
SET ZIBVLNS="^"
+4 IF ZIBVLNS=""
QUIT
+5 IF ZIBVLNS["^"
QUIT
+6 SET ZIBVLQ=0
+7 IF ZIBVLNS["?"
DO HELP
QUIT
+8 IF $EXTRACT(ZIBVLNS,1,5)="ZIBVL"
WRITE !!,"ZIBVL is not allowed!",*7
DO HELP
QUIT
+9 IF ZIBVLNS=" "
WRITE !!,"BLANK is not allowed!",*7
DO HELP
QUIT
+10 IF $LENGTH(ZIBVLNS)>1
IF $EXTRACT(ZIBVLNS,$LENGTH(ZIBVLNS))="*"
SET ZIBVLNS=$EXTRACT(ZIBVLNS,1,($LENGTH(ZIBVLNS)-1))
+11 Begin DoDot:1
+12 IF ZIBVLNS?1"%".AN
QUIT
+13 IF ZIBVLNS?1A.AN
QUIT
+14 IF ZIBVLNS="*"
QUIT
+15 SET ZIBVLQ=1
+16 QUIT
End DoDot:1
IF ZIBVLQ
SET ZIBVLQ=0
DO HELP
WRITE *7
QUIT
+17 QUIT
+18 ;
HELP ; DISPLAY HELP MESSAGE
+1 WRITE !!,"Enter valid variable name string (e.g IO), or * for all, or RETURN or ^ to exit.",!
+2 SET ZIBVLNS=""
+3 QUIT
+4 ;
PAUSE ; PAUSE FOR USER
+1 READ "Press any key to continue",ZIBVLY:300
IF '$TEST
SET ZIBVLY="^"
+2 WRITE !
+3 IF ZIBVLY["^"
SET ZIBVLQ=1
QUIT
+4 IF $DATA(IOF)
WRITE @IOF
+5 QUIT
