- 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
