Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ZTBKCONT

ZTBKCONT.m

Go to the documentation of this file.
  1. %ZTBKC1 ;SF/GJL,SFCIOFO/AC - OPEN M BLOCK COUNT ;06/05/2007  1720232.438851
  1.  ;;7.3;TOOLKIT;**80**;Apr 25, 1995;Build 6
  1.  ;
  1.  I $$ONAPPSVR G EXIT
  1.  O 63::0 E  S %T="The VIEW device is busy." G EXIT
  1.  S %G=$G(^XUTL($J,"ZTBKCDIR"))
  1.  I %G="" D
  1.  .S %G=$ZU(12,"")
  1.  .S ^XUTL($J,"ZTBKCDIR")=%G
  1.  S %B=$ZU(49,%G),%ZTBKBDB=$P(%B,",",21),%B=$P(%B,",",7) G EXIT:'%B
  1.  ;%B=directory block--Not used here.
  1.  O 63:"^^"_%G
  1. ONTGD ;FIND AND PARSE GLOBAL DIRECTORY BLOCK
  1.  ;The global directory block is not parsed here.
  1.  ;We use Cache's APIs/Extrinsic functions to obtain the
  1.  ;first data block of the selected global root.
  1.  ;===============================
  1.  N %ZTBKNSP S %ZTBKNSP="^^"_%G
  1.  I $G(%ZTBKVER)']"" S %ZTBKVER=$P($$VERSION^%ZOSV,".",1,2)
  1.  I $G(%BS)]"" S X=%BS
  1.  S %ZTBKGLO="^"_X,%A="^["""_%ZTBKNSP_"""]"_X
  1.  I '$D(@%A) G EXIT
  1.  I %ZTBKVER="5.0" D  I 1
  1.  . S %=$$GetGlobalPointers^%DM(%G,%ZTBKGLO,.%ZTBKTOP,.%B)
  1.  E  S %=$$GetGlobalPointers^%SYS.DATABASE(%G,%ZTBKGLO,.%ZTBKTOP,.%B)
  1.  V %B
  1.  I % S %O=1,%E=$V(%O*2-1,-6),%H=0,%J=0,%T=0 G ONTDATA
  1.  G EXIT
  1. ONTPTBK ;POINTER BLOCK
  1.  ;Not used here
  1. ONTPTLP ;POINTER BLOCK LOOP
  1.  ;Not used here
  1.  G EXIT
  1. ONTPTNT ;PROCESS NODES IN POINTER BLOCK
  1.  ;Not used here
  1. ONTPTDW ;SAVE OFF LAST DOWN LINK BLOCK FOR LATER USE
  1.  ;Not used here
  1.  ;
  1. ONTDTBK ;DATA BLOCK
  1.  V %B
  1.  S %O=1,%E=$V(%O*2-1,-6),%T=%T+1,%J=0
  1. ONTDATA ;DATA BLOCK LOOP TO PROCESS NODES
  1.  I %E'="" G ONTDTNT
  1.  S %B=$CASE(%ZTBKBDB,0:$V(2040,0,"3O"),:$V($ZUTIL(40,32,4),0,4)) I %B G ONTDTBK
  1.  G EXIT
  1. ONTDTNT ;PROCESS DATA NODES
  1.  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
  1.  I %I=2 S %O=%O+1 G ONTDATA
  1.  S:%J=1 %T=%T-1 G EXIT
  1.  G EXIT
  1. ONTNODE ;BUILD STRINGS TO COMPARE SUBSCRIPTS
  1.  S %F=$V(%O*2-1,-5),%M=$P(%F,"(",2),%M=$P(%M,")",1),%M=","_%M
  1.  G ONTTSTN
  1. ONTPROC ;PROCESS ENCODED DATA
  1.  ;Not used here
  1. ONTASCI ;PROCESS ASCII CHAR
  1.  ;Not used here
  1. ONTPOS ;PROCESS POSITIVE DATA
  1.  ;Not used here
  1. ONTNEG ;PROCESS NEGATIVE DATA
  1.  ;Not used here
  1. ONTTSTN S %M=$E(%M,2,256),%S=$P(X,"(",2),%S=$P(%S,")",1) I (%S="")!(%S=%M) S %I=1 Q
  1. ONTTSTL S %X=$P(%S,",",1),%Y=$P(%M,",",1) I +%X'=%X G ONTSTR
  1.  I %Y="" S %I=2 Q
  1.  I +%Y'=%Y S %I=3 Q
  1.  I %X>%Y S %I=2 Q
  1.  I %X<%Y S %I=3 Q
  1. ONTTSTC S %S=$P(%S,",",2,256) I %S="" S %I=1 Q
  1.  S %M=$P(%M,",",2,256) I %M="" S %I=2 Q
  1.  G ONTTSTL
  1. ONTSTR I +%Y=%Y S %I=2 Q
  1.  I %X]%Y S %I=2 Q
  1.  I %X'=%Y S %I=3 Q
  1.  G ONTTSTC
  1. ONTSTBIG ;Check for big strings
  1.  S %ZTBKEND=0
  1.  F %A=%O:1 S %E=$V(%A*2-1,-6) Q:%E=""  D  Q:%ZTBKEND
  1.  . S %ZTBKCY=$V(%A*2-1,-5)
  1.  . S %ZTBKCY1=$QL($NA(@%ZTBKCY))
  1.  . S %ZTBKCX=$NA(@("^"_X))
  1.  . S %ZTBKCX1=$QL($NA(@%ZTBKCX))
  1.  . I %ZTBKCX1>%ZTBKCY1 S %ZTBKEND=1 Q
  1.  . I $NA(@%ZTBKCX)'=$NA(@%ZTBKCY,%ZTBKCX1) S %ZTBKEND=1 Q
  1.  . S %ZTBKCY=$V(%A*2,-6)
  1.  . I $A(%ZTBKCY)'=5,($A(%ZTBKCY)'=$CASE(%ZTBKBDB,0:9,:7)),($A(%ZTBKCY)'=3) Q
  1.  . S %ZTBKCX=$P(%ZTBKCY,",",2),%ZTBKCX1=$P(%ZTBKCY,",",3)
  1.  . S %T=%T+(%ZTBKCX-1)+''%ZTBKCX1
  1.  . Q
  1.  Q
  1. ASKDIR ;Ask directory/data set name
  1.  N %A,%I,DEND,DIRNAM,GD
  1.  I $G(%ZTBKVER)']"" S %ZTBKVER=$P($$VERSION^%ZOSV,".",1,2)
  1.  I %ZTBKVER="5.0"!(%ZTBKVER'<5.2) D ASK I 1
  1.  E  W !,"An error has just occurred!" Q
  1.  I $G(DUOUT)=1 Q
  1.  I $G(DIRNAM)']"" S DUOUT=1 Q
  1.  S ^XUTL($J,"ZTBKCDIR")=DIRNAM
  1.  Q
  1. ASK ; Enter here to select default directory
  1.  N %ZTBKERR,%ZTBKEC S %ZTBKERR=0
  1.  I $$ONAPPSVR D  Q
  1.  . S DUOUT=1
  1.  . W !,"Note:  You are attempting to run this utility"
  1.  . W !,?7,"on a Cache' ECP Application Server."
  1.  . W !,?7,"This utility will not run on an ECP Application Server."
  1.  . W !,?7,"Please try running this utility again on an ECP Data Server."
  1.  D
  1.  . N $ETRAP,$ESTACK S $ETRAP="D ERROR^%ZTBKC1"
  1.  . D RDCHK
  1.  I %ZTBKERR=1 D ASKBYAPI Q
  1.  I %ZTBKERR=2 D  Q
  1.  . S DUOUT=1
  1.  . W !,"The following error just occurred:"
  1.  . W !,%ZTBKEC
  1.  S DIRNAM=$ZU(12,"")
  1.  K DIR S DIR(0)="Y",DIR("B")="YES"
  1.  S DIR("A")="Use default directory"
  1.  S DIR("A",1)="Default directory is "_DIRNAM
  1.  S DIR("?")="^D HELP^%ZTBKC1"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!$D(DIRUT)
  1.  I 'Y D ASK2
  1.  Q
  1. ASK2 ; Enter here to select directory from a list
  1.  N MGDIR,ZTBKCDIR
  1.  K DIR S DIR("A",1)="Select a number from the following:"
  1.  S %U="",MGDIR="%SYS" F %I=1:1 S %U=$O(^|MGDIR|SYS("UCI",%U)) Q:%U=""  D
  1.  .  S DIR("A",%I+1)="   "_$J(%I,3)_"      "_%U
  1.  .  S ZTBKCDIR(%I)=%U
  1.  .  I %U=DIRNAM S DIR("B")=%I
  1.  S DIR("A")="Enter a number "
  1.  S DIR(0)="N^"_"1:"_(%I-1)
  1.  W ! D ^DIR
  1.  Q:$D(DTOUT)!$D(DIRUT)
  1.  S DIRNAM=ZTBKCDIR(Y)
  1.  Q
  1. RDCHK ; Check to see if ^SYS global is readable with current privs.
  1.  N %U,MGDIR
  1.  S %U="",MGDIR="%SYS"
  1.  S %U=$O(^|MGDIR|SYS("UCI",%U))
  1.  Q
  1. ONAPPSVR() ;Check to see if this utility is run from an ECP Application Server
  1.  Q ($ZU(12,"")="")
  1.  ;
  1. ASKBYAPI ;
  1.  W !,"Note:  You do not have adequate privileges to view the ^SYS global."
  1.  W !,?7,"Therefore, a directory listing will not be available"
  1.  W !,?7,"at the directory prompt."
  1.  W !!,?7,"Also, Cache's API will be used to prompt for directory.",!!
  1.  I $G(%ZTBKVER)']"" S %ZTBKVER=$P($$VERSION^%ZOSV,".",1,2)
  1.  I %ZTBKVER="5.0" D ASK^%FILE I 1
  1.  E  I %ZTBKVER'<5.2 D ASK^%SYS.FILE I 1
  1.  E  W !,"An error has just occurred!" Q
  1.  Q
  1. HELP ;Single question mark help for 'Use default directory' prompt
  1.  W !,"Enter either 'Y' or 'N'."
  1.  W !!,"If you enter 'N' for 'NO', you may then select a directory from a list."
  1.  W !,"Block count on globals will only be returned for globals that reside"
  1.  W !,"in the selected directory."
  1.  Q
  1. ERROR ; Error trap for disconnect error and return back to the read loop.
  1.  S $ETRAP="D UNWIND^%ZTER"
  1.  S %ZTBKEC=$$EC^%ZOSV
  1.  I %ZTBKEC["PROTECT" S %ZTBKERR=1 D UNWIND^%ZTER Q
  1.  S %ZTBKERR=2 D ^%ZTER
  1.  D UNWIND^%ZTER
  1.  Q
  1. %Z3 N X S PG=PG+1,ST=0 D:(PG>1)&%ZTBIOC2&%ZTBIOC %Z5 Q:ST
  1.  U IO W:((9+$Y'<IOSL)&($Y>3))!(PG>1) @IOF
  1.  S %SK=$X W ?(%SK+25),"Global Block Count  ",$S(PG>1:"(cont.)",1:""),?(%SK+60),"Page ",PG
  1.  W !,$G(^XUTL($J,"ZTBKCDIR")),"  " S %SK=$X+1 W "Globals",?(%SK+12),"Data Blocks"
  1.  W ?(%SK+34),%ZTBKCDT W !
  1.  Q
  1. %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
  1.  Q
  1. 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[".")
  1.  Q
  1. ALL ;Entry point for block count of all globals.
  1. ALLONT ;Directory at ^UTILITY("GLO")
  1.  K ^UTILITY("%ZTBKC",$J)
  1.  O 63::0 E  S %T="The VIEW device is busy." G EXIT
  1.  S %G=$G(^XUTL($J,"ZTBKCDIR"))
  1.  I %G="" D
  1.  .S %G=$ZU(12,"")
  1.  .S ^XUTL($J,"ZTBKCDIR")=%G
  1.  S %B=$ZU(49,%G),%B=$P(%B,",",7) G EXIT:'%B
  1.  O 63:"^^"_%G
  1.  N ST,PG
  1.  S %ZTBIOC=(IO=IO(0)),%ZTBIOC2=$E(IOST,1,2)["C-"
  1.  U IO W:%ZTBIOC2 @IOF I '%ZTBIOC,'$D(ZTQUEUED) U IO(0) W !!,"Printing report..."
  1.  S %ZTBKCZY=IOSL-(255\IOM+1) K %D,%T,%TIM
  1. AONTVUE V %B S %ZTBKCG=""
  1.  S %ZTBKSIZ=$P($ZU(49,%G),",",2)
  1.  S %ZTBKBIG=$CASE(%ZTBKSIZ,2048:0,:1)
  1.  S %ZTBKCL=$CASE(%ZTBKBIG,0:$V(2040,0,"3O"),:$V($ZUTIL(40,32,4),0,4))
  1.  S %E=$CASE(%ZTBKBIG,0:$V(2046,0,2),:$V($ZU(40,32,0),0,4)+$ZU(40,32,10))
  1.  I %E>%ZTBKSIZ G EXIT
  1.  S %O=$CASE(%ZTBKBIG,0:0,:$ZU(40,32,10))
  1. AONTNXT G AONTPTR:%E'>%O
  1.  S %ZTBKA=%O,%ZTBKRAW=$V(%ZTBKA,0,4),%ZTBKINF=$ZU(167,0,0,%ZTBKRAW)
  1.  S %ZTBKA=%ZTBKA+4
  1.  S %ZTBKCCC=$P(%ZTBKINF,"^",3),%ZTBKLEN=$P(%ZTBKINF,"^",4)
  1.  S %ZTBKPAD=$P(%ZTBKINF,"^",5),%ZTBKSUB=$P(%ZTBKINF,"^",2)
  1.  S %ZTBKCG="" I %ZTBKCCC S %ZTBKCG=$E(%ZTBKPRV,1,%ZTBKCCC)
  1.  S %ZTBKCE=%ZTBKA+%ZTBKSUB-1,%O=%ZTBKA
  1. AONTLOP S %Z=$V(%O,0),%O=%O+1 S:%Z %ZTBKCG=%ZTBKCG_$C(%Z) G AONTLOP:(%O'>%ZTBKCE)
  1.  S ^UTILITY("%ZTBKC",$J,%ZTBKCG)=""
  1.  S %ZTBKPRV=%ZTBKCG,%O=%ZTBKCE+%ZTBKLEN-%ZTBKSUB-3,%ZTBKCG="" G AONTNXT
  1. AONTPTR S %B=%ZTBKCL I %B G AONTVUE
  1.  D NOW^%DTC S Y=% D DD S %ZTBKCDT=Y
  1.  S PG=0 D %Z3
  1.  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
  1.  W !!?%SK,"Total",?(%SK+15),%TOT K %GLO,%II,%SK,%T,%TOT,%ZTBIOC,%ZTBIOC2,%ZTBKCDT,%ZTBKCZY,X,Y U IO(0) D ^%ZISC
  1. 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
  1.  K %ZTBKA,%ZTBKBDB,%ZTBKBIG,%ZTBKCCC,%ZTBKCE,%ZTBKCG,%ZTBKCL,%ZTBKCX,%ZTBKCX1,%ZTBKCY,%ZTBKCY1,%ZTBKEND,%ZTBKGLO,%ZTBKINF,%ZTBKLEN,%ZTBKPAD,%ZTBKPRV,%ZTBKRAW,%ZTBKSIZ,%ZTBKSUB,%ZTBKTOP,%ZTBKVER