%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
Q
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
Q
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
Q
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
Q
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
Q
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="@"
Q
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
Q
ALLM11 ;Directory at
W $C(7)," NOT AVAILABLE!!!!"
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZTBKC 5438 printed Dec 13, 2024@02:15:49 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
