Routine: ZTBKCONT

%ZTBKC1 ;SF/GJL,SFCIOFO/AC - OPEN M BLOCK COUNT ;06/05/2007  1720232.438851

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

 I $$ONAPPSVR G EXIT

 O 63::0 E  S %T="The VIEW device is busy." G EXIT

 S %G=$G(^XUTL($J,"ZTBKCDIR"))

 I %G="" D

 .S %G=$ZU(12,"")

 .S ^XUTL($J,"ZTBKCDIR")=%G

 S %B=$ZU(49,%G),%ZTBKBDB=$P(%B,",",21),%B=$P(%B,",",7) G EXIT:'%B

 ;%B=directory block--Not used here.

 O 63:"^^"_%G

ONTGD ;FIND AND PARSE GLOBAL DIRECTORY BLOCK

 ;The global directory block is not parsed here.

 ;We use Cache's APIs/Extrinsic functions to obtain the

 ;first data block of the selected global root.

 ;===============================

 N %ZTBKNSP S %ZTBKNSP="^^"_%G

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

 I $G(%BS)]"" S X=%BS

 S %ZTBKGLO="^"_X,%A="^["""_%ZTBKNSP_"""]"_X

 I '$D(@%A) G EXIT

 I %ZTBKVER="5.0" D  I 1

 . S %=$$GetGlobalPointers^%DM(%G,%ZTBKGLO,.%ZTBKTOP,.%B)

 E  S %=$$GetGlobalPointers^%SYS.DATABASE(%G,%ZTBKGLO,.%ZTBKTOP,.%B)

 V %B

 I % S %O=1,%E=$V(%O*2-1,-6),%H=0,%J=0,%T=0 G ONTDATA

 G EXIT

ONTPTBK ;POINTER BLOCK

 ;Not used here

ONTPTLP ;POINTER BLOCK LOOP

 ;Not used here

 G EXIT

ONTPTNT ;PROCESS NODES IN POINTER BLOCK

 ;Not used here

ONTPTDW ;SAVE OFF LAST DOWN LINK BLOCK FOR LATER USE

 ;Not used here

ONTDTBK ;DATA BLOCK

 V %B

 S %O=1,%E=$V(%O*2-1,-6),%T=%T+1,%J=0

ONTDATA ;DATA BLOCK LOOP TO PROCESS NODES

 I %E'="" G ONTDTNT

 S %B=$CASE(%ZTBKBDB,0:$V(2040,0,"3O"),:$V($ZUTIL(40,32,4),0,4)) I %B G ONTDTBK

 G EXIT

ONTDTNT ;PROCESS DATA NODES

 S %J=%J+1 D ONTNODE I %I=1 S:%H=0 %T=%T+1 D ONTSTBIG S %H=1,%E="" G ONTDATA ;Next BLK

 I %I=2 S %O=%O+1 G ONTDATA

 S:%J=1 %T=%T-1 G EXIT

 G EXIT

ONTNODE ;BUILD STRINGS TO COMPARE SUBSCRIPTS

 S %F=$V(%O*2-1,-5),%M=$P(%F,"(",2),%M=$P(%M,")",1),%M=","_%M

 G ONTTSTN

ONTPROC ;PROCESS ENCODED DATA

 ;Not used here

ONTASCI ;PROCESS ASCII CHAR

 ;Not used here

ONTPOS ;PROCESS POSITIVE DATA

 ;Not used here

ONTNEG ;PROCESS NEGATIVE DATA

 ;Not used here

ONTTSTN S %M=$E(%M,2,256),%S=$P(X,"(",2),%S=$P(%S,")",1) I (%S="")!(%S=%M) S %I=1 Q

ONTTSTL S %X=$P(%S,",",1),%Y=$P(%M,",",1) I +%X'=%X G ONTSTR

 I %Y="" S %I=2 Q

 I +%Y'=%Y S %I=3 Q

 I %X>%Y S %I=2 Q

 I %X<%Y S %I=3 Q

ONTTSTC S %S=$P(%S,",",2,256) I %S="" S %I=1 Q

 S %M=$P(%M,",",2,256) I %M="" S %I=2 Q

 G ONTTSTL

ONTSTR I +%Y=%Y S %I=2 Q

 I %X]%Y S %I=2 Q

 I %X'=%Y S %I=3 Q

 G ONTTSTC

ONTSTBIG ;Check for big strings

 S %ZTBKEND=0

 F %A=%O:1 S %E=$V(%A*2-1,-6) Q:%E=""  D  Q:%ZTBKEND

 . S %ZTBKCY=$V(%A*2-1,-5)

 . S %ZTBKCY1=$QL($NA(@%ZTBKCY))

 . S %ZTBKCX=$NA(@("^"_X))

 . S %ZTBKCX1=$QL($NA(@%ZTBKCX))

 . I %ZTBKCX1>%ZTBKCY1 S %ZTBKEND=1 Q

 . I $NA(@%ZTBKCX)'=$NA(@%ZTBKCY,%ZTBKCX1) S %ZTBKEND=1 Q

 . S %ZTBKCY=$V(%A*2,-6)

 . I $A(%ZTBKCY)'=5,($A(%ZTBKCY)'=$CASE(%ZTBKBDB,0:9,:7)),($A(%ZTBKCY)'=3) Q

 . S %ZTBKCX=$P(%ZTBKCY,",",2),%ZTBKCX1=$P(%ZTBKCY,",",3)

 . S %T=%T+(%ZTBKCX-1)+''%ZTBKCX1

. Q

ASKDIR ;Ask directory/data set name

 N %A,%I,DEND,DIRNAM,GD

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

 I %ZTBKVER="5.0"!(%ZTBKVER'<5.2) D ASK I 1

 E  W !,"An error has just occurred!" Q

 I $G(DUOUT)=1 Q

 I $G(DIRNAM)']"" S DUOUT=1 Q

 S ^XUTL($J,"ZTBKCDIR")=DIRNAM

ASK ; Enter here to select default directory

 N %ZTBKERR,%ZTBKEC S %ZTBKERR=0

 I $$ONAPPSVR D  Q

 . S DUOUT=1

 . W !,"Note:  You are attempting to run this utility"

 . W !,?7,"on a Cache' ECP Application Server."

 . W !,?7,"This utility will not run on an ECP Application Server."

 . W !,?7,"Please try running this utility again on an ECP Data Server."

 . N $ETRAP,$ESTACK S $ETRAP="D ERROR^%ZTBKC1"

 . D RDCHK

 I %ZTBKERR=1 D ASKBYAPI Q

 I %ZTBKERR=2 D  Q

 . S DUOUT=1

 . W !,"The following error just occurred:"

 . W !,%ZTBKEC

 S DIRNAM=$ZU(12,"")

 K DIR S DIR(0)="Y",DIR("B")="YES"

 S DIR("A")="Use default directory"

 S DIR("A",1)="Default directory is "_DIRNAM

 S DIR("?")="^D HELP^%ZTBKC1"

 D ^DIR

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

 I 'Y D ASK2

ASK2 ; Enter here to select directory from a list

 N MGDIR,ZTBKCDIR

 K DIR S DIR("A",1)="Select a number from the following:"

 S %U="",MGDIR="%SYS" F %I=1:1 S %U=$O(^|MGDIR|SYS("UCI",%U)) Q:%U=""  D

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

 .  S ZTBKCDIR(%I)=%U

 .  I %U=DIRNAM S DIR("B")=%I

 S DIR("A")="Enter a number "

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

 W ! D ^DIR

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

 S DIRNAM=ZTBKCDIR(Y)

RDCHK ; Check to see if ^SYS global is readable with current privs.

 N %U,MGDIR

 S %U="",MGDIR="%SYS"

 S %U=$O(^|MGDIR|SYS("UCI",%U))

ONAPPSVR() ;Check to see if this utility is run from an ECP Application Server

 Q ($ZU(12,"")="")

ASKBYAPI ;

 W !,"Note:  You do not have adequate privileges to view the ^SYS global."

 W !,?7,"Therefore, a directory listing will not be available"

 W !,?7,"at the directory prompt."

 W !!,?7,"Also, Cache's API will be used to prompt for directory.",!!

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

 I %ZTBKVER="5.0" D ASK^%FILE I 1

 E  I %ZTBKVER'<5.2 D ASK^%SYS.FILE I 1

 E  W !,"An error has just occurred!" Q

HELP ;Single question mark help for 'Use default directory' prompt

 W !,"Enter either 'Y' or 'N'."

 W !!,"If you enter 'N' for 'NO', you may then select a directory from a list."

 W !,"Block count on globals will only be returned for globals that reside"

 W !,"in the selected directory."

ERROR ; Error trap for disconnect error and return back to the read loop.

 S $ETRAP="D UNWIND^%ZTER"

 S %ZTBKEC=$$EC^%ZOSV

 I %ZTBKEC["PROTECT" S %ZTBKERR=1 D UNWIND^%ZTER Q

 S %ZTBKERR=2 D ^%ZTER

 D UNWIND^%ZTER

%Z3 N X S PG=PG+1,ST=0 D:(PG>1)&%ZTBIOC2&%ZTBIOC %Z5 Q:ST

 U IO W:((9+$Y'<IOSL)&($Y>3))!(PG>1) @IOF

 S %SK=$X W ?(%SK+25),"Global Block Count  ",$S(PG>1:"(cont.)",1:""),?(%SK+60),"Page ",PG

 W !,$G(^XUTL($J,"ZTBKCDIR")),"  " S %SK=$X+1 W "Globals",?(%SK+12),"Data Blocks"

 W ?(%SK+34),%ZTBKCDT W !

%Z5 U IO(0) R !,"Press RETURN to continue or '^' to exit: ",ST:600 S ST=$S(ST["^":1,1:0) S:ST %GLO="zzzz" ;SET SOME VARIABLE TO STOP LOOP

DD S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".")

ALL ;Entry point for block count of all globals.

ALLONT ;Directory at ^UTILITY("GLO")

 K ^UTILITY("%ZTBKC",$J)

 O 63::0 E  S %T="The VIEW device is busy." G EXIT

 S %G=$G(^XUTL($J,"ZTBKCDIR"))

 I %G="" D

 .S %G=$ZU(12,"")

 .S ^XUTL($J,"ZTBKCDIR")=%G

 S %B=$ZU(49,%G),%B=$P(%B,",",7) G EXIT:'%B

 O 63:"^^"_%G

 N ST,PG

 S %ZTBIOC=(IO=IO(0)),%ZTBIOC2=$E(IOST,1,2)["C-"

 U IO W:%ZTBIOC2 @IOF I '%ZTBIOC,'$D(ZTQUEUED) U IO(0) W !!,"Printing report..."

 S %ZTBKCZY=IOSL-(255\IOM+1) K %D,%T,%TIM

AONTVUE V %B S %ZTBKCG=""

 S %ZTBKSIZ=$P($ZU(49,%G),",",2)

 S %ZTBKBIG=$CASE(%ZTBKSIZ,2048:0,:1)

 S %ZTBKCL=$CASE(%ZTBKBIG,0:$V(2040,0,"3O"),:$V($ZUTIL(40,32,4),0,4))

 S %E=$CASE(%ZTBKBIG,0:$V(2046,0,2),:$V($ZU(40,32,0),0,4)+$ZU(40,32,10))

 I %E>%ZTBKSIZ G EXIT

 S %O=$CASE(%ZTBKBIG,0:0,:$ZU(40,32,10))

AONTNXT G AONTPTR:%E'>%O

 S %ZTBKA=%O,%ZTBKRAW=$V(%ZTBKA,0,4),%ZTBKINF=$ZU(167,0,0,%ZTBKRAW)

 S %ZTBKA=%ZTBKA+4

 S %ZTBKCCC=$P(%ZTBKINF,"^",3),%ZTBKLEN=$P(%ZTBKINF,"^",4)

 S %ZTBKPAD=$P(%ZTBKINF,"^",5),%ZTBKSUB=$P(%ZTBKINF,"^",2)

 S %ZTBKCG="" I %ZTBKCCC S %ZTBKCG=$E(%ZTBKPRV,1,%ZTBKCCC)

 S %ZTBKCE=%ZTBKA+%ZTBKSUB-1,%O=%ZTBKA

AONTLOP S %Z=$V(%O,0),%O=%O+1 S:%Z %ZTBKCG=%ZTBKCG_$C(%Z) G AONTLOP:(%O'>%ZTBKCE)

 S ^UTILITY("%ZTBKC",$J,%ZTBKCG)=""

 S %ZTBKPRV=%ZTBKCG,%O=%ZTBKCE+%ZTBKLEN-%ZTBKSUB-3,%ZTBKCG="" G AONTNXT

AONTPTR S %B=%ZTBKCL I %B G AONTVUE

 D NOW^%DTC S Y=% D DD S %ZTBKCDT=Y

 S PG=0 D %Z3

 S (%TOT,%GLO)=0 F %II=1:1 S X=$O(^UTILITY("%ZTBKC",$J,%GLO)),%GLO=X Q:X=""  D:%ZTBKCZY'>$Y %Z3 Q:$G(ST)  S:X?1"^".E X=$E(X,2,255) W !,?%SK,X,?(%SK+15) S %T=-1 D %ZTBKC1 S X=%T S:X>0 %TOT=%TOT+X W:X<0 "-- no such global --" W:X'<0 X

 W !!?%SK,"Total",?(%SK+15),%TOT K %GLO,%II,%SK,%T,%TOT,%ZTBIOC,%ZTBIOC2,%ZTBKCDT,%ZTBKCZY,X,Y U IO(0) D ^%ZISC

EXIT C 63 K %,%A,%B,%C,%D,%E,%F,%G,%H,%I,%J,%K,%L,%M,%N,%O,%S,%V,%W,%X,%Y,%Z,%ST

 K %ZTBKA,%ZTBKBDB,%ZTBKBIG,%ZTBKCCC,%ZTBKCE,%ZTBKCG,%ZTBKCL,%ZTBKCX,%ZTBKCX1,%ZTBKCY,%ZTBKCY1,%ZTBKEND,%ZTBKGLO,%ZTBKINF,%ZTBKLEN,%ZTBKPAD,%ZTBKPRV,%ZTBKRAW,%ZTBKSIZ,%ZTBKSUB,%ZTBKTOP,%ZTBKVER

ZTBKCONT.m