XTVSRFL ;BHAM/MAM/GTS - VistA Package Sizing Manager;
;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;;
INIT(VALMCNT,XTVPSPRM) ;;VistA Size Report entry point
;;INPUT:
; VALMCNT - Current Node # on ListMan ^TMP("XTVS PKG MGR RPT",$JOB) global
; XTVPSPRM - Package Parameter file to report against
;
;; data variables (local, for each package)
;; PKGIEN = Package IEN
;; PKGNAME = Package NAME (.01 - $P(^(0),"^",1))
;; PKGPFX = Package PREFIX / NAMESPACE (1 - $P(^(0),"^",2))
;;
;; RTOT = total ROUTINEs
;; TLCNT = total SIZE of all ROUTINES
;; FTOT = total FILEs
;; FLDTOT = total FIELDs of all FILES
;; OTOT = total OPTIONs (^DIC(19,)
;; PTOT = total PROTOCOLs (^ORD(101,)
;; RPTOT = total REMOTE PROCEDUREs (^XWB(8994,)
;; TPLTTOT = total Fileman Templates
;;
I $G(DUZ)="" W !!,"DUZ must be defined." Q
;
N X,Y,EXTDIR,DISSORT
;
ALL ; Select All or Single report
W !!,"VistA Package Sizing Report",!
S EXTDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I") ;EXTDIR = Directory storing XTMPSIZE.DAT
N DIR S DIR(0)="YA",DIR("B")="NO"
S DIR("A")="Do you want to display Sizing Information for ALL VistA Packages? "
S DIR("?",1)="A Size report for ALL VistA Packages requires the..."
S DIR("?",2)=" "_XTVPSPRM
S DIR("?",3)=" ...file to be stored in "_EXTDIR_"."
S DIR("?",4)=""
S DIR("?",5)=" "_XTVPSPRM
S DIR("?",6)=" is sourced from Package file data in Forum or other VistA instance."
S DIR("?",7)=" The report will count package components on local VistA based on the"
S DIR("?",8)=" parameters defined in the Package Parameter file for the package."
S DIR("?",9)=""
S DIR("?")="Enter Yes to report All packages; No to report a Single package."
D ^DIR I Y'=1,Y'=0 G KWIT
IF Y'=1 GOTO ONEPKG
;
SORT ; Select Sort for All report
N DIR S DIR("A")="Select VistA Size Report"
S DIR(0)="S^1:SORT ON PKG NAMES;2:SORT ON # OF ROUTINES - HIGH TO LOW;"
S DIR(0)=DIR(0)_"3:SORT ON PKG ROUTINES SIZE TOTAL - HIGH TO LOW;"
S DIR(0)=DIR(0)_"4:SORT ON PKG NAME, CARET DELIMITED DATA;"
S DIR(0)=DIR(0)_"5:SORT ON PKG NAME INCLUDE PARENT PKG, CARET DELIMITED DATA"
S DIR("L")=" 5. Delimited (^) Data with PARENT PKG, Sorted by PACKAGE NAME"
S DIR("L",1)="Select which method to display the package size data: "
S DIR("L",2)=""
S DIR("L",3)=" 1. Sorted on PACKAGE NAME"
S DIR("L",4)=" 2. Sorted on NUMBER of ROUTINES (Highest to Lowest)"
S DIR("L",5)=" 3. Sorted on TOTAL ROUTINE SIZE (Highest to Lowest)"
S DIR("L",6)=" 4. Delimited (^) Data, Sorted on PACKAGE NAME"
D ^DIR G:'Y KWIT S DISSORT=+Y
;
DO LOOP(DISSORT,.VALMCNT)
QUIT
;
LOOP(DISSORT,VALMCNT) ; Loop through all entries in the Package parameters file
NEW POPERR
SET POPERR=0
DO OPEN^%ZISH("XTMP",EXTDIR,XTVPSPRM,"R")
SET:POP POPERR=POP
QUIT:POPERR
U IO
SET LNNUM=0
FOR S LINEITEM="" READ LINEITEM:5 Q:$$STATUS^%ZISH DO
.IF LINEITEM]"" DO
..S LNNUM=LNNUM+1
..SET ^TMP("XTVS-FORUMPKG",$J,LNNUM)=LINEITEM
D CLOSE^%ZISH("XTMP")
;
DO KIDSIDX^XTVSRFL1 ;Create Prefix-Package Indicies from KIDS
;
;Create Prefix Indicies
DO TALLYRPT(DISSORT,0)
;
;Check existence of Packages
DO PKGFLCK
;
DISALL ; Set report into display array
; display option 4 & 5 have no formatting, and are used for creating spreadsheets,
; for which the following heading lines are not needed
I (DISSORT'=4)&(DISSORT'=5) D ;
. DO ADD^XTVSLAPI(.VALMCNT,"VistA Application Sizing Information Sort Type: "_DISSORT)
. DO ADD^XTVSLAPI(.VALMCNT," ")
. DO ADD^XTVSLAPI(.VALMCNT," Total")
. DO ADD^XTVSLAPI(.VALMCNT,"Application Rtn")
. DO ADD^XTVSLAPI(.VALMCNT,"(Namespace) Routines Size Files Fields Options Protocols RPCs Templates")
. DO ADD^XTVSLAPI(.VALMCNT,"================================================================================")
;
DAD ; Add report lines to display array
NEW S3
I DISSORT=2!(DISSORT=3) DO
. S S3=""
. F S S3=$O(^TMP("XTVS-VPS0",$J,S3),-1) S D3=S3 Q:S3="" S D1="" F S D1=$O(^TMP("XTVS-VPS0",$J,S3,D1)) Q:D1="" S D2="" F S D2=$O(^TMP("XTVS-VPS0",$J,S3,D1,D2)) Q:D2="" D PDAD(DISSORT,$G(^(D2)),D1,D2,D3,.VALMCNT)
I DISSORT=1!(DISSORT=4)!(DISSORT=5) DO
. SET D1=""
. ;
. IF DISSORT'=5 DO
.. IF DISSORT=4 DO
... DO ADD^XTVSLAPI(.VALMCNT,"{package name}^{prefix}^{#rtns}^{size of rtns}^{#files}^{#fields}^{#options}^{#protocols}^{#RPCs}^{#templates}")
.. FOR S D1=$O(^TMP("XTVS-VPS",$J,D1)) Q:D1="" S D2="" DO
... F S D2=$O(^TMP("XTVS-VPS",$J,D1,D2)) Q:D2="" DO
.... D PDAD(DISSORT,$G(^(D2)),D1,D2,"",.VALMCNT)
. ;
. IF DISSORT=5 DO
.. DO ADD^XTVSLAPI(.VALMCNT,"{package name}^{prefix}^{#rtns}^{size of rtns}^{#files}^{#fields}^{#options}^{#protocols}^{#RPCs}^{#templates}^{parent pkg}")
.. S TMPSUB=""
.. F S TMPSUB=$O(^TMP("XTVS-VPS",$J,TMPSUB)) Q:TMPSUB="" S D1="" DO
... F S D1=$O(^TMP("XTVS-VPS",$J,TMPSUB,D1)) Q:D1="" S D2="" DO
.... F S D2=$O(^TMP("XTVS-VPS",$J,TMPSUB,D1,D2)) Q:D2="" DO
..... D PDAD(DISSORT,$G(^(D2)),D1,D2,"",.VALMCNT)
;
KILL ^TMP("XTVS-VPS",$J),^TMP("XTVS-PREFIX-IDX",$J),^TMP("XTVS-FORUM-PFXS",$J)
KILL ^TMP("XTVS-VPS0",$J),^TMP("XTVS-KIDSPFX-IDX",$J),^TMP("XTVS-FORUM2TMP",$J)
KILL ^TMP("XTVS-FORUMPKG",$J),^TMP("XTVS-IDX-PKG",$J)
;
KWIT ; QUIT Report
QUIT
;
PDAD(DISSORT,DATA,D1,D2,D3,VALMCNT) ; print actual data (finally)
N D4,D5,D6,D7,D8,D9,D10,DATANDE,SPCT
I (DISSORT=1)!(DISSORT=4)!(DISSORT=5) DO
. S D4=$P(DATA,"^",2),D5=$P(DATA,"^",3),D6=$P(DATA,"^",4),D7=$P(DATA,"^",5),D8=$P(DATA,"^",6),D9=$P(DATA,"^",7),D10=$P(DATA,"^",8),D3=+DATA
;
;Following code only executes when a caret (^) delimited report is selected
I (DISSORT=4)!(DISSORT=5) DO QUIT ;;Quit reporting sort types 4 & 5
. SET DATANDE=""
. SET DATANDE=D1_"^"_D2_"^"_D3_"^"_D4_"^"_D5_"^"_D6_"^"_D7_"^"_D8_"^"_D9_"^"_D10_$S($P(DATA,"^",9)'="":"^"_$P(DATA,"^",9),1:"")_$S($P(DATA,"^",10)'="":"^"_$P(DATA,"^",10),1:"")
. DO ADD^XTVSLAPI(.VALMCNT,DATANDE)
;
;Following code only executes when user readable report selected (sort types 1, 2, or 3)
I DISSORT=2!(DISSORT=3) DO
. S D5=$P(DATA,"^",2),D6=$P(DATA,"^",3),D7=$P(DATA,"^",4),D8=$P(DATA,"^",5),D9=$P(DATA,"^",6),D10=$P(DATA,"^",7)
. S:DISSORT=2 D4=+DATA
. S:DISSORT=3 D4=D3,D3=+DATA
;
DO ADD^XTVSLAPI(.VALMCNT,D1)
SET DATANDE=""
SET DATANDE="("_D2_")"
FOR SPCT=1:1:11-$L(DATANDE) SET DATANDE=DATANDE_" " ;Space out 2nd data element
SET DATANDE=DATANDE_$J(D3,6)_" "_$J(D4,9)_" "_$J(D5,4)_" "_$J(D6,6)_" "_$J(D7,6)_" "_$J(D8,6)_" "_$J(D9,6)_" "_$J(D10,6)
DO ADD^XTVSLAPI(.VALMCNT,DATANDE)
DO ADD^XTVSLAPI(.VALMCNT,"--------------------------------------------------------------------------------")
QUIT
;
TALLYRPT(DISSORT,XTVSSILN,SELPKGNM) ; Compile component totals
; INPUT:
; DISSORT -
; 1: Sorted on PACKAGE NAME [Default]
; 2: Sorted on NUMBER of ROUTINES (Highest to Lowest)
; 3: Sorted on TOTAL ROUTINE SIZE (Highest to Lowest)
; 4: Delimited (^) Data, Sorted on PACKAGE NAME
; 5: Delimited (^) Data with PARENT PKG, Sorted by PACKAGE NAME
;
; XTVSSILN - Silent mode
; 0: Show HangChar
; 1: Silent [Default]
;
; SELPKGNM - Selected package name
; Define when called from ONEPKGSZ^XTVSSVR to only check & send message
; when selected package is missing
;
; Requires the following TMP globals are defined before execution:
; ^TMP("XTVS-FORUMPKG",$J)
; ^TMP("XTVS-KIDSPFX-IDX",$J)
;
;Create Prefix Indicies
;
IF $GET(DISSORT)="" SET DISSORT=1
IF $GET(XTVSSILN)'=0 SET XTVSSILN=1
;
NEW D1,D2,D3,XTCHAR,TMPSUB,PCENUM,LINEITEM,PKGNAME,PKGPFX,LINECNT
NEW PREFIX,PKGIEN,FFCTRSLT
SET (D1,D2,D3)=0
;
; Create ^TMP("XTVS-IDX-PKG",$J) array for MULTX^XTVSRFL1
SET TMPSUB=0
FOR SET TMPSUB=$O(^TMP("XTVS-FORUMPKG",$J,TMPSUB)) QUIT:TMPSUB="" DO
.SET LINEITEM=^TMP("XTVS-FORUMPKG",$J,TMPSUB)
.SET PKGNAME=$P(LINEITEM,"^")
.SET PKGPFX=$P(LINEITEM,"^",2)
.SET ^TMP("XTVS-PREFIX-IDX",$J,PKGPFX,PKGNAME)="" ;Prefix,Pkg-Name
.SET ^TMP("XTVS-FORUM-PFXS",$J,PKGPFX)="" ;Prefix
.; Following ^TMP for PACKAGES in Param file: Prefix,Pkg-Name = 1 when KIDS Prefix, Null when not KIDS Prefix
.IF '$D(^TMP("XTVS-KIDSPFX-IDX",$J,PKGPFX)) SET ^TMP("XTVS-IDX-PKG",$J,PKGPFX,PKGNAME)=""
.IF $D(^TMP("XTVS-KIDSPFX-IDX",$J,PKGPFX)) SET ^TMP("XTVS-IDX-PKG",$J,PKGPFX,PKGNAME)=$S(^TMP("XTVS-KIDSPFX-IDX",$J,PKGPFX)=PKGNAME:1,1:"")
.;
.SET ADDPRFX=$P(LINEITEM,"^",5)
.SET LPCNT=0
.FOR PCENUM=1:1 SET PREFIX=$P(ADDPRFX,"|",PCENUM) Q:PREFIX="" DO
.. SET ^TMP("XTVS-FORUM-PFXS",$J,PREFIX)="" ;Prefix
.. ; Following ^TMP for PACKAGES in Param file : Prefix,Pkg-Name = 1 when KIDS Prefix, Null when not KIDS Prefix
.. SET ^TMP("XTVS-IDX-PKG",$J,PREFIX,PKGNAME)=$S($D(^TMP("XTVS-KIDSPFX-IDX",$J,PREFIX)):1,1:"")
;
;Count components - ^TMP Global loop
WRITE:'XTVSSILN !,"Compiling component totals for selected Package data file... "
SET (TMPSUB,XTCHAR)=0
FOR SET TMPSUB=$O(^TMP("XTVS-FORUMPKG",$J,TMPSUB)) QUIT:TMPSUB="" DO:'XTVSSILN HANGCHAR^XTVSLAPI(.XTCHAR) DO
.SET PKGIEN=0
.SET LINEITEM=^TMP("XTVS-FORUMPKG",$J,TMPSUB)
.SET PKGNAME=$P(LINEITEM,"^")
.;
.IF PKGNAME["''" DO
.. IF $D(^DIC(9.4,"B",$REPLACE(PKGNAME,"''",""""))) SET PKGIEN=$O(^DIC(9.4,"B",$REPLACE(PKGNAME,"''",""""),""))
.. IF '$D(^DIC(9.4,"B",$REPLACE(PKGNAME,"''",""""))),$D(^DIC(9.4,"B",PKGNAME)) SET PKGIEN=$O(^DIC(9.4,"B",PKGNAME,""))
.IF PKGNAME'["''" SET PKGIEN=+$O(^DIC(9.4,"B",PKGNAME,""))
.;
.IF (PKGIEN=0),(PKGNAME=$P($G(SELPKGNM),"^",1)) DO RMTPKGMG^XTVSLAPI("Package: "_PKGNAME_" ...not found! Protocol count may be incorrect.",$S($G(XTVSSNDR)]"":XTVSSNDR,1:$$NETNAME^XMXUTIL(DUZ)),PKGNAME) ;p152 v2 ba
.DO COMPNTCT(PKGNAME,PKGIEN,LINEITEM,DISSORT)
;
I DISSORT=2 S D1="" F S D1=$O(^TMP("XTVS-VPS",$J,D1)) Q:D1="" S D2="" F S D2=$O(^TMP("XTVS-VPS",$J,D1,D2)) Q:D2="" S X=$G(^(D2)),^TMP("XTVS-VPS0",$J,+X,D1,D2)=$P(X,"^",2,8)
I DISSORT=3 S D1="" F S D1=$O(^TMP("XTVS-VPS",$J,D1)) Q:D1="" S D2="" F S D2=$O(^TMP("XTVS-VPS",$J,D1,D2)) Q:D2="" S X=$G(^(D2)),^TMP("XTVS-VPS0",$J,+$P(X,"^",2),D1,D2)=+X_"^"_$P(X,"^",3,8)
;
QUIT
;
COMPNTCT(PKGNAME,PKGIEN,LINEITEM,DISSORT) ;Count components for package
;Input:
; PKGNAME - Package Name
; PKGIEN - Package File IEN for Package
; LINEITEM - Package Parameters from Parameter file
; DISSORT - Report Type (Sort) selected
;
NEW APFXLST,RPFXLST,PCENUM,PKGPFX,LPA,APFX,RPFX,ADDPRFX,PRNTPKG
NEW FTOT,OTOT,PTOT,RPTOT,RTOT,TLCNT,TPLTTOT,FLDTOT
;
SET PKGPFX=$P(LINEITEM,"^",2)
;
SET (FTOT,FLDTOT,OTOT,PTOT,RPTOT,RTOT,TLCNT,TPLTTOT)=0
;Count files & fields - entry in ^TMP global loop
SET FFCTRSLT=$$COUNTFLS^XTVSRFL1(PKGPFX,$P(LINEITEM,"^",3),$P(LINEITEM,"^",4),$P(LINEITEM,"^",7),$P(LINEITEM,"^",8)) ; Files^Fields
SET FTOT=$P(FFCTRSLT,"^") ;Extract File ctr
SET FLDTOT=$P(FFCTRSLT,"^",2) ;Extract Field ctr
;
;Define Excepted & Additional Prefix Arrays
KILL RDP,ADP
SET RPFXLST=$P(LINEITEM,"^",6)
SET (RDP,PCENUM)=0
FOR SET PCENUM=PCENUM+1 SET RPFX=($P(RPFXLST,"|",PCENUM)) QUIT:RPFX']"" DO
. SET RDP=RDP+1,RDP(RDP)=RPFX ;RDP = Excepted Namespace
;
SET APFXLST=$P(LINEITEM,"^",5)
SET (ADP,PCENUM)=0
; NOTE: MULTX screens a Primary or KIDS Prefix for another package from inclusion as an added prefix to current package
FOR SET PCENUM=PCENUM+1 SET APFX=($P(APFXLST,"|",PCENUM)) QUIT:APFX="" IF $$MULTX^XTVSRFL1(APFX,PKGNAME) SET ADP=ADP+1 SET ADP(ADP)=APFX ;ADP = Added Namespace
;
SET RTOT=$$ROUTINE^XTVSRFL1(PKGPFX,.TLCNT,.RDP,.ADP) ;Count routines
I ADP F LPA=1:1:ADP I ADP(LPA)'="" S RTOT=RTOT+$$ROUTINE^XTVSRFL1(ADP(LPA),.TLCNT,.RDP,.ADP) ;ADP(LPA) added prefixes called individually
;
DO CNTR^XTVSRFL1("^DIC(19,",.OTOT,PKGPFX,.RDP,.ADP) ;Count Options
I ADP F LPA=1:1:ADP I ADP(LPA)'="" D CNTR^XTVSRFL1("^DIC(19,",.OTOT,ADP(LPA),.RDP,.ADP)
;
SET PTOT=$$PROTOCOL^XTVSRFL1(PKGPFX,PKGIEN,.RDP) ;Count Protocols
I ADP F LPA=1:1:ADP I ADP(LPA)'="" SET PTOT=PTOT+$$PROTOCOL^XTVSRFL1(ADP(LPA),PKGIEN,.RDP)
;
DO CNTR^XTVSRFL1("^XWB(8994,",.RPTOT,PKGPFX,.RDP,.ADP) ;Count Remote Procedure Calls
I ADP F LPA=1:1:ADP I ADP(LPA)'="" D CNTR^XTVSRFL1("^XWB(8994,",.RPTOT,ADP(LPA),.RDP,.ADP)
;
; Count Templates
DO CNTR^XTVSRFL1("^DIPT(",.TPLTTOT,PKGPFX,.RDP,.ADP) ;Print Templates
I ADP F LPA=1:1:ADP I ADP(LPA)'="" D CNTR^XTVSRFL1("^DIPT(",.TPLTTOT,ADP(LPA),.RDP,.ADP)
;
DO CNTR^XTVSRFL1("^DIBT(",.TPLTTOT,PKGPFX,.RDP,.ADP) ;Sort Templates
I ADP F LPA=1:1:ADP I ADP(LPA)'="" D CNTR^XTVSRFL1("^DIBT(",.TPLTTOT,ADP(LPA),.RDP,.ADP)
;
DO CNTR^XTVSRFL1("^DIE(",.TPLTTOT,PKGPFX,.RDP,.ADP) ;Input Templates
I ADP F LPA=1:1:ADP I ADP(LPA)'="" D CNTR^XTVSRFL1("^DIE(",.TPLTTOT,ADP(LPA),.RDP,.ADP)
;
SET:DISSORT'=5 ^TMP("XTVS-VPS",$J,PKGNAME,PKGPFX)=RTOT_"^"_TLCNT_"^"_FTOT_"^"_FLDTOT_"^"_OTOT_"^"_PTOT_"^"_RPTOT_"^"_TPLTTOT
IF DISSORT=5 DO
.SET PRNTPKG=$P(LINEITEM,"^",9)
.SET ^TMP("XTVS-VPS",$J,TMPSUB,PKGNAME,PKGPFX)=RTOT_"^"_TLCNT_"^"_FTOT_"^"_FLDTOT_"^"_OTOT_"^"_PTOT_"^"_RPTOT_"^"_TPLTTOT_$S(PRNTPKG'=""&PRNTPKG'=PKGNAME:"^"_PRNTPKG,1:"")_$S($P(LINEITEM,"^",10)'="":"^"_$P(LINEITEM,"^",10),1:"")
;
KILL ADP,RDP
;
QUIT
;
PKGFLCK ; Check for Package File entries matching Parameter names, send report message
;Requires the ^TMP("XTVS-FORUMPKG",$J) global
;
NEW TMPSUB,PKGIEN,PKGNAME,MSGNDENM
KILL ^TMP("XTVS-LOCAL-ERROR",$JOB)
SET (MSGNDENM,TMPSUB)=0
FOR SET TMPSUB=$O(^TMP("XTVS-FORUMPKG",$J,TMPSUB)) QUIT:TMPSUB="" DO
. SET PKGIEN=0
. SET PKGNAME=$P(^TMP("XTVS-FORUMPKG",$J,TMPSUB),"^")
. ;
. IF PKGNAME["''" DO
.. IF $D(^DIC(9.4,"B",$REPLACE(PKGNAME,"''",""""))) SET PKGIEN=$O(^DIC(9.4,"B",$REPLACE(PKGNAME,"''",""""),""))
.. IF '$D(^DIC(9.4,"B",$REPLACE(PKGNAME,"''",""""))),$D(^DIC(9.4,"B",PKGNAME)) SET PKGIEN=$O(^DIC(9.4,"B",PKGNAME,""))
. IF PKGNAME'["''" SET PKGIEN=+$O(^DIC(9.4,"B",PKGNAME,""))
. ;
. IF PKGIEN=0 DO
.. IF MSGNDENM=0 DO
... SET ^TMP("XTVS-LOCAL-ERROR",$JOB,1)="Package Size Report warning for "_^%ZOSF("PROD")_"."
... SET ^TMP("XTVS-LOCAL-ERROR",$JOB,2)=" The following package(s) are not found on this VistA."
... SET ^TMP("XTVS-LOCAL-ERROR",$JOB,3)=" (The number of protocols reported may be incorrect.)"
.. SET MSGNDENM=$ORDER(^TMP("XTVS-LOCAL-ERROR",$JOB,""),-1)+1
.. SET ^TMP("XTVS-LOCAL-ERROR",$JOB,MSGNDENM)=" - "_PKGNAME
;
IF $D(^TMP("XTVS-LOCAL-ERROR",$JOB)) DO
. NEW XMDUZ,XMY,XMTEXT,XMSUB
. SET XMDUZ="VistA Package Size Analysis Manager"
. SET XMY($$NETNAME^XMXUTIL(DUZ))=""
. SET XMTEXT="^TMP(""XTVS-LOCAL-ERROR"","_$JOB_","
. SET XMSUB="PACKAGE REPORT NOTICE ("_^%ZOSF("PROD")_") ; Report process warning."
. DO ^XMD
. IF +XMZ'>0 DO
.. SET ERRTEXT="'Package Report Notice' FAILED to return to "_$$NETNAME^XMXUTIL(DUZ)_"."
.. DO APPERROR^%ZTER("PKGFLCK^XTFSRFL : Package extract error")
;
KILL ^TMP("XTVS-LOCAL-ERROR",$JOB)
QUIT
;
ONEPKG ; Select a package to report
NEW PKGNAME,LINEITEM
KILL ^TMP("XTVS-PARAM-CAP",$J),^TMP("XTVS-PREFIX-IDX",$J),^TMP("XTVS-FORUM-PFXS",$J),^TMP("XTVS-IDX-PKG",$J)
DO OPEN^%ZISH("XTMP",EXTDIR,XTVPSPRM,"R")
U IO
SET VALMCNT=0
FOR S LINEITEM="" READ LINEITEM:5 Q:$$STATUS^%ZISH DO
. IF LINEITEM]"" DO SCAPARY^XTVSLP(LINEITEM) ;Creates ^TMP("XTVS-PARAM-CAP",$J) array
DO CLOSE^%ZISH("XTMP")
;
DO KIDSIDX^XTVSRFL1 ;Create Prefix-Package Indicies from KIDS [^TMP("XTVS-KIDSPFX-IDX")]
;
SET PKGNAME=$$SELPKG^XTVSLPDC(0) ; Select the package to report
;
IF PKGNAME=0 W !!,"VistA Package Not Selected!"
IF PKGNAME'=0 DO
. DO PARAMIDX^XTVSRFL1 ;Create Prefix Indicies
. ;
. DO ONERPT^XTVSRFL1(PKGNAME,.VALMCNT) ;Report stat's for a single package
;
KILL ^TMP("XTVS-PREFIX-IDX",$J),^TMP("XTVS-FORUM-PFXS",$J),^TMP("XTVS-KIDSPFX-IDX",$J)
KILL ^TMP("XTVS-PARAM-CAP",$J),^TMP("XTVS-IDX-PKG",$J)
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSRFL 16088 printed Dec 13, 2024@02:42:20 Page 2
XTVSRFL ;BHAM/MAM/GTS - VistA Package Sizing Manager;
+1 ;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;
INIT(VALMCNT,XTVPSPRM) ;;VistA Size Report entry point
+1 ;;INPUT:
+2 ; VALMCNT - Current Node # on ListMan ^TMP("XTVS PKG MGR RPT",$JOB) global
+3 ; XTVPSPRM - Package Parameter file to report against
+4 ;
+5 ;; data variables (local, for each package)
+6 ;; PKGIEN = Package IEN
+7 ;; PKGNAME = Package NAME (.01 - $P(^(0),"^",1))
+8 ;; PKGPFX = Package PREFIX / NAMESPACE (1 - $P(^(0),"^",2))
+9 ;;
+10 ;; RTOT = total ROUTINEs
+11 ;; TLCNT = total SIZE of all ROUTINES
+12 ;; FTOT = total FILEs
+13 ;; FLDTOT = total FIELDs of all FILES
+14 ;; OTOT = total OPTIONs (^DIC(19,)
+15 ;; PTOT = total PROTOCOLs (^ORD(101,)
+16 ;; RPTOT = total REMOTE PROCEDUREs (^XWB(8994,)
+17 ;; TPLTTOT = total Fileman Templates
+18 ;;
+19 IF $GET(DUZ)=""
WRITE !!,"DUZ must be defined."
QUIT
+20 ;
+21 NEW X,Y,EXTDIR,DISSORT
+22 ;
ALL ; Select All or Single report
+1 WRITE !!,"VistA Package Sizing Report",!
+2 ;EXTDIR = Directory storing XTMPSIZE.DAT
SET EXTDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+3 NEW DIR
SET DIR(0)="YA"
SET DIR("B")="NO"
+4 SET DIR("A")="Do you want to display Sizing Information for ALL VistA Packages? "
+5 SET DIR("?",1)="A Size report for ALL VistA Packages requires the..."
+6 SET DIR("?",2)=" "_XTVPSPRM
+7 SET DIR("?",3)=" ...file to be stored in "_EXTDIR_"."
+8 SET DIR("?",4)=""
+9 SET DIR("?",5)=" "_XTVPSPRM
+10 SET DIR("?",6)=" is sourced from Package file data in Forum or other VistA instance."
+11 SET DIR("?",7)=" The report will count package components on local VistA based on the"
+12 SET DIR("?",8)=" parameters defined in the Package Parameter file for the package."
+13 SET DIR("?",9)=""
+14 SET DIR("?")="Enter Yes to report All packages; No to report a Single package."
+15 DO ^DIR
IF Y'=1
IF Y'=0
GOTO KWIT
+16 IF Y'=1
GOTO ONEPKG
+17 ;
SORT ; Select Sort for All report
+1 NEW DIR
SET DIR("A")="Select VistA Size Report"
+2 SET DIR(0)="S^1:SORT ON PKG NAMES;2:SORT ON # OF ROUTINES - HIGH TO LOW;"
+3 SET DIR(0)=DIR(0)_"3:SORT ON PKG ROUTINES SIZE TOTAL - HIGH TO LOW;"
+4 SET DIR(0)=DIR(0)_"4:SORT ON PKG NAME, CARET DELIMITED DATA;"
+5 SET DIR(0)=DIR(0)_"5:SORT ON PKG NAME INCLUDE PARENT PKG, CARET DELIMITED DATA"
+6 SET DIR("L")=" 5. Delimited (^) Data with PARENT PKG, Sorted by PACKAGE NAME"
+7 SET DIR("L",1)="Select which method to display the package size data: "
+8 SET DIR("L",2)=""
+9 SET DIR("L",3)=" 1. Sorted on PACKAGE NAME"
+10 SET DIR("L",4)=" 2. Sorted on NUMBER of ROUTINES (Highest to Lowest)"
+11 SET DIR("L",5)=" 3. Sorted on TOTAL ROUTINE SIZE (Highest to Lowest)"
+12 SET DIR("L",6)=" 4. Delimited (^) Data, Sorted on PACKAGE NAME"
+13 DO ^DIR
if 'Y
GOTO KWIT
SET DISSORT=+Y
+14 ;
+15 DO LOOP(DISSORT,.VALMCNT)
+16 QUIT
+17 ;
LOOP(DISSORT,VALMCNT) ; Loop through all entries in the Package parameters file
+1 NEW POPERR
+2 SET POPERR=0
+3 DO OPEN^%ZISH("XTMP",EXTDIR,XTVPSPRM,"R")
+4 if POP
SET POPERR=POP
+5 if POPERR
QUIT
+6 USE IO
+7 SET LNNUM=0
+8 FOR
SET LINEITEM=""
READ LINEITEM:5
if $$STATUS^%ZISH
QUIT
Begin DoDot:1
+9 IF LINEITEM]""
Begin DoDot:2
+10 SET LNNUM=LNNUM+1
+11 SET ^TMP("XTVS-FORUMPKG",$JOB,LNNUM)=LINEITEM
End DoDot:2
End DoDot:1
+12 DO CLOSE^%ZISH("XTMP")
+13 ;
+14 ;Create Prefix-Package Indicies from KIDS
DO KIDSIDX^XTVSRFL1
+15 ;
+16 ;Create Prefix Indicies
+17 DO TALLYRPT(DISSORT,0)
+18 ;
+19 ;Check existence of Packages
+20 DO PKGFLCK
+21 ;
DISALL ; Set report into display array
+1 ; display option 4 & 5 have no formatting, and are used for creating spreadsheets,
+2 ; for which the following heading lines are not needed
+3 ;
IF (DISSORT'=4)&(DISSORT'=5)
Begin DoDot:1
+4 DO ADD^XTVSLAPI(.VALMCNT,"VistA Application Sizing Information Sort Type: "_DISSORT)
+5 DO ADD^XTVSLAPI(.VALMCNT," ")
+6 DO ADD^XTVSLAPI(.VALMCNT," Total")
+7 DO ADD^XTVSLAPI(.VALMCNT,"Application Rtn")
+8 DO ADD^XTVSLAPI(.VALMCNT,"(Namespace) Routines Size Files Fields Options Protocols RPCs Templates")
+9 DO ADD^XTVSLAPI(.VALMCNT,"================================================================================")
End DoDot:1
+10 ;
DAD ; Add report lines to display array
+1 NEW S3
+2 IF DISSORT=2!(DISSORT=3)
Begin DoDot:1
+3 SET S3=""
+4 FOR
SET S3=$ORDER(^TMP("XTVS-VPS0",$JOB,S3),-1)
SET D3=S3
if S3=""
QUIT
SET D1=""
FOR
SET D1=$ORDER(^TMP("XTVS-VPS0",$JOB,S3,D1))
if D1=""
QUIT
SET D2=""
FOR
SET D2=$ORDER(^TMP("XTVS-VPS0",$JOB,S3,D1,D2))
if D2=""
QUIT
DO PDAD(DISSORT,$GET(^(D2)),D1,D2,D3,.VALMCNT)
End DoDot:1
+5 IF DISSORT=1!(DISSORT=4)!(DISSORT=5)
Begin DoDot:1
+6 SET D1=""
+7 ;
+8 IF DISSORT'=5
Begin DoDot:2
+9 IF DISSORT=4
Begin DoDot:3
+10 DO ADD^XTVSLAPI(.VALMCNT,"{package name}^{prefix}^{#rtns}^{size of rtns}^{#files}^{#fields}^{#options}^{#protocols}^{#RPCs}^{#templates}")
End DoDot:3
+11 FOR
SET D1=$ORDER(^TMP("XTVS-VPS",$JOB,D1))
if D1=""
QUIT
SET D2=""
Begin DoDot:3
+12 FOR
SET D2=$ORDER(^TMP("XTVS-VPS",$JOB,D1,D2))
if D2=""
QUIT
Begin DoDot:4
+13 DO PDAD(DISSORT,$GET(^(D2)),D1,D2,"",.VALMCNT)
End DoDot:4
End DoDot:3
End DoDot:2
+14 ;
+15 IF DISSORT=5
Begin DoDot:2
+16 DO ADD^XTVSLAPI(.VALMCNT,"{package name}^{prefix}^{#rtns}^{size of rtns}^{#files}^{#fields}^{#options}^{#protocols}^{#RPCs}^{#templates}^{parent pkg}")
+17 SET TMPSUB=""
+18 FOR
SET TMPSUB=$ORDER(^TMP("XTVS-VPS",$JOB,TMPSUB))
if TMPSUB=""
QUIT
SET D1=""
Begin DoDot:3
+19 FOR
SET D1=$ORDER(^TMP("XTVS-VPS",$JOB,TMPSUB,D1))
if D1=""
QUIT
SET D2=""
Begin DoDot:4
+20 FOR
SET D2=$ORDER(^TMP("XTVS-VPS",$JOB,TMPSUB,D1,D2))
if D2=""
QUIT
Begin DoDot:5
+21 DO PDAD(DISSORT,$GET(^(D2)),D1,D2,"",.VALMCNT)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 KILL ^TMP("XTVS-VPS",$JOB),^TMP("XTVS-PREFIX-IDX",$JOB),^TMP("XTVS-FORUM-PFXS",$JOB)
+24 KILL ^TMP("XTVS-VPS0",$JOB),^TMP("XTVS-KIDSPFX-IDX",$JOB),^TMP("XTVS-FORUM2TMP",$JOB)
+25 KILL ^TMP("XTVS-FORUMPKG",$JOB),^TMP("XTVS-IDX-PKG",$JOB)
+26 ;
KWIT ; QUIT Report
+1 QUIT
+2 ;
PDAD(DISSORT,DATA,D1,D2,D3,VALMCNT) ; print actual data (finally)
+1 NEW D4,D5,D6,D7,D8,D9,D10,DATANDE,SPCT
+2 IF (DISSORT=1)!(DISSORT=4)!(DISSORT=5)
Begin DoDot:1
+3 SET D4=$PIECE(DATA,"^",2)
SET D5=$PIECE(DATA,"^",3)
SET D6=$PIECE(DATA,"^",4)
SET D7=$PIECE(DATA,"^",5)
SET D8=$PIECE(DATA,"^",6)
SET D9=$PIECE(DATA,"^",7)
SET D10=$PIECE(DATA,"^",8)
SET D3=+DATA
End DoDot:1
+4 ;
+5 ;Following code only executes when a caret (^) delimited report is selected
+6 ;;Quit reporting sort types 4 & 5
IF (DISSORT=4)!(DISSORT=5)
Begin DoDot:1
+7 SET DATANDE=""
+8 SET DATANDE=D1_"^"_D2_"^"_D3_"^"_D4_"^"_D5_"^"_D6_"^"_D7_"^"_D8_"^"_D9_"^"_D10_$SELECT($PIECE(DATA,"^",9)'="":"^"_$PIECE(DATA,"^",9),1:"")_$SELECT($PIECE(DATA,"^",10)'="":"^"_$PIECE(DATA,"^",10),1:"")
+9 DO ADD^XTVSLAPI(.VALMCNT,DATANDE)
End DoDot:1
QUIT
+10 ;
+11 ;Following code only executes when user readable report selected (sort types 1, 2, or 3)
+12 IF DISSORT=2!(DISSORT=3)
Begin DoDot:1
+13 SET D5=$PIECE(DATA,"^",2)
SET D6=$PIECE(DATA,"^",3)
SET D7=$PIECE(DATA,"^",4)
SET D8=$PIECE(DATA,"^",5)
SET D9=$PIECE(DATA,"^",6)
SET D10=$PIECE(DATA,"^",7)
+14 if DISSORT=2
SET D4=+DATA
+15 if DISSORT=3
SET D4=D3
SET D3=+DATA
End DoDot:1
+16 ;
+17 DO ADD^XTVSLAPI(.VALMCNT,D1)
+18 SET DATANDE=""
+19 SET DATANDE="("_D2_")"
+20 ;Space out 2nd data element
FOR SPCT=1:1:11-$LENGTH(DATANDE)
SET DATANDE=DATANDE_" "
+21 SET DATANDE=DATANDE_$JUSTIFY(D3,6)_" "_$JUSTIFY(D4,9)_" "_$JUSTIFY(D5,4)_" "_$JUSTIFY(D6,6)_" "_$JUSTIFY(D7,6)_" "_$JUSTIFY(D8,6)_" "_$JUSTIFY(D9,6)_" "_$JUSTIFY(D10,6)
+22 DO ADD^XTVSLAPI(.VALMCNT,DATANDE)
+23 DO ADD^XTVSLAPI(.VALMCNT,"--------------------------------------------------------------------------------")
+24 QUIT
+25 ;
TALLYRPT(DISSORT,XTVSSILN,SELPKGNM) ; Compile component totals
+1 ; INPUT:
+2 ; DISSORT -
+3 ; 1: Sorted on PACKAGE NAME [Default]
+4 ; 2: Sorted on NUMBER of ROUTINES (Highest to Lowest)
+5 ; 3: Sorted on TOTAL ROUTINE SIZE (Highest to Lowest)
+6 ; 4: Delimited (^) Data, Sorted on PACKAGE NAME
+7 ; 5: Delimited (^) Data with PARENT PKG, Sorted by PACKAGE NAME
+8 ;
+9 ; XTVSSILN - Silent mode
+10 ; 0: Show HangChar
+11 ; 1: Silent [Default]
+12 ;
+13 ; SELPKGNM - Selected package name
+14 ; Define when called from ONEPKGSZ^XTVSSVR to only check & send message
+15 ; when selected package is missing
+16 ;
+17 ; Requires the following TMP globals are defined before execution:
+18 ; ^TMP("XTVS-FORUMPKG",$J)
+19 ; ^TMP("XTVS-KIDSPFX-IDX",$J)
+20 ;
+21 ;Create Prefix Indicies
+22 ;
+23 IF $GET(DISSORT)=""
SET DISSORT=1
+24 IF $GET(XTVSSILN)'=0
SET XTVSSILN=1
+25 ;
+26 NEW D1,D2,D3,XTCHAR,TMPSUB,PCENUM,LINEITEM,PKGNAME,PKGPFX,LINECNT
+27 NEW PREFIX,PKGIEN,FFCTRSLT
+28 SET (D1,D2,D3)=0
+29 ;
+30 ; Create ^TMP("XTVS-IDX-PKG",$J) array for MULTX^XTVSRFL1
+31 SET TMPSUB=0
+32 FOR
SET TMPSUB=$ORDER(^TMP("XTVS-FORUMPKG",$JOB,TMPSUB))
if TMPSUB=""
QUIT
Begin DoDot:1
+33 SET LINEITEM=^TMP("XTVS-FORUMPKG",$JOB,TMPSUB)
+34 SET PKGNAME=$PIECE(LINEITEM,"^")
+35 SET PKGPFX=$PIECE(LINEITEM,"^",2)
+36 ;Prefix,Pkg-Name
SET ^TMP("XTVS-PREFIX-IDX",$JOB,PKGPFX,PKGNAME)=""
+37 ;Prefix
SET ^TMP("XTVS-FORUM-PFXS",$JOB,PKGPFX)=""
+38 ; Following ^TMP for PACKAGES in Param file: Prefix,Pkg-Name = 1 when KIDS Prefix, Null when not KIDS Prefix
+39 IF '$DATA(^TMP("XTVS-KIDSPFX-IDX",$JOB,PKGPFX))
SET ^TMP("XTVS-IDX-PKG",$JOB,PKGPFX,PKGNAME)=""
+40 IF $DATA(^TMP("XTVS-KIDSPFX-IDX",$JOB,PKGPFX))
SET ^TMP("XTVS-IDX-PKG",$JOB,PKGPFX,PKGNAME)=$SELECT(^TMP("XTVS-KIDSPFX-IDX",$JOB,PKGPFX)=PKGNAME:1,1:"")
+41 ;
+42 SET ADDPRFX=$PIECE(LINEITEM,"^",5)
+43 SET LPCNT=0
+44 FOR PCENUM=1:1
SET PREFIX=$PIECE(ADDPRFX,"|",PCENUM)
if PREFIX=""
QUIT
Begin DoDot:2
+45 ;Prefix
SET ^TMP("XTVS-FORUM-PFXS",$JOB,PREFIX)=""
+46 ; Following ^TMP for PACKAGES in Param file : Prefix,Pkg-Name = 1 when KIDS Prefix, Null when not KIDS Prefix
+47 SET ^TMP("XTVS-IDX-PKG",$JOB,PREFIX,PKGNAME)=$SELECT($DATA(^TMP("XTVS-KIDSPFX-IDX",$JOB,PREFIX)):1,1:"")
End DoDot:2
End DoDot:1
+48 ;
+49 ;Count components - ^TMP Global loop
+50 if 'XTVSSILN
WRITE !,"Compiling component totals for selected Package data file... "
+51 SET (TMPSUB,XTCHAR)=0
+52 FOR
SET TMPSUB=$ORDER(^TMP("XTVS-FORUMPKG",$JOB,TMPSUB))
if TMPSUB=""
QUIT
if 'XTVSSILN
DO HANGCHAR^XTVSLAPI(.XTCHAR)
Begin DoDot:1
+53 SET PKGIEN=0
+54 SET LINEITEM=^TMP("XTVS-FORUMPKG",$JOB,TMPSUB)
+55 SET PKGNAME=$PIECE(LINEITEM,"^")
+56 ;
+57 IF PKGNAME["''"
Begin DoDot:2
+58
*** ERROR ***
IF $DATA(^DIC(9.4,"B",$REPLACE(PKGNAME,"''","""")))
