A1VSRFL1 ;Albany FO/GTS - VistA Package Sizing Manager; 21-OCT-2016
;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
;
;;Variable glosary (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 (Future: TBD)
;; OTOT = total OPTIONs (^DIC(19,)
;; PRCTOT = total PROTOCOLs (^ORD(101,)
;; RPTOT = total REMOTE PROCEDUREs (^XWB(8994,)
;; TPLTTOT = total Fileman Templates
;
ONERPT(PKGNAME,VALMCNT) ; Report a single package
;;INPUT:
; VALMCNT - Current Node # on ListMan ^TMP("A1VS PKG MGR RPT",$JOB) global
; PKGNAME - Package name to report
;
N Q,PCENUM,ADP,RDP,FTOT,RTOT,OTOT,PRCTOT,RPTOT,TPLTTOT,PKGIEN,PKGPFX,RNDT,TLCNT
N PARMDAT,PARMDAT3,PARMDAT4,PARMDAT7,PARMDAT8
D FULL^VALM1
IF '$D(^DIC(9.4,"B",PKGNAME)) W !!,"Selected package is not defined on this VistA Instance. Unable to continue."
SET PKGIEN=$O(^DIC(9.4,"B",PKGNAME,""))
S PKGPFX=$G(^TMP("A1VS-PARAM-CAP",$J,PKGNAME,2,"Primary Prefix"))
I PKGPFX="" W !!,"PREFIX not found for package selected. Unable to continue." Q
;
SET PARMDAT=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,5,"Additional Prefixes")
S (ADP,Q,PCENUM)=0
FOR SET PCENUM=PCENUM+1 SET Q=$P(PARMDAT,"|",PCENUM) Q:Q="" SET ADP=ADP+1 SET ADP(ADP)=Q
;
SET PARMDAT=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,6,"Excepted Prefixes")
S (RDP,Q,PCENUM)=0
FOR SET PCENUM=PCENUM+1 SET Q=$P(PARMDAT,"|",PCENUM) Q:Q="" SET RDP=RDP+1 SET RDP(RDP)=Q
;
W !,"...counting...",!," ...files..."
SET PARMDAT3=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,3,"*Lowest File#")
SET PARMDAT4=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,4,"*Highest File#")
SET PARMDAT7=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,7,"File Numbers")
SET PARMDAT8=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,8,"File Ranges")
SET FTOT=$$COUNTFLS(PKGPFX,PARMDAT3,PARMDAT4,PARMDAT7,PARMDAT8) ; Count Files
;
W !," ...routines..."
S TLCNT=0,RTOT=$$ROUTINE(PKGPFX,.TLCNT)
I ADP F Q=1:1:ADP I ADP(Q)'="" S RTOT=RTOT+$$ROUTINE(ADP(Q),.TLCNT) ; Count Routines
;
W !," ...options..."
S OTOT=$$OPTION(PKGPFX)
I ADP F Q=1:1:ADP I ADP(Q)'="" S OTOT=OTOT+$$OPTION(ADP(Q)) ;Count Options
;
S PRCTOT=$$PROTOCOL(PKGPFX,PKGIEN)
I ADP F Q=1:1:ADP I ADP(Q)'="" S PRCTOT=PRCTOT+$$PROTOCOL(ADP(Q),PKGIEN) ;Count Protocols
;
W !," ...remote procedures..."
S RPTOT=0
D CNTR("^XWB(8994,",.RPTOT,PKGPFX,PKGNAME,.RDP,.ADP) ;Count Remote Procedure Calls
;
W !," ...edit, print, & sort templates..."
S TPLTTOT=0
D CNTR("^DIPT(",.TPLTTOT,PKGPFX,PKGNAME,.RDP,.ADP) ;Count Print Templates
D CNTR("^DIBT(",.TPLTTOT,PKGPFX,PKGNAME,.RDP,.ADP) ;Count Sort Templates
D CNTR("^DIE(",.TPLTTOT,PKGPFX,PKGNAME,.RDP,.ADP) ;Count Input Templates
;
DO ADD^A1VSLAPI(.VALMCNT," ")
DO ADD^A1VSLAPI(.VALMCNT," VistA Application Sizing Information",1,3,36)
DO NOW^%DTC S Y=X D DD^%DT
SET RNDT=Y
DO ADD^A1VSLAPI(.VALMCNT,"Run Date: "_RNDT)
DO ADD^A1VSLAPI(.VALMCNT,"VistA Application: "_PKGNAME)
DO ADD^A1VSLAPI(.VALMCNT,"==================")
DO ADD^A1VSLAPI(.VALMCNT,"Number of Routines: "_RTOT)
DO ADD^A1VSLAPI(.VALMCNT,"Size of Routines: "_TLCNT)
DO ADD^A1VSLAPI(.VALMCNT,"Number of Files: "_FTOT)
DO ADD^A1VSLAPI(.VALMCNT,"Number of Fields: TBD")
DO ADD^A1VSLAPI(.VALMCNT,"Number of Options: "_OTOT)
DO ADD^A1VSLAPI(.VALMCNT,"Number of Protocols: "_PRCTOT)
DO ADD^A1VSLAPI(.VALMCNT,"Number of RPCs: "_RPTOT)
DO ADD^A1VSLAPI(.VALMCNT,"Number of Templates: "_TPLTTOT)
QUIT
;
COUNTFLS(PKGPFX,LINE3,LINE4,LINE7,LINE8) ;Count total # of files for a package
; LINE3=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,3,"*Lowest File#")
; LINE4=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,4,"*Highest File#")
; LINE7=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,7,"File Numbers")
; LINE8=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,8,"File Ranges")
;
NEW FNDFLDAT,FILELIST,PCENUM,FLERNG,STRTFNUM,ENDFNUM,FTOT,FNUM
SET (FTOT,FNDFLDAT)=0
;
; 1st look for delimited list of file ranges, if exists count it only
SET FILELIST=LINE8
IF FILELIST'="" DO
. SET FNDFLDAT=1
. SET PCENUM=0
. FOR SET PCENUM=PCENUM+1 SET FLERNG=$P(FILELIST,"|",PCENUM) QUIT:FLERNG']"" DO
.. SET STRTFNUM=+$P(FLERNG,"-")
.. SET ENDFNUM=+$P(FLERNG,"-",2)
.. IF +STRTFNUM>0,+ENDFNUM>0 SET FTOT=FTOT+$$FLECNT(STRTFNUM,ENDFNUM)
;
; 2nd if no list of file ranges, look files between Lowest and Highest file number range
IF 'FNDFLDAT,PKGPFX'="XU" DO
. NEW STRTFNUM,ENDFNUM,FNUM,FILENAME
. SET STRTFNUM=LINE3
. SET ENDFNUM=LINE4
. IF +STRTFNUM>0,+ENDFNUM>0 SET FNDFLDAT=1 SET FTOT=FTOT+$$FLECNT(STRTFNUM,ENDFNUM)
;
; 3rd if no list of file ranges & no High/Low file range, count files in File list data element
SET FILELIST=LINE7
IF 'FNDFLDAT,FILELIST'="" DO
. SET FNDFLDAT=1
. SET PCENUM=0
. FOR SET PCENUM=PCENUM+1 SET FNUM=$P(FILELIST,"|",PCENUM) QUIT:FNUM']"" SET FTOT=FTOT+1
QUIT FTOT
;
ROUTINE(PKGPFX,TLCNT,RDP,ADP) ; Returns total of all characters in all routines
; ...Including line feeds on each line of each routine in characters counted
; Input - PKGPFX : Prefix for routine in package
; - TLCNT : Sum of routine sizes in package
; - RDP : Removed (Excepted) Prefixes
; - ADP : Additional Prefixes
;
; Output - TLCNT : Sum of routine sizes incremented by routines in PKGPFX
;
NEW CNT,LPPFX,PFXLN,X,ADPFXLN,ADPFX
SET PFXLN=$L(PKGPFX)
SET CNT=0
SET LPPFX=""
DO RTNLST(PKGPFX,"^TMP(""A1VS"",""RTNLST"""_","_$J_")") ;Create global of Routines with Primary Prefix
FOR SET LPPFX=$ORDER(^TMP("A1VS","RTNLST",$J,LPPFX)) QUIT:LPPFX="" QUIT:($E(LPPFX,1,PFXLN)'=PKGPFX) DO
.IF $$RDPCK(LPPFX,.RDP) DO
.. SET X=LPPFX
.. X ^%ZOSF("TEST") IF $T SET TLCNT=TLCNT+$$RSIZE(LPPFX) SET CNT=CNT+1
KILL ^TMP("A1VS","RTNLST",$J)
;
SET ADPFX=""
FOR SET ADPFX=$O(ADP(ADPFX)) Q:ADPFX="" DO
. SET ADPFXLN=$L(ADPFX)
. DO RTNLST(ADPFX,"^TMP(""A1VS"",""RTNLST"""_","_$J_")") ;Create global of Routines with Additional Prefix
. FOR SET LPPFX=$ORDER(^TMP("A1VS","RTNLST",$J,LPPFX)) QUIT:LPPFX="" QUIT:($E(LPPFX,1,ADPFXLN)'=ADPFX) DO
.. IF ($E(LPPFX,1,PFXLN)'=PKGPFX),($$RDPCK(LPPFX,.RDP)) DO
... SET X=LPPFX
... X ^%ZOSF("TEST") IF $T SET TLCNT=TLCNT+$$RSIZE(LPPFX) SET CNT=CNT+1
. KILL ^TMP("A1VS","RTNLST",$J)
QUIT CNT
;
RTNLST(PREFIX,RTNLIST) ; Create RTNLIST of routines in PREFIX namespace
NEW RTNS,RTNNAME
SET RTNS=##class(%ResultSet).%New("%Routine:RoutineList") ;Create Routine Query Class instance
DO RTNS.Execute(PREFIX_"*.INT") ;Query Routines
FOR Q:'RTNS.Next() SET RTNNAME=$P(RTNS.GetData(1),".") SET @RTNLIST@(RTNNAME)=""
QUIT
;
RDPCK(LPPFX,RDP) ;Check for excepted PREFIX [Result=0 when Excepted]
N RESULT,RPFX,RPFXLN
S RESULT=1
S RPFX=""
FOR SET RPFX=$O(RDP(RPFX)) Q:RPFX="" Q:'RESULT DO
. SET RPFXLN=$L(RPFX)
. IF $E(LPPFX,1,RPFXLN)=RPFX SET RESULT=0
Q RESULT
;
FLECNT(STRTFNUM,ENDFNUM) ; Count Files
NEW FCNT,FNUM
SET FCNT=0
SET FNUM=$O(^DIC(STRTFNUM),-1)
FOR SET FNUM=$O(^DIC(FNUM)) Q:'FNUM Q:'FNUM Q:FNUM>ENDFNUM DO
. KILL VPSFAT
. SET FILENAME=$P($G(^DIC(FNUM,0)),"^")
. IF FILENAME]"" S FCNT=FCNT+1
KILL VPSFAT
Q FCNT
;
PROTOCOL(PKGPFX,PKGIEN,RDP,ADP) ; Count Protocols
NEW LPPFX,PFXLN,ADPFXLN,ADPFX,CNT,ORDIEN
SET PFXLN=$L(PKGPFX)
SET CNT=0
SET LPPFX=""
IF '$D(PGKIEN) SET PKGIEN=0
IF $D(PKGIEN),(PKGIEN="") SET PKGIEN=0
FOR SET LPPFX=$O(^ORD(101,"B",LPPFX)) QUIT:LPPFX="" SET ORDIEN=$O(^ORD(101,"B",LPPFX,"")) QUIT:ORDIEN="" DO
. IF $P($G(^ORD(101,ORDIEN,0)),"^",12)=PKGIEN SET CNT=CNT+1
. IF $E(LPPFX,1,PFXLN)=PKGPFX,$$RDPCK(LPPFX,.RDP) DO
.. IF ($P($G(^ORD(101,ORDIEN,0)),"^",12)'=PKGIEN) S CNT=CNT+1
.;
. IF ($E(LPPFX,1,PFXLN)'=PKGPFX),($P($G(^ORD(101,ORDIEN,0)),"^",12)'=PKGIEN) DO
.. SET ADPFX=""
.. FOR SET ADPFX=$O(ADP(ADPFX)) QUIT:ADPFX="" DO
... SET ADPFXLN=$L(ADPFX)
... IF $E(LPPFX,1,ADPFXLN)=ADPFX,$$RDPCK(LPPFX,.RDP) SET CNT=CNT+1
;
Q CNT
;
CNTR(TMPGLB,CNT,PKGPFX,PKGNAME,RDP,ADP) ;Count Templates & RPCs
NEW LPPFX,PFXLN,TMPLTPFX,PFXEXT,PFXANLYS,PFXAVAIL
SET PFXLN=$L(PKGPFX)
SET LPPFX=$O(@(TMPGLB_"""B"","""_PKGPFX_""")"),-1)
FOR SET LPPFX=$O(@(TMPGLB_"""B"","""_LPPFX_""")")) Q:$E(LPPFX,1,PFXLN)'=PKGPFX DO
.SET TMPLTPFX=LPPFX
.SET:TMPLTPFX[" " TMPLTPFX=$P(TMPLTPFX," ")
.IF $L(TMPLTPFX)=PFXLN SET CNT=CNT+1
.IF $L(TMPLTPFX)>PFXLN,('$D(^TMP("A1VS-PREFIX-IDX",$J,PKGNAME,TMPLTPFX))),('$D(^TMP("A1VS-FORUM-PFXS",$J,TMPLTPFX))) DO
..; Prefix starts with PKGPFX, is not part of another package's main prefix, and is not the current package
.. SET PFXAVAIL=1
.. SET PFXANLYS=PKGPFX
.. FOR PFXEXT=PFXLN+1:1 Q:($E(TMPLTPFX,PFXEXT)'?1AN) Q:'PFXAVAIL SET PFXANLYS=PFXANLYS_$E(TMPLTPFX,PFXEXT) DO
... IF ($D(^TMP("A1VS-FORUM-PFXS",$J,PFXANLYS))),'$$RDPCK(PFXANLYS,.RDP) SET PFXAVAIL=0 ;Parsed prefix belongs to other package or excluded from current pkg
.. IF PFXAVAIL SET CNT=CNT+1
QUIT
;
OPTION(PKGPFX,PKGNME,RDP) ;Count Options
;
NEW CNT,LPPFX,PFXLN,OPTPFX,PFXEXT,PFXANLYS,PFXAVAIL
SET PFXLN=$L(PKGPFX)
SET CNT=0
SET LPPFX=$O(^DIC(19,"B",PKGPFX),-1)
FOR SET LPPFX=$O(^DIC(19,"B",LPPFX)) Q:$E(LPPFX,1,PFXLN)'=PKGPFX DO
.SET OPTPFX=LPPFX
.SET:OPTPFX[" " OPTPFX=$P(OPTPFX," ")
.IF $L(OPTPFX)=PFXLN SET CNT=CNT+1
.IF $L(OPTPFX)>PFXLN,('$D(^TMP("A1VS-PREFIX-IDX",$J,PKGNAME,OPTPFX))),('$D(^TMP("A1VS-FORUM-PFXS",$J,OPTPFX))) DO
..; Prefix starts with PKGPFX, is not part of another package, or the current package
.. SET PFXAVAIL=1
.. SET PFXANLYS=PKGPFX
.. FOR PFXEXT=PFXLN+1:1 Q:($E(OPTPFX,PFXEXT)'?1AN) Q:'PFXAVAIL SET PFXANLYS=PFXANLYS_$E(OPTPFX,PFXEXT) DO
... IF ($D(^TMP("A1VS-FORUM-PFXS",$J,PFXANLYS))),'$$RDPCK(PFXANLYS,.RDP) SET PFXAVAIL=0 ;Parsed prefix belongs to other package or excluded from current pkg
.. IF PFXAVAIL SET CNT=CNT+1
Q CNT
;
; - NOTE: Check for Primary Prefix (=1) will count DVBC for COMP & PEN package but NOT AMIE.
MULTX(APFX,PKGNAME) ; Return indication of Multiple packages using same prefix
;Prevent Primary prefix from double counting as added prefix
NEW RESULT,LPPKG
SET RESULT=1
SET LPPKG=""
;
; Return RESULT=0 if PKGNAME is not LPPKG and LPPKG is primary package
FOR SET LPPKG=$O(^TMP("A1VS-IDX-PKG",$J,APFX,LPPKG)) Q:LPPKG="" Q:'RESULT DO
. IF LPPKG'=PKGNAME,^TMP("A1VS-IDX-PKG",$J,APFX,LPPKG)=1 SET RESULT=0
QUIT RESULT
;
;
KIDSIDX() ;Create Prefix-Package Indicies from KIDS
NEW KIDSIEN,KIDSPKG,KIDSPRFX,KIDSZERO,PKGIEN,PATCHNME
SET KIDSIEN=0
FOR SET KIDSIEN=$O(^XPD(9.6,KIDSIEN)) Q:+KIDSIEN=0 DO
. SET KIDSZERO=$G(^XPD(9.6,KIDSIEN,0))
. IF KIDSZERO]"" DO
.. SET PKGIEN=$P(KIDSZERO,"^",2)
.. SET:+PKGIEN>0 KIDSPKG=$P($G(^DIC(9.4,PKGIEN,0)),"^",1)
.. SET PATCHNME=$P(KIDSZERO,"^",1)
.. SET KIDSPRFX=$P(PATCHNME,"*",1)
.. IF KIDSPRFX]"" SET ^TMP("A1VS-KIDSPFX-IDX",$J,KIDSPRFX)=KIDSPKG
QUIT
;
RSIZE(RTN) ; Compute routine size (# characters plus line feeds) [^%ZOSF("SIZE") algorithm]
NEW LINE,CT,RSIZEVAL
SET (CT,RSIZEVAL)=0
SET LINE=""
X "ZL @RTN F S CT=CT+1,LINE=$T(+CT) Q:$L(LINE)=0 SET RSIZEVAL=RSIZEVAL+$L(LINE)+2"
QUIT RSIZEVAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1VSRFL1 11337 printed Dec 13, 2024@01:38:51 Page 2
A1VSRFL1 ;Albany FO/GTS - VistA Package Sizing Manager; 21-OCT-2016
+1 ;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
+2 ;
+3 ;;Variable glosary (local, for each package)
+4 ;; PKGIEN = Package IEN
+5 ;; PKGNAME = Package NAME (.01 - $P(^(0),"^",1))
+6 ;; PKGPFX = Package PREFIX / NAMESPACE (1 - $P(^(0),"^",2))
+7 ;;
+8 ;; RTOT = total ROUTINEs
+9 ;; TLCNT = total SIZE of all ROUTINES
+10 ;; FTOT = total FILEs
+11 ;; FLDTOT = total FIELDs of all FILES (Future: TBD)
+12 ;; OTOT = total OPTIONs (^DIC(19,)
+13 ;; PRCTOT = total PROTOCOLs (^ORD(101,)
+14 ;; RPTOT = total REMOTE PROCEDUREs (^XWB(8994,)
+15 ;; TPLTTOT = total Fileman Templates
+16 ;
ONERPT(PKGNAME,VALMCNT) ; Report a single package
+1 ;;INPUT:
+2 ; VALMCNT - Current Node # on ListMan ^TMP("A1VS PKG MGR RPT",$JOB) global
+3 ; PKGNAME - Package name to report
+4 ;
+5 NEW Q,PCENUM,ADP,RDP,FTOT,RTOT,OTOT,PRCTOT,RPTOT,TPLTTOT,PKGIEN,PKGPFX,RNDT,TLCNT
+6 NEW PARMDAT,PARMDAT3,PARMDAT4,PARMDAT7,PARMDAT8
+7 DO FULL^VALM1
+8 IF '$DATA(^DIC(9.4,"B",PKGNAME))
WRITE !!,"Selected package is not defined on this VistA Instance. Unable to continue."
+9 SET PKGIEN=$ORDER(^DIC(9.4,"B",PKGNAME,""))
+10 SET PKGPFX=$GET(^TMP("A1VS-PARAM-CAP",$JOB,PKGNAME,2,"Primary Prefix"))
+11 IF PKGPFX=""
WRITE !!,"PREFIX not found for package selected. Unable to continue."
QUIT
+12 ;
+13 SET PARMDAT=^TMP("A1VS-PARAM-CAP",$JOB,PKGNAME,5,"Additional Prefixes")
+14 SET (ADP,Q,PCENUM)=0
+15 FOR
SET PCENUM=PCENUM+1
SET Q=$PIECE(PARMDAT,"|",PCENUM)
if Q=""
QUIT
SET ADP=ADP+1
SET ADP(ADP)=Q
+16 ;
+17 SET PARMDAT=^TMP("A1VS-PARAM-CAP",$JOB,PKGNAME,6,"Excepted Prefixes")
+18 SET (RDP,Q,PCENUM)=0
+19 FOR
SET PCENUM=PCENUM+1
SET Q=$PIECE(PARMDAT,"|",PCENUM)
if Q=""
QUIT
SET RDP=RDP+1
SET RDP(RDP)=Q
+20 ;
+21 WRITE !,"...counting...",!," ...files..."
+22 SET PARMDAT3=^TMP("A1VS-PARAM-CAP",$JOB,PKGNAME,3,"*Lowest File#")
+23 SET PARMDAT4=^TMP("A1VS-PARAM-CAP",$JOB,PKGNAME,4,"*Highest File#")
+24 SET PARMDAT7=^TMP("A1VS-PARAM-CAP",$JOB,PKGNAME,7,"File Numbers")
+25 SET PARMDAT8=^TMP("A1VS-PARAM-CAP",$JOB,PKGNAME,8,"File Ranges")
+26 ; Count Files
SET FTOT=$$COUNTFLS(PKGPFX,PARMDAT3,PARMDAT4,PARMDAT7,PARMDAT8)
+27 ;
+28 WRITE !," ...routines..."
+29 SET TLCNT=0
SET RTOT=$$ROUTINE(PKGPFX,.TLCNT)
+30 ; Count Routines
IF ADP
FOR Q=1:1:ADP
IF ADP(Q)'=""
SET RTOT=RTOT+$$ROUTINE(ADP(Q),.TLCNT)
+31 ;
+32 WRITE !," ...options..."
+33 SET OTOT=$$OPTION(PKGPFX)
+34 ;Count Options
IF ADP
FOR Q=1:1:ADP
IF ADP(Q)'=""
SET OTOT=OTOT+$$OPTION(ADP(Q))
+35 ;
+36 SET PRCTOT=$$PROTOCOL(PKGPFX,PKGIEN)
+37 ;Count Protocols
IF ADP
FOR Q=1:1:ADP
IF ADP(Q)'=""
SET PRCTOT=PRCTOT+$$PROTOCOL(ADP(Q),PKGIEN)
+38 ;
+39 WRITE !," ...remote procedures..."
+40 SET RPTOT=0
+41 ;Count Remote Procedure Calls
DO CNTR("^XWB(8994,",.RPTOT,PKGPFX,PKGNAME,.RDP,.ADP)
+42 ;
+43 WRITE !," ...edit, print, & sort templates..."
+44 SET TPLTTOT=0
+45 ;Count Print Templates
DO CNTR("^DIPT(",.TPLTTOT,PKGPFX,PKGNAME,.RDP,.ADP)
+46 ;Count Sort Templates
DO CNTR("^DIBT(",.TPLTTOT,PKGPFX,PKGNAME,.RDP,.ADP)
+47 ;Count Input Templates
DO CNTR("^DIE(",.TPLTTOT,PKGPFX,PKGNAME,.RDP,.ADP)
+48 ;
+49 DO ADD^A1VSLAPI(.VALMCNT," ")
+50 DO ADD^A1VSLAPI(.VALMCNT," VistA Application Sizing Information",1,3,36)
+51 DO NOW^%DTC
SET Y=X
DO DD^%DT
+52 SET RNDT=Y
+53 DO ADD^A1VSLAPI(.VALMCNT,"Run Date: "_RNDT)
+54 DO ADD^A1VSLAPI(.VALMCNT,"VistA Application: "_PKGNAME)
+55 DO ADD^A1VSLAPI(.VALMCNT,"==================")
+56 DO ADD^A1VSLAPI(.VALMCNT,"Number of Routines: "_RTOT)
+57 DO ADD^A1VSLAPI(.VALMCNT,"Size of Routines: "_TLCNT)
+58 DO ADD^A1VSLAPI(.VALMCNT,"Number of Files: "_FTOT)
+59 DO ADD^A1VSLAPI(.VALMCNT,"Number of Fields: TBD")
+60 DO ADD^A1VSLAPI(.VALMCNT,"Number of Options: "_OTOT)
+61 DO ADD^A1VSLAPI(.VALMCNT,"Number of Protocols: "_PRCTOT)
+62 DO ADD^A1VSLAPI(.VALMCNT,"Number of RPCs: "_RPTOT)
+63 DO ADD^A1VSLAPI(.VALMCNT,"Number of Templates: "_TPLTTOT)
+64 QUIT
+65 ;
COUNTFLS(PKGPFX,LINE3,LINE4,LINE7,LINE8) ;Count total # of files for a package
+1 ; LINE3=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,3,"*Lowest File#")
+2 ; LINE4=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,4,"*Highest File#")
+3 ; LINE7=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,7,"File Numbers")
+4 ; LINE8=^TMP("A1VS-PARAM-CAP",$J,PKGNAME,8,"File Ranges")
+5 ;
+6 NEW FNDFLDAT,FILELIST,PCENUM,FLERNG,STRTFNUM,ENDFNUM,FTOT,FNUM
+7 SET (FTOT,FNDFLDAT)=0
+8 ;
+9 ; 1st look for delimited list of file ranges, if exists count it only
+10 SET FILELIST=LINE8
+11 IF FILELIST'=""
Begin DoDot:1
+12 SET FNDFLDAT=1
+13 SET PCENUM=0
+14 FOR
SET PCENUM=PCENUM+1
SET FLERNG=$PIECE(FILELIST,"|",PCENUM)
if FLERNG']""
QUIT
Begin DoDot:2
+15 SET STRTFNUM=+$PIECE(FLERNG,"-")
+16 SET ENDFNUM=+$PIECE(FLERNG,"-",2)
+17 IF +STRTFNUM>0
IF +ENDFNUM>0
SET FTOT=FTOT+$$FLECNT(STRTFNUM,ENDFNUM)
End DoDot:2
End DoDot:1
+18 ;
+19 ; 2nd if no list of file ranges, look files between Lowest and Highest file number range
+20 IF 'FNDFLDAT
IF PKGPFX'="XU"
Begin DoDot:1
+21 NEW STRTFNUM,ENDFNUM,FNUM,FILENAME
+22 SET STRTFNUM=LINE3
+23 SET ENDFNUM=LINE4
+24 IF +STRTFNUM>0
IF +ENDFNUM>0
SET FNDFLDAT=1
SET FTOT=FTOT+$$FLECNT(STRTFNUM,ENDFNUM)
End DoDot:1
+25 ;
+26 ; 3rd if no list of file ranges & no High/Low file range, count files in File list data element
+27 SET FILELIST=LINE7
+28 IF 'FNDFLDAT
IF FILELIST'=""
Begin DoDot:1
+29 SET FNDFLDAT=1
+30 SET PCENUM=0
+31 FOR
SET PCENUM=PCENUM+1
SET FNUM=$PIECE(FILELIST,"|",PCENUM)
if FNUM']""
QUIT
SET FTOT=FTOT+1
End DoDot:1
+32 QUIT FTOT
+33 ;
ROUTINE(PKGPFX,TLCNT,RDP,ADP) ; Returns total of all characters in all routines
+1 ; ...Including line feeds on each line of each routine in characters counted
+2 ; Input - PKGPFX : Prefix for routine in package
+3 ; - TLCNT : Sum of routine sizes in package
+4 ; - RDP : Removed (Excepted) Prefixes
+5 ; - ADP : Additional Prefixes
+6 ;
+7 ; Output - TLCNT : Sum of routine sizes incremented by routines in PKGPFX
+8 ;
+9 NEW CNT,LPPFX,PFXLN,X,ADPFXLN,ADPFX
+10 SET PFXLN=$LENGTH(PKGPFX)
+11 SET CNT=0
+12 SET LPPFX=""
+13 ;Create global of Routines with Primary Prefix
DO RTNLST(PKGPFX,"^TMP(""A1VS"",""RTNLST"""_","_$JOB_")")
+14 FOR
SET LPPFX=$ORDER(^TMP("A1VS","RTNLST",$JOB,LPPFX))
if LPPFX=""
QUIT
if ($EXTRACT(LPPFX,1,PFXLN)'=PKGPFX)
QUIT
Begin DoDot:1
+15 IF $$RDPCK(LPPFX,.RDP)
Begin DoDot:2
+16 SET X=LPPFX
+17 XECUTE ^%ZOSF("TEST")
IF $TEST
SET TLCNT=TLCNT+$$RSIZE(LPPFX)
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+18 KILL ^TMP("A1VS","RTNLST",$JOB)
+19 ;
+20 SET ADPFX=""
+21 FOR
SET ADPFX=$ORDER(ADP(ADPFX))
if ADPFX=""
QUIT
Begin DoDot:1
+22 SET ADPFXLN=$LENGTH(ADPFX)
+23 ;Create global of Routines with Additional Prefix
DO RTNLST(ADPFX,"^TMP(""A1VS"",""RTNLST"""_","_$JOB_")")
+24 FOR
SET LPPFX=$ORDER(^TMP("A1VS","RTNLST",$JOB,LPPFX))
if LPPFX=""
QUIT
if ($EXTRACT(LPPFX,1,ADPFXLN)'=ADPFX)
QUIT
Begin DoDot:2
+25 IF ($EXTRACT(LPPFX,1,PFXLN)'=PKGPFX)
IF ($$RDPCK(LPPFX,.RDP))
Begin DoDot:3
+26 SET X=LPPFX
+27 XECUTE ^%ZOSF("TEST")
IF $TEST
SET TLCNT=TLCNT+$$RSIZE(LPPFX)
SET CNT=CNT+1
End DoDot:3
End DoDot:2
+28 KILL ^TMP("A1VS","RTNLST",$JOB)
End DoDot:1
+29 QUIT CNT
+30 ;
RTNLST(PREFIX,RTNLIST) ; Create RTNLIST of routines in PREFIX namespace
+1 NEW RTNS,RTNNAME
+2 ;Create Routine Query Class instance
SET RTNS=##class(%ResultSet).%New("%Routine:RoutineList")
+3 ;Query Routines
DO RTNS.Execute(PREFIX_"*.INT")
+4 FOR
if 'RTNS.Next()
QUIT
SET RTNNAME=$PIECE(RTNS.GetData(1),".")
SET @RTNLIST@(RTNNAME)=""
+5 QUIT
+6 ;
RDPCK(LPPFX,RDP) ;Check for excepted PREFIX [Result=0 when Excepted]
+1 NEW RESULT,RPFX,RPFXLN
+2 SET RESULT=1
+3 SET RPFX=""
+4 FOR
SET RPFX=$ORDER(RDP(RPFX))
if RPFX=""
QUIT
if 'RESULT
QUIT
Begin DoDot:1
+5 SET RPFXLN=$LENGTH(RPFX)
+6 IF $EXTRACT(LPPFX,1,RPFXLN)=RPFX
SET RESULT=0
End DoDot:1
+7 QUIT RESULT
+8 ;
FLECNT(STRTFNUM,ENDFNUM) ; Count Files
+1 NEW FCNT,FNUM
+2 SET FCNT=0
+3 SET FNUM=$ORDER(^DIC(STRTFNUM),-1)
+4 FOR
SET FNUM=$ORDER(^DIC(FNUM))
if 'FNUM
QUIT
if 'FNUM
QUIT
if FNUM>ENDFNUM
QUIT
Begin DoDot:1
+5 KILL VPSFAT
+6 SET FILENAME=$PIECE($GET(^DIC(FNUM,0)),"^")
+7 IF FILENAME]""
SET FCNT=FCNT+1
End DoDot:1
+8 KILL VPSFAT
+9 QUIT FCNT
+10 ;
PROTOCOL(PKGPFX,PKGIEN,RDP,ADP) ; Count Protocols
+1 NEW LPPFX,PFXLN,ADPFXLN,ADPFX,CNT,ORDIEN
+2 SET PFXLN=$LENGTH(PKGPFX)
+3 SET CNT=0
+4 SET LPPFX=""
+5 IF '$DATA(PGKIEN)
SET PKGIEN=0
+6 IF $DATA(PKGIEN)
IF (PKGIEN="")
SET PKGIEN=0
+7 FOR
SET LPPFX=$ORDER(^ORD(101,"B",LPPFX))
if LPPFX=""
QUIT
SET ORDIEN=$ORDER(^ORD(101,"B",LPPFX,""))
if ORDIEN=""
QUIT
Begin DoDot:1
+8 IF $PIECE($GET(^ORD(101,ORDIEN,0)),"^",12)=PKGIEN
SET CNT=CNT+1
+9 IF $EXTRACT(LPPFX,1,PFXLN)=PKGPFX
IF $$RDPCK(LPPFX,.RDP)
Begin DoDot:2
+10 IF ($PIECE($GET(^ORD(101,ORDIEN,0)),"^",12)'=PKGIEN)
SET CNT=CNT+1
End DoDot:2
+11 ;
+12 IF ($EXTRACT(LPPFX,1,PFXLN)'=PKGPFX)
IF ($PIECE($GET(^ORD(101,ORDIEN,0)),"^",12)'=PKGIEN)
Begin DoDot:2
+13 SET ADPFX=""
+14 FOR
SET ADPFX=$ORDER(ADP(ADPFX))
if ADPFX=""
QUIT
Begin DoDot:3
+15 SET ADPFXLN=$LENGTH(ADPFX)
+16 IF $EXTRACT(LPPFX,1,ADPFXLN)=ADPFX
IF $$RDPCK(LPPFX,.RDP)
SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;
+18 QUIT CNT
+19 ;
CNTR(TMPGLB,CNT,PKGPFX,PKGNAME,RDP,ADP) ;Count Templates & RPCs
+1 NEW LPPFX,PFXLN,TMPLTPFX,PFXEXT,PFXANLYS,PFXAVAIL
+2 SET PFXLN=$LENGTH(PKGPFX)
+3 SET LPPFX=$ORDER(@(TMPGLB_"""B"","""_PKGPFX_""")"),-1)
+4 FOR
SET LPPFX=$ORDER(@(TMPGLB_"""B"","""_LPPFX_""")"))
if $EXTRACT(LPPFX,1,PFXLN)'=PKGPFX
QUIT
Begin DoDot:1
+5 SET TMPLTPFX=LPPFX
+6 if TMPLTPFX[" "
SET TMPLTPFX=$PIECE(TMPLTPFX," ")
+7 IF $LENGTH(TMPLTPFX)=PFXLN
SET CNT=CNT+1
+8 IF $LENGTH(TMPLTPFX)>PFXLN
IF ('$DATA(^TMP("A1VS-PREFIX-IDX",$JOB,PKGNAME,TMPLTPFX)))
IF ('$DATA(^TMP("A1VS-FORUM-PFXS",$JOB,TMPLTPFX)))
Begin DoDot:2
+9 ; Prefix starts with PKGPFX, is not part of another package's main prefix, and is not the current package
+10 SET PFXAVAIL=1
+11 SET PFXANLYS=PKGPFX
+12 FOR PFXEXT=PFXLN+1:1
if ($EXTRACT(TMPLTPFX,PFXEXT)'?1AN)
QUIT
if 'PFXAVAIL
QUIT
SET PFXANLYS=PFXANLYS_$EXTRACT(TMPLTPFX,PFXEXT)
Begin DoDot:3
+13 ;Parsed prefix belongs to other package or excluded from current pkg
IF ($DATA(^TMP("A1VS-FORUM-PFXS",$JOB,PFXANLYS)))
IF '$$RDPCK(PFXANLYS,.RDP)
SET PFXAVAIL=0
End DoDot:3
+14 IF PFXAVAIL
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
OPTION(PKGPFX,PKGNME,RDP) ;Count Options
+1 ;
+2 NEW CNT,LPPFX,PFXLN,OPTPFX,PFXEXT,PFXANLYS,PFXAVAIL
+3 SET PFXLN=$LENGTH(PKGPFX)
+4 SET CNT=0
+5 SET LPPFX=$ORDER(^DIC(19,"B",PKGPFX),-1)
+6 FOR
SET LPPFX=$ORDER(^DIC(19,"B",LPPFX))
if $EXTRACT(LPPFX,1,PFXLN)'=PKGPFX
QUIT
Begin DoDot:1
+7 SET OPTPFX=LPPFX
+8 if OPTPFX[" "
SET OPTPFX=$PIECE(OPTPFX," ")
+9 IF $LENGTH(OPTPFX)=PFXLN
SET CNT=CNT+1
+10 IF $LENGTH(OPTPFX)>PFXLN
IF ('$DATA(^TMP("A1VS-PREFIX-IDX",$JOB,PKGNAME,OPTPFX)))
IF ('$DATA(^TMP("A1VS-FORUM-PFXS",$JOB,OPTPFX)))
Begin DoDot:2
+11 ; Prefix starts with PKGPFX, is not part of another package, or the current package
+12 SET PFXAVAIL=1
+13 SET PFXANLYS=PKGPFX
+14 FOR PFXEXT=PFXLN+1:1
if ($EXTRACT(OPTPFX,PFXEXT)'?1AN)
QUIT
if 'PFXAVAIL
QUIT
SET PFXANLYS=PFXANLYS_$EXTRACT(OPTPFX,PFXEXT)
Begin DoDot:3
+15 ;Parsed prefix belongs to other package or excluded from current pkg
IF ($DATA(^TMP("A1VS-FORUM-PFXS",$JOB,PFXANLYS)))
IF '$$RDPCK(PFXANLYS,.RDP)
SET PFXAVAIL=0
End DoDot:3
+16 IF PFXAVAIL
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+17 QUIT CNT
+18 ;
+19 ; - NOTE: Check for Primary Prefix (=1) will count DVBC for COMP & PEN package but NOT AMIE.
MULTX(APFX,PKGNAME) ; Return indication of Multiple packages using same prefix
+1 ;Prevent Primary prefix from double counting as added prefix
+2 NEW RESULT,LPPKG
+3 SET RESULT=1
+4 SET LPPKG=""
+5 ;
+6 ; Return RESULT=0 if PKGNAME is not LPPKG and LPPKG is primary package
+7 FOR
SET LPPKG=$ORDER(^TMP("A1VS-IDX-PKG",$JOB,APFX,LPPKG))
if LPPKG=""
QUIT
if 'RESULT
QUIT
Begin DoDot:1
+8 IF LPPKG'=PKGNAME
IF ^TMP("A1VS-IDX-PKG",$JOB,APFX,LPPKG)=1
SET RESULT=0
End DoDot:1
+9 QUIT RESULT
+10 ;
+11 ;
KIDSIDX() ;Create Prefix-Package Indicies from KIDS
+1 NEW KIDSIEN,KIDSPKG,KIDSPRFX,KIDSZERO,PKGIEN,PATCHNME
+2 SET KIDSIEN=0
+3 FOR
SET KIDSIEN=$ORDER(^XPD(9.6,KIDSIEN))
if +KIDSIEN=0
QUIT
Begin DoDot:1
+4 SET KIDSZERO=$GET(^XPD(9.6,KIDSIEN,0))
+5 IF KIDSZERO]""
Begin DoDot:2
+6 SET PKGIEN=$PIECE(KIDSZERO,"^",2)
+7 if +PKGIEN>0
SET KIDSPKG=$PIECE($GET(^DIC(9.4,PKGIEN,0)),"^",1)
+8 SET PATCHNME=$PIECE(KIDSZERO,"^",1)
+9 SET KIDSPRFX=$PIECE(PATCHNME,"*",1)
+10 IF KIDSPRFX]""
SET ^TMP("A1VS-KIDSPFX-IDX",$JOB,KIDSPRFX)=KIDSPKG
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
RSIZE(RTN) ; Compute routine size (# characters plus line feeds) [^%ZOSF("SIZE") algorithm]
+1 NEW LINE,CT,RSIZEVAL
+2 SET (CT,RSIZEVAL)=0
+3 SET LINE=""
+4 XECUTE "ZL @RTN F S CT=CT+1,LINE=$T(+CT) Q:$L(LINE)=0 SET RSIZEVAL=RSIZEVAL+$L(LINE)+2"
+5 QUIT RSIZEVAL
