%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
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
Q
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."
D
. 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
Q
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)
Q
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))
Q
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
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."
Q
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
Q
%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 !
Q
%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
Q
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[".")
Q
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
