Routine: ZTBKC

%ZTBKC ;SF/GJL - GLOBAL BLOCK COUNT ;05/24/2007  686246.738699

 ;;7.3;TOOLKIT;**80**;Apr 25, 1995;Build 6

 ;X = FULL Global Reference: NAME(SUB1,...,SUBn)

 N %ZIS,DIRUT,DTOUT,DUOUT,POP

 S U="^",%BS="",XX1=0 K ^XUTL($J)

 I $P($G(^%ZOSF("OS")),"^")["OpenM-NT" N %ZTBKVER D  G QUIT:$G(%ZTBKVER)']""!$D(DUOUT)!$D(DIRUT)

 . S %ZTBKVER=$P($$VERSION^%ZOSV,".",1,2)

 . I %ZTBKVER="5.0"!(%ZTBKVER'<5.2) D ASKDIR^%ZTBKC1 Q

 . W !,"This version of the Block Count Utility does not support this version of Cache'"

 . S %ZTBKVER=""

READ W !!,"Block Count for Global ^" I %BS]"" W %BS,"//"

 R X:$S($D(DTIME):DTIME,1:300),! G:'$T!(X="^") QUIT I X="" S X=%BS

STRIP I (X?1"^".E)!(X?1" ".E) S X=$E(X,2,256) G STRIP

 I X="" G READY

 I X="*" S ZTBKCALL=1 G READY

 I X["*" W !,$C(7),"Wild cards not allowed as part of the global name." G SYNTAX

 I X?1"??".E D QQ G READ

 I X?1"?".E G SYNTAX

 I X?1"(".E S %BS="" G SYNTAX

 I $P(X,"(")'?.1"^".1"%"1A.AN W !,$C(7),"Only alphanumerics are allowed in global names." G SYNTAX

 I $L(X,"(")>1,$E(X,$L(X))'=")" G SYNTAX

 I $L(X,"(")>1,$P($E(X,1,$L(X)-1),"(",2,255)']"" G SYNTAX

 S %T=X,%Z=1 F %A=1:1 Q:$E(%T,%A)=""  I $E(%T,%A)="""" D QUOTES

 I %Z-1 G SYNTAX2

 S %BS=X,X=U_%T,Y=$D(@(U_%BS)) W $S(Y=0:" doesn't exist.",1:"OK") I Y S XX1=XX1+1,^XUTL($J,XX1)=%BS_X

 S %BS="" G READ

QUOTES I ((%Z=0)&($E(%T,%A+1)="""")) S %T=$E(%T,0,%A)_$E(%T,%A+2,999)

 E  S %T=$E(%T,0,%A-1)_$E(%T,%A+1,999),%A=%A-1,%Z=1-%Z

SYNTAX W !,"Enter: * for all globals in current directory, or"

 W !,"Enter: a FULL Global Reference, e.g. ^DD(3,""GL""), or"

 W !,"       ^ " W:%BS="" "or NULL " W "to quit."

 W !!,"Enter: ? for this help, or"

 W !,"       ?? for more help."

 G READ

SYNTAX2 W !,?5,"I'm sorry, but I don't understand your use of quotes."

 W !,"Please surround string subscripts with quotes and any quote"

 W !,"which is a part of the subscript should be doubled."

 G READ

QQ ;Double question mark response

 K DIR S DIR(0)="SO^S:Show current selection"

 S DIR(0)=DIR(0)_";D:De-select from current selection"

 S DIR(0)=DIR(0)_";M:More help"

 D ^DIR

 I Y="S" D SHOW G QQ

 I Y="D" D DSEL G QQ

 I Y="M" D XTNDHELP G QQ

SHOW ;Show current selection

 I '$D(IOF) D HOME^%ZIS

 I $O(^XUTL($J,0))'>0 D  Q

 . W !!,?20,"You have not selected any globals.",!

 . K DIR S DIR(0)="E" D ^DIR

 W @IOF,!,"You have selected the following globals:",!

 S %U="" F %I=1:1 S %A=$G(^XUTL($J,%I)) Q:%A=""  D

 .  W !,?8,"^"_$P(%A,U)

 K DIR S DIR(0)="E" D ^DIR

DSEL ;Ask directory

 N ZTBKCLST

 I $O(^XUTL($J,0))'>0 D  Q

 . W !!,?20,"You have not selected any globals.",!

 . K DIR S DIR(0)="E" D ^DIR

 K DIR S DIR("A",1)="To de-select from the selected globals:"

 S %U="" F %I=1:1 S %A=$G(^XUTL($J,%I)) Q:%A=""  D

 .  S DIR("A",%I+1)=$J("",3)_$J(%I,3)_$J("^",7)_$P(%A,U)

 .  S ZTBKCLST(%I)=%A

 S DIR("A")="Enter a list or a range of numbers: "

 S DIR(0)="L^"_"1:"_(%I-1)

 W ! D ^DIR

 Q:$D(DTOUT)!$D(DIRUT)

W !

 F %I=1:1 S %A=$P(Y,",",%I) Q:%A']""  Q:(%A'=+%A)  K ZTBKCLST(%A) W "."

 S %A=$O(ZTBKCLST("")) I %A="" D  Q

 . F %I=0:0 S %I=$O(^XUTL($J,%I)) Q:%I'>0  Q:%I'=+%I  K ^XUTL($J,%I)

 . S XX1=0

 F %I=1:1 Q:%A']""&($G(^XUTL($J,%I))']"")  D

 . I %A]"" S ^XUTL($J,%I)=ZTBKCLST(%A),%A=$O(ZTBKCLST(%A))

 . E  K ^XUTL($J,%I)

 S XX1=$O(XUTL($J,"@"),-1) I XX1'=+XX1 S XX1=0

XTNDHELP ;Extended help

 I '$D(IOF) D HOME^%ZIS

 W @IOF,!,?35,"More Help",!

 W !,?10,"Globals that contain commas in subscripts may not produce accurate"

 W !,?10,"block counts.  Also, avoid specifying full global references"

 W !,?10,"that contain commas in the subscripts when entering globals"

 W !,?10,"at the 'Block Count for Global ^' prompt."

 W !,?10,""

 W !,?10,"After entering a double question mark ('??') response to the"

 W !,?10,"'Block Count for Global ^' prompt, enter 'S' for a listing"

 W !,?10,"of globals selected or 'D' to de-select globals from this list."

 W ! K DIR S DIR(0)="E" D ^DIR

READY I '$D(ZTBKCALL),$O(^XUTL($J,0))'>0 D  G QUIT

 . W !!,?20,"No globals have been selected!!!",!

 W !,"Output results on" S %ZIS="Q" D ^%ZIS G QUIT:POP

 I $D(IO("Q")) S ZTRTN=$S($D(ZTBKCALL):"ALL^%ZTBKC1",1:"DQ^%ZTBKC"),ZTDESC="Global block count",ZTSAVE("^XUTL($J,")="" D ^%ZTLOAD K ZTSK U IO(0) D ^%ZISC K ZTRTN,ZTDESC,ZTSAVE G QUIT

 I $D(ZTBKCALL) U IO D ALL^%ZTBKC1 U IO(0) D ^%ZISC G QUIT

DQ ;

 U IO F XX1=0:0 S XX1=$O(^XUTL($J,XX1)) Q:XX1'>0  S %T=^(XX1),%BS=$P(%T,U,1),X=$P(%T,U,2) W !,"Global ^",%BS D ENCOUNT W $S(X'>0:" doesn't exist",1:" has "_X_" data block") W:X>1 "s"

QUIT U:$D(IO(0))#2 IO(0) D ^%ZISC K DIR,X,XX1,Y,ZTBKCALL,%A,%I,%T,%U,%Z,%BS I $D(ZTQUEUED) S ZTREQ="@"

ALL ;All Globals in Directory

 S %A=$P(^%ZOSF("OS"),"^",1)

 D ALL^%ZTBKC1 G ALLEXIT

 ;I %A="DSM-3" D ALL^%ZTBKC1 G ALLEXIT

 ;I %A="M/11" D ALLM11 G ALLEXIT

 ;I %A="M/11+" D ALL^%ZTBKC1 G ALLEXIT

 ;I %A="M/VX" D ALL^%ZTBKC1 G ALLEXIT

 ;I %A["MSM" D ALL^%ZTBKC1 G ALLEXIT

 ;I %A["VAX DSM" G ALL^%ZTBKC1

ALLEXIT K %A

ALLM11 ;Directory at

 W $C(7),"  NOT AVAILABLE!!!!"

ENCOUNT ;  X = Full Global Reference: NAME(SUB1,...,SUBn)

 ;  Surrounding/doubled quotes should have been removed from subscripts

 ;  The count is not accurate for subscripts containing commas

 S %T=-1,%A=$P(^%ZOSF("OS"),"^") I X?1"^".E S X=$E(X,2,255)

 D ^%ZTBKC1

 ;I "^MSM-UNIX^MSM-PC^VAX DSM(V5)^DSM-3^M/11^M/11+^M/VX^"[("^"_%A_"^") D ^%ZTBKC1

EXIT S X=%T K %A,%T

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZTBKC   5438     printed  Mar 13, 2025@21:20:43                                                                                                                                                                                                       Page 2

%ZTBKC    ;SF/GJL - GLOBAL BLOCK COUNT ;05/24/2007  686246.738699

 +1       ;;7.3;TOOLKIT;**80**;Apr 25, 1995;Build 6

 +2       ;

 +3       ;X = FULL Global Reference: NAME(SUB1,...,SUBn)

 +4       ;

 +5        NEW %ZIS,DIRUT,DTOUT,DUOUT,POP

 +6        SET U="^"

           SET %BS=""

           SET XX1=0

           KILL ^XUTL($JOB)

 +7        IF $PIECE($GET(^%ZOSF("OS")),"^")["OpenM-NT"

               NEW %ZTBKVER

               Begin DoDot:1

 +8                SET %ZTBKVER=$PIECE($$VERSION^%ZOSV,".",1,2)

 +9                IF %ZTBKVER="5.0"!(%ZTBKVER'<5.2)

                       DO ASKDIR^%ZTBKC1

                       QUIT

 +10               WRITE !,"This version of the Block Count Utility does not support this version of Cache'"

 +11               SET %ZTBKVER=""

               End DoDot:1

               if $GET(%ZTBKVER)']""!$DATA(DUOUT)!$DATA(DIRUT)

                   GOTO QUIT

READ       WRITE !!,"Block Count for Global ^"

           IF %BS]""

               WRITE %BS,"//"

 +1        READ X:$SELECT($DATA(DTIME):DTIME,1:300),!

           if '$TEST!(X="^")

               GOTO QUIT

           IF X=""

               SET X=%BS

STRIP      IF (X?1"^".E)!(X?1" ".E)

               SET X=$EXTRACT(X,2,256)

               GOTO STRIP

 +1        IF X=""

               GOTO READY

 +2        IF X="*"

               SET ZTBKCALL=1

               GOTO READY

 +3        IF X["*"

               WRITE !,$CHAR(7),"Wild cards not allowed as part of the global name."

               GOTO SYNTAX

 +4        IF X?1"??".E

               DO QQ

               GOTO READ

 +5        IF X?1"?".E

               GOTO SYNTAX

 +6        IF X?1"(".E

               SET %BS=""

               GOTO SYNTAX

 +7        IF $PIECE(X,"(")'?.1"^".1"%"1A.AN

               WRITE !,$CHAR(7),"Only alphanumerics are allowed in global names."

               GOTO SYNTAX

 +8        IF $LENGTH(X,"(")>1

               IF $EXTRACT(X,$LENGTH(X))'=")"

                   GOTO SYNTAX

 +9        IF $LENGTH(X,"(")>1

               IF $PIECE($EXTRACT(X,1,$LENGTH(X)-1),"(",2,255)']""

                   GOTO SYNTAX

 +10       SET %T=X

           SET %Z=1

           FOR %A=1:1

               if $EXTRACT(%T,%A)=""

                   QUIT

               IF $EXTRACT(%T,%A)=""""

                   DO QUOTES

 +11       IF %Z-1

               GOTO SYNTAX2

 +12       SET %BS=X

           SET X=U_%T

           SET Y=$DATA(@(U_%BS))

           WRITE $SELECT(Y=0:" doesn't exist.",1:"OK")

           IF Y

               SET XX1=XX1+1

               SET ^XUTL($JOB,XX1)=%BS_X

 +13       SET %BS=""

           GOTO READ

QUOTES     IF ((%Z=0)&($EXTRACT(%T,%A+1)=""""))

               SET %T=$EXTRACT(%T,0,%A)_$EXTRACT(%T,%A+2,999)

 +1       IF '$TEST

               SET %T=$EXTRACT(%T,0,%A-1)_$EXTRACT(%T,%A+1,999)

               SET %A=%A-1

               SET %Z=1-%Z

 +2        QUIT

SYNTAX     WRITE !,"Enter: * for all globals in current directory, or"

 +1        WRITE !,"Enter: a FULL Global Reference, e.g. ^DD(3,""GL""), or"

 +2        WRITE !,"       ^ "

           if %BS=""

               WRITE "or NULL "

           WRITE "to quit."

 +3        WRITE !!,"Enter: ? for this help, or"

 +4        WRITE !,"       ?? for more help."

 +5        GOTO READ

SYNTAX2    WRITE !,?5,"I'm sorry, but I don't understand your use of quotes."

 +1        WRITE !,"Please surround string subscripts with quotes and any quote"

 +2        WRITE !,"which is a part of the subscript should be doubled."

 +3        GOTO READ

QQ        ;Double question mark response

 +1        KILL DIR

           SET DIR(0)="SO^S:Show current selection"

 +2        SET DIR(0)=DIR(0)_";D:De-select from current selection"

 +3        SET DIR(0)=DIR(0)_";M:More help"

 +4        DO ^DIR

 +5        IF Y="S"

               DO SHOW

               GOTO QQ

 +6        IF Y="D"

               DO DSEL

               GOTO QQ

 +7        IF Y="M"

               DO XTNDHELP

               GOTO QQ

 +8        QUIT

SHOW      ;Show current selection

 +1        IF '$DATA(IOF)

               DO HOME^%ZIS

 +2        IF $ORDER(^XUTL($JOB,0))'>0

               Begin DoDot:1

 +3                WRITE !!,?20,"You have not selected any globals.",!

 +4                KILL DIR

                   SET DIR(0)="E"

                   DO ^DIR

               End DoDot:1

               QUIT

 +5        WRITE @IOF,!,"You have selected the following globals:",!

 +6        SET %U=""

           FOR %I=1:1

               SET %A=$GET(^XUTL($JOB,%I))

               if %A=""

                   QUIT

               Begin DoDot:1

 +7                WRITE !,?8,"^"_$PIECE(%A,U)

               End DoDot:1

 +8        KILL DIR

           SET DIR(0)="E"

           DO ^DIR

 +9        QUIT

DSEL      ;Ask directory

 +1        NEW ZTBKCLST

 +2        IF $ORDER(^XUTL($JOB,0))'>0

               Begin DoDot:1

 +3                WRITE !!,?20,"You have not selected any globals.",!

 +4                KILL DIR

                   SET DIR(0)="E"

                   DO ^DIR

               End DoDot:1

               QUIT

 +5        KILL DIR

           SET DIR("A",1)="To de-select from the selected globals:"

 +6        SET %U=""

           FOR %I=1:1

               SET %A=$GET(^XUTL($JOB,%I))

               if %A=""

                   QUIT

               Begin DoDot:1

 +7                SET DIR("A",%I+1)=$JUSTIFY("",3)_$JUSTIFY(%I,3)_$JUSTIFY("^",7)_$PIECE(%A,U)

 +8                SET ZTBKCLST(%I)=%A

               End DoDot:1

 +9        SET DIR("A")="Enter a list or a range of numbers: "

 +10       SET DIR(0)="L^"_"1:"_(%I-1)

 +11       WRITE !

           DO ^DIR

 +12       if $DATA(DTOUT)!$DATA(DIRUT)

               QUIT

 +13       WRITE !

 +14       FOR %I=1:1

               SET %A=$PIECE(Y,",",%I)

               if %A']""

                   QUIT

               if (%A'=+%A)

                   QUIT

               KILL ZTBKCLST(%A)

               WRITE "."

 +15       SET %A=$ORDER(ZTBKCLST(""))

           IF %A=""

               Begin DoDot:1

 +16               FOR %I=0:0

                       SET %I=$ORDER(^XUTL($JOB,%I))

                       if %I'>0

                           QUIT

                       if %I'=+%I

                           QUIT

                       KILL ^XUTL($JOB,%I)

 +17               SET XX1=0

               End DoDot:1

               QUIT

 +18       FOR %I=1:1

               if %A']""&($GET(^XUTL($JOB,%I))']"")

                   QUIT

               Begin DoDot:1

 +19               IF %A]""

                       SET ^XUTL($JOB,%I)=ZTBKCLST(%A)

                       SET %A=$ORDER(ZTBKCLST(%A))

 +20              IF '$TEST

                       KILL ^XUTL($JOB,%I)

               End DoDot:1

 +21       SET XX1=$ORDER(XUTL($JOB,"@"),-1)

           IF XX1'=+XX1

               SET XX1=0

 +22       QUIT

XTNDHELP  ;Extended help

 +1        IF '$DATA(IOF)

               DO HOME^%ZIS

 +2        WRITE @IOF,!,?35,"More Help",!

 +3        WRITE !,?10,"Globals that contain commas in subscripts may not produce accurate"

 +4        WRITE !,?10,"block counts.  Also, avoid specifying full global references"

 +5        WRITE !,?10,"that contain commas in the subscripts when entering globals"

 +6        WRITE !,?10,"at the 'Block Count for Global ^' prompt."

 +7        WRITE !,?10,""

 +8        WRITE !,?10,"After entering a double question mark ('??') response to the"

 +9        WRITE !,?10,"'Block Count for Global ^' prompt, enter 'S' for a listing"

 +10       WRITE !,?10,"of globals selected or 'D' to de-select globals from this list."

 +11       WRITE !

           KILL DIR

           SET DIR(0)="E"

           DO ^DIR

 +12       QUIT

READY      IF '$DATA(ZTBKCALL)

               IF $ORDER(^XUTL($JOB,0))'>0

                   Begin DoDot:1

 +1                    WRITE !!,?20,"No globals have been selected!!!",!

                   End DoDot:1

                   GOTO QUIT

 +2        WRITE !,"Output results on"

           SET %ZIS="Q"

           DO ^%ZIS

           if POP

               GOTO QUIT

 +3        IF $DATA(IO("Q"))

               SET ZTRTN=$SELECT($DATA(ZTBKCALL):"ALL^%ZTBKC1",1:"DQ^%ZTBKC")

               SET ZTDESC="Global block count"

               SET ZTSAVE("^XUTL($J,")=""

               DO ^%ZTLOAD

               KILL ZTSK

               USE IO(0)

               DO ^%ZISC

               KILL ZTRTN,ZTDESC,ZTSAVE

               GOTO QUIT

 +4        IF $DATA(ZTBKCALL)

               USE IO

               DO ALL^%ZTBKC1

               USE IO(0)

               DO ^%ZISC

               GOTO QUIT

DQ        ;

 +1        USE IO

           FOR XX1=0:0

               SET XX1=$ORDER(^XUTL($JOB,XX1))

               if XX1'>0

                   QUIT

               SET %T=^(XX1)

               SET %BS=$PIECE(%T,U,1)

               SET X=$PIECE(%T,U,2)

               WRITE !,"Global ^",%BS

               DO ENCOUNT

               WRITE $SELECT(X'>0:" doesn't exist",1:" has "_X_" data block")

               if X>1

                   WRITE "s"

QUIT       if $DATA(IO(0))#2

               USE IO(0)

           DO ^%ZISC

           KILL DIR,X,XX1,Y,ZTBKCALL,%A,%I,%T,%U,%Z,%BS

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +1        QUIT

ALL       ;All Globals in Directory

 +1        SET %A=$PIECE(^%ZOSF("OS"),"^",1)

 +2        DO ALL^%ZTBKC1

           GOTO ALLEXIT

 +3       ;I %A="DSM-3" D ALL^%ZTBKC1 G ALLEXIT

 +4       ;I %A="M/11" D ALLM11 G ALLEXIT

 +5       ;I %A="M/11+" D ALL^%ZTBKC1 G ALLEXIT

 +6       ;I %A="M/VX" D ALL^%ZTBKC1 G ALLEXIT

 +7       ;I %A["MSM" D ALL^%ZTBKC1 G ALLEXIT

 +8       ;I %A["VAX DSM" G ALL^%ZTBKC1

ALLEXIT    KILL %A

 +1        QUIT

ALLM11    ;Directory at

 +1        WRITE $CHAR(7),"  NOT AVAILABLE!!!!"

 +2        QUIT

ENCOUNT   ;  X = Full Global Reference: NAME(SUB1,...,SUBn)

 +1       ;  Surrounding/doubled quotes should have been removed from subscripts

 +2       ;  The count is not accurate for subscripts containing commas

 +3        SET %T=-1

           SET %A=$PIECE(^%ZOSF("OS"),"^")

           IF X?1"^".E

               SET X=$EXTRACT(X,2,255)

 +4        DO ^%ZTBKC1

 +5       ;I "^MSM-UNIX^MSM-PC^VAX DSM(V5)^DSM-3^M/11^M/11+^M/VX^"[("^"_%A_"^") D ^%ZTBKC1

EXIT       SET X=%T

           KILL %A,%T

 +1        QUIT

ZTBKC.m