| 1 | %ZTBKC1 ;SF/GJL,SFCIOFO/AC - OPEN M BLOCK COUNT ;06/05/2007 1720232.438851
|
|---|
| 2 | ;;7.3;TOOLKIT;**80**;Apr 25, 1995;Build 6
|
|---|
| 3 | ;
|
|---|
| 4 | I $$ONAPPSVR G EXIT
|
|---|
| 5 | O 63::0 E S %T="The VIEW device is busy." G EXIT
|
|---|
| 6 | S %G=$G(^XUTL($J,"ZTBKCDIR"))
|
|---|
| 7 | I %G="" D
|
|---|
| 8 | .S %G=$ZU(12,"")
|
|---|
| 9 | .S ^XUTL($J,"ZTBKCDIR")=%G
|
|---|
| 10 | S %B=$ZU(49,%G),%ZTBKBDB=$P(%B,",",21),%B=$P(%B,",",7) G EXIT:'%B
|
|---|
| 11 | ;%B=directory block--Not used here.
|
|---|
| 12 | O 63:"^^"_%G
|
|---|
| 13 | ONTGD ;FIND AND PARSE GLOBAL DIRECTORY BLOCK
|
|---|
| 14 | ;The global directory block is not parsed here.
|
|---|
| 15 | ;We use Cache's APIs/Extrinsic functions to obtain the
|
|---|
| 16 | ;first data block of the selected global root.
|
|---|
| 17 | ;===============================
|
|---|
| 18 | N %ZTBKNSP S %ZTBKNSP="^^"_%G
|
|---|
| 19 | I $G(%ZTBKVER)']"" S %ZTBKVER=$P($$VERSION^%ZOSV,".",1,2)
|
|---|
| 20 | I $G(%BS)]"" S X=%BS
|
|---|
| 21 | S %ZTBKGLO="^"_X,%A="^["""_%ZTBKNSP_"""]"_X
|
|---|
| 22 | I '$D(@%A) G EXIT
|
|---|
| 23 | I %ZTBKVER="5.0" D I 1
|
|---|
| 24 | . S %=$$GetGlobalPointers^%DM(%G,%ZTBKGLO,.%ZTBKTOP,.%B)
|
|---|
| 25 | E S %=$$GetGlobalPointers^%SYS.DATABASE(%G,%ZTBKGLO,.%ZTBKTOP,.%B)
|
|---|
| 26 | V %B
|
|---|
| 27 | I % S %O=1,%E=$V(%O*2-1,-6),%H=0,%J=0,%T=0 G ONTDATA
|
|---|
| 28 | G EXIT
|
|---|
| 29 | ONTPTBK ;POINTER BLOCK
|
|---|
| 30 | ;Not used here
|
|---|
| 31 | ONTPTLP ;POINTER BLOCK LOOP
|
|---|
| 32 | ;Not used here
|
|---|
| 33 | G EXIT
|
|---|
| 34 | ONTPTNT ;PROCESS NODES IN POINTER BLOCK
|
|---|
| 35 | ;Not used here
|
|---|
| 36 | ONTPTDW ;SAVE OFF LAST DOWN LINK BLOCK FOR LATER USE
|
|---|
| 37 | ;Not used here
|
|---|
| 38 | ;
|
|---|
| 39 | ONTDTBK ;DATA BLOCK
|
|---|
| 40 | V %B
|
|---|
| 41 | S %O=1,%E=$V(%O*2-1,-6),%T=%T+1,%J=0
|
|---|
| 42 | ONTDATA ;DATA BLOCK LOOP TO PROCESS NODES
|
|---|
| 43 | I %E'="" G ONTDTNT
|
|---|
| 44 | S %B=$CASE(%ZTBKBDB,0:$V(2040,0,"3O"),:$V($ZUTIL(40,32,4),0,4)) I %B G ONTDTBK
|
|---|
| 45 | G EXIT
|
|---|
| 46 | ONTDTNT ;PROCESS DATA NODES
|
|---|
| 47 | 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
|
|---|
| 48 | I %I=2 S %O=%O+1 G ONTDATA
|
|---|
| 49 | S:%J=1 %T=%T-1 G EXIT
|
|---|
| 50 | G EXIT
|
|---|
| 51 | ONTNODE ;BUILD STRINGS TO COMPARE SUBSCRIPTS
|
|---|
| 52 | S %F=$V(%O*2-1,-5),%M=$P(%F,"(",2),%M=$P(%M,")",1),%M=","_%M
|
|---|
| 53 | G ONTTSTN
|
|---|
| 54 | ONTPROC ;PROCESS ENCODED DATA
|
|---|
| 55 | ;Not used here
|
|---|
| 56 | ONTASCI ;PROCESS ASCII CHAR
|
|---|
| 57 | ;Not used here
|
|---|
| 58 | ONTPOS ;PROCESS POSITIVE DATA
|
|---|
| 59 | ;Not used here
|
|---|
| 60 | ONTNEG ;PROCESS NEGATIVE DATA
|
|---|
| 61 | ;Not used here
|
|---|
| 62 | ONTTSTN S %M=$E(%M,2,256),%S=$P(X,"(",2),%S=$P(%S,")",1) I (%S="")!(%S=%M) S %I=1 Q
|
|---|
| 63 | ONTTSTL S %X=$P(%S,",",1),%Y=$P(%M,",",1) I +%X'=%X G ONTSTR
|
|---|
| 64 | I %Y="" S %I=2 Q
|
|---|
| 65 | I +%Y'=%Y S %I=3 Q
|
|---|
| 66 | I %X>%Y S %I=2 Q
|
|---|
| 67 | I %X<%Y S %I=3 Q
|
|---|
| 68 | ONTTSTC S %S=$P(%S,",",2,256) I %S="" S %I=1 Q
|
|---|
| 69 | S %M=$P(%M,",",2,256) I %M="" S %I=2 Q
|
|---|
| 70 | G ONTTSTL
|
|---|
| 71 | ONTSTR I +%Y=%Y S %I=2 Q
|
|---|
| 72 | I %X]%Y S %I=2 Q
|
|---|
| 73 | I %X'=%Y S %I=3 Q
|
|---|
| 74 | G ONTTSTC
|
|---|
| 75 | ONTSTBIG ;Check for big strings
|
|---|
| 76 | S %ZTBKEND=0
|
|---|
| 77 | F %A=%O:1 S %E=$V(%A*2-1,-6) Q:%E="" D Q:%ZTBKEND
|
|---|
| 78 | . S %ZTBKCY=$V(%A*2-1,-5)
|
|---|
| 79 | . S %ZTBKCY1=$QL($NA(@%ZTBKCY))
|
|---|
| 80 | . S %ZTBKCX=$NA(@("^"_X))
|
|---|
| 81 | . S %ZTBKCX1=$QL($NA(@%ZTBKCX))
|
|---|
| 82 | . I %ZTBKCX1>%ZTBKCY1 S %ZTBKEND=1 Q
|
|---|
| 83 | . I $NA(@%ZTBKCX)'=$NA(@%ZTBKCY,%ZTBKCX1) S %ZTBKEND=1 Q
|
|---|
| 84 | . S %ZTBKCY=$V(%A*2,-6)
|
|---|
| 85 | . I $A(%ZTBKCY)'=5,($A(%ZTBKCY)'=$CASE(%ZTBKBDB,0:9,:7)),($A(%ZTBKCY)'=3) Q
|
|---|
| 86 | . S %ZTBKCX=$P(%ZTBKCY,",",2),%ZTBKCX1=$P(%ZTBKCY,",",3)
|
|---|
| 87 | . S %T=%T+(%ZTBKCX-1)+''%ZTBKCX1
|
|---|
| 88 | . Q
|
|---|
| 89 | Q
|
|---|
| 90 | ASKDIR ;Ask directory/data set name
|
|---|
| 91 | N %A,%I,DEND,DIRNAM,GD
|
|---|
| 92 | I $G(%ZTBKVER)']"" S %ZTBKVER=$P($$VERSION^%ZOSV,".",1,2)
|
|---|
| 93 | I %ZTBKVER="5.0"!(%ZTBKVER'<5.2) D ASK I 1
|
|---|
| 94 | E W !,"An error has just occurred!" Q
|
|---|
| 95 | I $G(DUOUT)=1 Q
|
|---|
| 96 | I $G(DIRNAM)']"" S DUOUT=1 Q
|
|---|
| 97 | S ^XUTL($J,"ZTBKCDIR")=DIRNAM
|
|---|
| 98 | Q
|
|---|
| 99 | ASK ; Enter here to select default directory
|
|---|
| 100 | N %ZTBKERR,%ZTBKEC S %ZTBKERR=0
|
|---|
| 101 | I $$ONAPPSVR D Q
|
|---|
| 102 | . S DUOUT=1
|
|---|
| 103 | . W !,"Note: You are attempting to run this utility"
|
|---|
| 104 | . W !,?7,"on a Cache' ECP Application Server."
|
|---|
| 105 | . W !,?7,"This utility will not run on an ECP Application Server."
|
|---|
| 106 | . W !,?7,"Please try running this utility again on an ECP Data Server."
|
|---|
| 107 | D
|
|---|
| 108 | . N $ETRAP,$ESTACK S $ETRAP="D ERROR^%ZTBKC1"
|
|---|
| 109 | . D RDCHK
|
|---|
| 110 | I %ZTBKERR=1 D ASKBYAPI Q
|
|---|
| 111 | I %ZTBKERR=2 D Q
|
|---|
| 112 | . S DUOUT=1
|
|---|
| 113 | . W !,"The following error just occurred:"
|
|---|
| 114 | . W !,%ZTBKEC
|
|---|
| 115 | S DIRNAM=$ZU(12,"")
|
|---|
| 116 | K DIR S DIR(0)="Y",DIR("B")="YES"
|
|---|
| 117 | S DIR("A")="Use default directory"
|
|---|
| 118 | S DIR("A",1)="Default directory is "_DIRNAM
|
|---|
| 119 | S DIR("?")="^D HELP^%ZTBKC1"
|
|---|
| 120 | D ^DIR
|
|---|
| 121 | Q:$D(DTOUT)!$D(DIRUT)
|
|---|
| 122 | I 'Y D ASK2
|
|---|
| 123 | Q
|
|---|
| 124 | ASK2 ; Enter here to select directory from a list
|
|---|
| 125 | N MGDIR,ZTBKCDIR
|
|---|
| 126 | K DIR S DIR("A",1)="Select a number from the following:"
|
|---|
| 127 | S %U="",MGDIR="%SYS" F %I=1:1 S %U=$O(^|MGDIR|SYS("UCI",%U)) Q:%U="" D
|
|---|
| 128 | . S DIR("A",%I+1)=" "_$J(%I,3)_" "_%U
|
|---|
| 129 | . S ZTBKCDIR(%I)=%U
|
|---|
| 130 | . I %U=DIRNAM S DIR("B")=%I
|
|---|
| 131 | S DIR("A")="Enter a number "
|
|---|
| 132 | S DIR(0)="N^"_"1:"_(%I-1)
|
|---|
| 133 | W ! D ^DIR
|
|---|
| 134 | Q:$D(DTOUT)!$D(DIRUT)
|
|---|
| 135 | S DIRNAM=ZTBKCDIR(Y)
|
|---|
| 136 | Q
|
|---|
| 137 | RDCHK ; Check to see if ^SYS global is readable with current privs.
|
|---|
| 138 | N %U,MGDIR
|
|---|
| 139 | S %U="",MGDIR="%SYS"
|
|---|
| 140 | S %U=$O(^|MGDIR|SYS("UCI",%U))
|
|---|
| 141 | Q
|
|---|
| 142 | ONAPPSVR() ;Check to see if this utility is run from an ECP Application Server
|
|---|
| 143 | Q ($ZU(12,"")="")
|
|---|
| 144 | ;
|
|---|
| 145 | ASKBYAPI ;
|
|---|
| 146 | W !,"Note: You do not have adequate privileges to view the ^SYS global."
|
|---|
| 147 | W !,?7,"Therefore, a directory listing will not be available"
|
|---|
| 148 | W !,?7,"at the directory prompt."
|
|---|
| 149 | W !!,?7,"Also, Cache's API will be used to prompt for directory.",!!
|
|---|
| 150 | I $G(%ZTBKVER)']"" S %ZTBKVER=$P($$VERSION^%ZOSV,".",1,2)
|
|---|
| 151 | I %ZTBKVER="5.0" D ASK^%FILE I 1
|
|---|
| 152 | E I %ZTBKVER'<5.2 D ASK^%SYS.FILE I 1
|
|---|
| 153 | E W !,"An error has just occurred!" Q
|
|---|
| 154 | Q
|
|---|
| 155 | HELP ;Single question mark help for 'Use default directory' prompt
|
|---|
| 156 | W !,"Enter either 'Y' or 'N'."
|
|---|
| 157 | W !!,"If you enter 'N' for 'NO', you may then select a directory from a list."
|
|---|
| 158 | W !,"Block count on globals will only be returned for globals that reside"
|
|---|
| 159 | W !,"in the selected directory."
|
|---|
| 160 | Q
|
|---|
| 161 | ERROR ; Error trap for disconnect error and return back to the read loop.
|
|---|
| 162 | S $ETRAP="D UNWIND^%ZTER"
|
|---|
| 163 | S %ZTBKEC=$$EC^%ZOSV
|
|---|
| 164 | I %ZTBKEC["PROTECT" S %ZTBKERR=1 D UNWIND^%ZTER Q
|
|---|
| 165 | S %ZTBKERR=2 D ^%ZTER
|
|---|
| 166 | D UNWIND^%ZTER
|
|---|
| 167 | Q
|
|---|
| 168 | %Z3 N X S PG=PG+1,ST=0 D:(PG>1)&%ZTBIOC2&%ZTBIOC %Z5 Q:ST
|
|---|
| 169 | U IO W:((9+$Y'<IOSL)&($Y>3))!(PG>1) @IOF
|
|---|
| 170 | S %SK=$X W ?(%SK+25),"Global Block Count ",$S(PG>1:"(cont.)",1:""),?(%SK+60),"Page ",PG
|
|---|
| 171 | W !,$G(^XUTL($J,"ZTBKCDIR"))," " S %SK=$X+1 W "Globals",?(%SK+12),"Data Blocks"
|
|---|
| 172 | W ?(%SK+34),%ZTBKCDT W !
|
|---|
| 173 | Q
|
|---|
| 174 | %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
|
|---|
| 175 | Q
|
|---|
| 176 | 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[".")
|
|---|
| 177 | Q
|
|---|
| 178 | ALL ;Entry point for block count of all globals.
|
|---|
| 179 | ALLONT ;Directory at ^UTILITY("GLO")
|
|---|
| 180 | K ^UTILITY("%ZTBKC",$J)
|
|---|
| 181 | O 63::0 E S %T="The VIEW device is busy." G EXIT
|
|---|
| 182 | S %G=$G(^XUTL($J,"ZTBKCDIR"))
|
|---|
| 183 | I %G="" D
|
|---|
| 184 | .S %G=$ZU(12,"")
|
|---|
| 185 | .S ^XUTL($J,"ZTBKCDIR")=%G
|
|---|
| 186 | S %B=$ZU(49,%G),%B=$P(%B,",",7) G EXIT:'%B
|
|---|
| 187 | O 63:"^^"_%G
|
|---|
| 188 | N ST,PG
|
|---|
| 189 | S %ZTBIOC=(IO=IO(0)),%ZTBIOC2=$E(IOST,1,2)["C-"
|
|---|
| 190 | U IO W:%ZTBIOC2 @IOF I '%ZTBIOC,'$D(ZTQUEUED) U IO(0) W !!,"Printing report..."
|
|---|
| 191 | S %ZTBKCZY=IOSL-(255\IOM+1) K %D,%T,%TIM
|
|---|
| 192 | AONTVUE V %B S %ZTBKCG=""
|
|---|
| 193 | S %ZTBKSIZ=$P($ZU(49,%G),",",2)
|
|---|
| 194 | S %ZTBKBIG=$CASE(%ZTBKSIZ,2048:0,:1)
|
|---|
| 195 | S %ZTBKCL=$CASE(%ZTBKBIG,0:$V(2040,0,"3O"),:$V($ZUTIL(40,32,4),0,4))
|
|---|
| 196 | S %E=$CASE(%ZTBKBIG,0:$V(2046,0,2),:$V($ZU(40,32,0),0,4)+$ZU(40,32,10))
|
|---|
| 197 | I %E>%ZTBKSIZ G EXIT
|
|---|
| 198 | S %O=$CASE(%ZTBKBIG,0:0,:$ZU(40,32,10))
|
|---|
| 199 | AONTNXT G AONTPTR:%E'>%O
|
|---|
| 200 | S %ZTBKA=%O,%ZTBKRAW=$V(%ZTBKA,0,4),%ZTBKINF=$ZU(167,0,0,%ZTBKRAW)
|
|---|
| 201 | S %ZTBKA=%ZTBKA+4
|
|---|
| 202 | S %ZTBKCCC=$P(%ZTBKINF,"^",3),%ZTBKLEN=$P(%ZTBKINF,"^",4)
|
|---|
| 203 | S %ZTBKPAD=$P(%ZTBKINF,"^",5),%ZTBKSUB=$P(%ZTBKINF,"^",2)
|
|---|
| 204 | S %ZTBKCG="" I %ZTBKCCC S %ZTBKCG=$E(%ZTBKPRV,1,%ZTBKCCC)
|
|---|
| 205 | S %ZTBKCE=%ZTBKA+%ZTBKSUB-1,%O=%ZTBKA
|
|---|
| 206 | AONTLOP S %Z=$V(%O,0),%O=%O+1 S:%Z %ZTBKCG=%ZTBKCG_$C(%Z) G AONTLOP:(%O'>%ZTBKCE)
|
|---|
| 207 | S ^UTILITY("%ZTBKC",$J,%ZTBKCG)=""
|
|---|
| 208 | S %ZTBKPRV=%ZTBKCG,%O=%ZTBKCE+%ZTBKLEN-%ZTBKSUB-3,%ZTBKCG="" G AONTNXT
|
|---|
| 209 | AONTPTR S %B=%ZTBKCL I %B G AONTVUE
|
|---|
| 210 | D NOW^%DTC S Y=% D DD S %ZTBKCDT=Y
|
|---|
| 211 | S PG=0 D %Z3
|
|---|
| 212 | 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
|
|---|
| 213 | W !!?%SK,"Total",?(%SK+15),%TOT K %GLO,%II,%SK,%T,%TOT,%ZTBIOC,%ZTBIOC2,%ZTBKCDT,%ZTBKCZY,X,Y U IO(0) D ^%ZISC
|
|---|
| 214 | 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
|
|---|
| 215 | K %ZTBKA,%ZTBKBDB,%ZTBKBIG,%ZTBKCCC,%ZTBKCE,%ZTBKCG,%ZTBKCL,%ZTBKCX,%ZTBKCX1,%ZTBKCY,%ZTBKCY1,%ZTBKEND,%ZTBKGLO,%ZTBKINF,%ZTBKLEN,%ZTBKPAD,%ZTBKPRV,%ZTBKRAW,%ZTBKSIZ,%ZTBKSUB,%ZTBKTOP,%ZTBKVER
|
|---|
