XTVSLPR1 ;ALBANY FO/GTS - VistA Package Sizing Manager; 18-DEC-2018
;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
;APIs
INCONSCK ;Check for overlaps in Forum Package file data
;Requires ^TMP("XTVS-PFXIDX",$J,<prefix>,<package name>) & ^TMP("XTVS-FRIDX",$J,<begin file #>,<end file #>,<package name>)
NEW TMPROOT,PKGNME,PREFIX,ADPFXIND,OLDPKG
SET TMPROOT="^TMP(""XTVS-PKGEDIT"","_$J_")"
SET OLDPKG=$QSUBSCRIPT($QUERY(@TMPROOT),3)
SET ADPFXIND=0
FOR SET TMPROOT=$QUERY(@TMPROOT) QUIT:TMPROOT="" Q:$QSUBSCRIPT(TMPROOT,1)'="XTVS-PKGEDIT" Q:$QSUBSCRIPT(TMPROOT,2)'=$JOB DO
. SET PKGNME=$QSUBSCRIPT(TMPROOT,3)
. SET PREFIX=$QSUBSCRIPT(TMPROOT,4)
. ; Execute "If" code when a new package is encountered
. IF (OLDPKG'=PKGNME) DO
.. ;1st loop on pkg, check primary prefix
.. IF ('ADPFXIND) DO CHKPFX(PKGNME,PREFIX,"^TMP(""XTVS-PKGEDIT"","_$J_","""_PKGNME_""","""_PREFIX_""")",PREFIX)
.. SET ADPFXIND=0 ;Reset the Add Prefix list found indicator after the first pass on the latest package
. SET OLDPKG=PKGNME
. DO FLDDATLP(TMPROOT,PKGNME,PREFIX,.ADPFXIND) ; Loop fields and data to check Prefix and File ranges
KILL ^TMP("XTVS-PKGRPT-PFX-IDX",$J),^TMP("XTVS-PKGRPT-FRNG-IDX",$J),^TMP("XTVS-PKGRPT-CMB-IDX",$J)
QUIT
;
FLDDATLP(TMPROOT,PKGNME,PREFIX,ADPFXIND) ;Check Fields and Data for 'ADDPFX' and 'FLERNG' Nodes
; Input: TMPROOT - Package "XTVS-PKGEDIT" array root [^TMP("XTVS-PKGEDIT",$J,PKGNME,PREFIX)]
; PKGNME - Package Name using Prefix
; PREFIX - Additional Prefix used by Package
; ADPFXIND - Indicates that prefix has been checked
;
NEW FLDSUB,DATASUB,FLERNGFD
SET FLERNGFD=0 ;Set compare file ranges by first found : FILE RANGE, *LOWEST/*HIGHEST, FILE LIST
SET FLDSUB="" ;Extract Field Subscript looking for Additional Prefixes and File Ranges
FOR SET FLDSUB=$O(@TMPROOT@(FLDSUB)) Q:FLDSUB="" DO
. SET DATASUB=""
. FOR SET DATASUB=$O(@TMPROOT@(FLDSUB,DATASUB)) Q:DATASUB="" DO
.. ;NOTE: To change Field Subscript, check different value of FLDSUB
.. IF FLDSUB="ADDPFX" DO CHKPFX(PKGNME,DATASUB,TMPROOT,PREFIX) SET ADPFXIND=1
.. IF FLDSUB="F1-FLERNG" DO ;FILE RANGE
... DO CHKFILE(PKGNME,DATASUB,TMPROOT,PREFIX,"F1")
... SET FLERNGFD=1
.. IF 'FLERNGFD,FLDSUB="F2-BEGFILE",$D(@TMPROOT@("F2-ENDFILE")) DO ;*LOWEST - *HIGHEST
... DO CHKFILE(PKGNME,DATASUB,TMPROOT,PREFIX,"F2")
... IF $O(@TMPROOT@(FLDSUB,DATASUB))="" SET FLERNGFD=1
.. IF 'FLERNGFD,FLDSUB="F3-FNUM" DO ;FILE LIST
... DO CHKFILE(PKGNME,DATASUB,TMPROOT,PREFIX,"F3")
... IF $O(@TMPROOT@(FLDSUB,DATASUB))="" SET FLERNGFD=1
QUIT
;
CHKPFX(PKGNME,PREFIX,TMPROOT,PKGPFX) ; Check Prefix for multiple use
; Input: PKGNME - Package Name using Prefix
; PREFIX - Additional Prefix used by Package
; TMPROOT - Package "XTVS-PKGEDIT" array root [^TMP("XTVS-PKGEDIT",J,PKGNME,PREFIX)]
; PKGPFX - Package Prefix
;
; Output: ^TMP("XTVS-ERROR",$J,"PREFIX") array
;
NEW IDXROOT,PKGSUB,ERRARYCT,FILERPRT,ADDREMPX
SET FILERPRT=0
SET IDXROOT="^TMP(""XTVS-PFXIDX"","_$J_","""_PREFIX_""")" ;Use "PFXIDX" index
SET ADDREMPX=@IDXROOT@(PKGNME)
SET ERRARYCT=+$O(^TMP("XTVS-ERROR",$J,"PREFIX",""),-1)
FOR SET IDXROOT=$QUERY(@IDXROOT) Q:IDXROOT="" Q:$QSUBSCRIPT(IDXROOT,1)'="XTVS-PFXIDX" Q:$QSUBSCRIPT(IDXROOT,3)'[PREFIX Q:$QSUBSCRIPT(IDXROOT,2)'=$JOB DO
. SET PKGSUB=$QSUBSCRIPT(IDXROOT,4)
. IF PKGSUB'=PKGNME DO
.. NEW IDXRT3
.. SET IDXRT3=$QSUBSCRIPT(IDXROOT,3)
.. IF IDXRT3=PREFIX DO MLTPFX(TMPROOT,PKGSUB,PKGNME,IDXRT3,.ERRARYCT,.FILERPRT)
.. IF (IDXRT3'=PREFIX),(ADDREMPX'[IDXRT3) DO MLTPFX(TMPROOT,PKGSUB,PKGNME,IDXRT3,.ERRARYCT,.FILERPRT)
;
QUIT
;
CHKFILE(PKGNME,FLERNG,TMPROOT,PKGPFX,FSRC) ; Check File range for multiple use
; Input: PKGNME - Package Name using Prefix
; FILRNG - File Range used by Package Name
; TMPROOT - Package "XTVS-PKGEDIT" array root
; PKGPFX - Package Prefix
; FSRC - File Source
; F1 : File Range multiple
; F2 : *LOW/*HIGH fields
; F3 : File List multiple
;
; Output: ^TMP("XTVS-ERROR",$J,"FILERNG") array
;
NEW IDXROOT,STARTSUB,ENDSUB,PKGSUB,ERRARYCT,RNGBEG,RNGEND,PKGRPRT,RNGIND,PARENT,PREFIX
NEW NODETXT,CMBARCT,NDTXTCMB,FTYPE,OPFTCODE,OPFTYPE
SET PKGRPRT=0
SET FTYPE=$S(FSRC="F1":"File Range:",FSRC="F2":"LOW/HIGH range:",FSRC="F3":"File #",1:"")
SET RNGBEG=$P(FLERNG,"-")
SET RNGEND=$P(FLERNG,"-",2)
SET ERRARYCT=+$O(^TMP("XTVS-ERROR",$J,"FILERNG",""),-1)
SET IDXROOT="^TMP(""XTVS-FRIDX"","_$J_")"
FOR SET IDXROOT=$QUERY(@IDXROOT) Q:IDXROOT="" Q:$QSUBSCRIPT(IDXROOT,1)'="XTVS-FRIDX" Q:$QSUBSCRIPT(IDXROOT,2)'=$JOB DO
. SET STARTSUB=$QSUBSCRIPT(IDXROOT,3)
. SET ENDSUB=$QSUBSCRIPT(IDXROOT,4)
. SET PKGSUB=$QSUBSCRIPT(IDXROOT,5)
. IF PKGSUB'=PKGNME DO
.. SET RNGIND=$$RNGCHK(RNGBEG,RNGEND,STARTSUB,ENDSUB)
.. IF RNGIND DO
... SET ERRARYCT=ERRARYCT+1
... IF ERRARYCT=1 DO SETFLHDR("FILERNG",.ERRARYCT)
... ;
... SET CMBARCT=+$O(^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",""),-1)
... IF +CMBARCT=0 DO CMBARST(.CMBARCT)
... ;
... IF 'PKGRPRT DO NOPKGRT(TMPROOT,PKGNME,PKGPFX,FTYPE,.ERRARYCT,.CMBARCT,.PKGRPRT) ;Output Package being reported
... SET PREFIX=$O(^TMP("XTVS-PKGEDIT",$J,PKGSUB,""))
... SET PARENT=^TMP("XTVS-PKGEDIT",$J,PKGSUB,PREFIX,"PARENT")
... SET OPFTCODE=@IDXROOT
... SET OPFTYPE=$S(OPFTCODE="FR":"File Range: ",OPFTCODE="LH":"LOW/HIGH range: ",OPFTCODE="FL":"File List number: ",1:"")
... SET NODETXT=" . "_PKGSUB_" ["_OPFTYPE_$S(OPFTCODE="FL":STARTSUB,1:STARTSUB_"-"_ENDSUB)_"]"_$S(PARENT]"":" (Parent: "_PARENT_")",1:"")
... SET NDTXTCMB=NODETXT
... IF ($L(NODETXT)>79),(NODETXT["(Parent") SET NODETXT=$$SPLITNDE(NODETXT,"FILERNG",.ERRARYCT,"(Parent")
... SET ^TMP("XTVS-ERROR",$J,"FILERNG",ERRARYCT)=NODETXT
... SET CMBARCT=CMBARCT+1
... IF ($L(NDTXTCMB)>79),(NDTXTCMB["(Parent") SET NODETXT=$$SPLITNDE(NDTXTCMB,"COMB-PFX-FLRNG",.CMBARCT,"(Parent")
... SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
QUIT
;
MLTPFX(TMPROOT,PKGSUB,PKGNME,SUBPFX,ERRARYCT,FILERPRT) ; Report multiple use of prefix
NEW PARENT,CMBARCT,NODETXT,CMBHDR
SET (CMBHDR,PKGHDOUT)=0
SET PARENT=""
SET ERRARYCT=ERRARYCT+1
IF ERRARYCT=1 DO
. SET ^TMP("XTVS-ERROR",$J,"PREFIX",1)="The Package Prefixes are overlapped by the subsequent package(s) listed:"
. SET ERRARYCT=2
;
SET CMBARCT=+$O(^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",""),-1)
IF +CMBARCT=0 DO CMBARST(.CMBARCT)
;
SET PKGPFX=$O(^TMP("XTVS-PKGEDIT",$J,PKGSUB,""))
;
; IF not printed package header, print header
IF 'FILERPRT DO
. SET ^TMP("XTVS-ERROR",$J,"PREFIX",ERRARYCT)=" "
. SET CMBARCT=CMBARCT+1
. SET ^TMP("XTVS-ERROR",$J,"XTVS-PKGRPT-CMB-IDX",ERRARYCT)=" "
. SET ERRARYCT=ERRARYCT+1
. IF '$D(^TMP("XTVS-PKGRPT-PFX-IDX",$J,PKGNME)) DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$J_",""PREFIX"")",PKGNME,.ERRARYCT)
. IF '$D(^TMP("XTVS-PKGRPT-CMB-IDX",$J,PKGNME)) DO
.. SET CMBARCT=CMBARCT+1
.. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=" "
.. SET CMBARCT=CMBARCT+1
.. DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$J_",""COMB-PFX-FLRNG"")",PKGNME,.CMBARCT)
.. SET CMBHDR=1
. ;
. IF 'CMBHDR DO
.. SET CMBARCT=CMBARCT+1
.. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=" "
. ;
. SET NODETXT=" Prefix: "_PREFIX_" ; intersects the following package prefix assignments..."
. SET ^TMP("XTVS-ERROR",$J,"PREFIX",ERRARYCT)=NODETXT
. SET ERRARYCT=ERRARYCT+1
. SET CMBARCT=CMBARCT+1
. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
. SET FILERPRT=1
SET PARENT=^TMP("XTVS-PKGEDIT",$J,PKGSUB,PKGPFX,"PARENT")
;
SET NODETXT=" . "_PKGSUB_" ["_SUBPFX_"] "_$S(PARENT]"":" (Parent: "_PARENT_")",1:"")
SET CMBARCT=CMBARCT+1
IF ($L(NODETXT)>79),(NODETXT["(Parent") DO
. NEW NDTXTCMB
. SET NDTXTCMB=NODETXT
. SET NODETXT=$$SPLITNDE(NODETXT,"PREFIX",.ERRARYCT,"(Parent")
. SET NODETXT=$$SPLITNDE(NDTXTCMB,"COMB-PFX-FLRNG",.CMBARCT,"(Parent")
SET ^TMP("XTVS-ERROR",$J,"PREFIX",ERRARYCT)=NODETXT
SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
QUIT
;
;
PKGERHDR(TMPROOT,ERRAYRT,PKGNME,ERRARYCT) ; Output Header info for PREFIX and FILE RANGE overlap arrays
NEW PKGPFX
SET:$QSUBSCRIPT(ERRAYRT,3)="PREFIX" ^TMP("XTVS-PKGRPT-PFX-IDX",$J,PKGNME)="" ;Temporary index of Prefix overlap packages reported
SET:$QSUBSCRIPT(ERRAYRT,3)="FILERNG" ^TMP("XTVS-PKGRPT-FRNG-IDX",$J,PKGNME)="" ;Temporary index of File overlap packages reported
SET:$QSUBSCRIPT(ERRAYRT,3)="COMB-PFX-FLRNG" ^TMP("XTVS-PKGRPT-CMB-IDX",$J,PKGNME)="" ;Temporary index of File overlap packages reported
;
SET PKGPFX=$QSUBSCRIPT(TMPROOT,4)
SET @ERRAYRT@(ERRARYCT)=" "
SET ERRARYCT=ERRARYCT+1
SET @ERRAYRT@(ERRARYCT)=" "_PKGNME_" [Primary Prefix: "_PKGPFX_"]"
SET PARENT=@TMPROOT@("PARENT")
SET ERRARYCT=ERRARYCT+1
SET @ERRAYRT@(ERRARYCT)=" Parent: "_$S(PARENT]"":PARENT,1:"None indicated")
SET ERRARYCT=ERRARYCT+1
QUIT
;
CMBARST(CMBARCT) ;Add Header to Combined Prefix and File Range overlap error array
SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",1)="The Package Prefixes are overlapped by the subsequent package(s) listed."
SET CMBARCT=2
DO SETFLHDR("COMB-PFX-FLRNG",.CMBARCT)
QUIT
;
SETFLHDR(NODETYPE,ERRARYCT) ;Set File Header
SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)="The Packages Files overlapping the reported package are listed and identified"
SET ERRARYCT=ERRARYCT+1
SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" by comparing assigned files for the reported package to the overlap package."
SET ERRARYCT=ERRARYCT+1
SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" The VistA Size Report tool uses File assignments to count files in a package."
SET ERRARYCT=ERRARYCT+1
SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" The Parameter File defines file assignments in 'File Ranges', '*Lowest File#'"
SET ERRARYCT=ERRARYCT+1
SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" to '*Highest File#, and 'File Numbers' (List). Only one of these data elements"
SET ERRARYCT=ERRARYCT+1
SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" is used to count files in a package and package file overlap as follows:"
SET ERRARYCT=ERRARYCT+1
SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" 1) File Ranges ; 2) *Low/*High file numbers ; 3) File Numbers (List)"
SET ERRARYCT=ERRARYCT+1
SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" The data element used is indicated in the File Overlap portion of this report."
SET ERRARYCT=ERRARYCT+1
QUIT
;
SPLITNDE(TEXT,NODESUB,ERRARYCT,SPTEXT) ;Split Error Node
NEW SPLITPLC,TXTSLICE,NODETXTG
SET SPLITPLC=$FIND(TEXT,SPTEXT)-$L(SPTEXT)
SET TXTSLICE=$E(TEXT,1,SPLITPLC-1)
SET ^TMP("XTVS-ERROR",$J,NODESUB,ERRARYCT)=TXTSLICE
SET ERRARYCT=ERRARYCT+1
SET NODETXT=" "_$E(TEXT,SPLITPLC,$L(TEXT))
QUIT NODETXT
;
NOPKGRT(TMPROOT,PKGNME,PKGPFX,FTYPE,ERRARYCT,CMBARCT,PKGRPRT) ;Report Package for File section
NEW NODETXT,FLEHDR,NDTXTCMB
SET FLEHDR=0
SET ^TMP("XTVS-ERROR",$J,"FILERNG",ERRARYCT)=" "
SET ERRARYCT=ERRARYCT+1
SET CMBARCT=CMBARCT+1
IF ('$D(^TMP("XTVS-PKGRPT-FRNG-IDX",$J,PKGNME))) DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$J_",""FILERNG"")",PKGNME,.ERRARYCT)
IF ('$D(^TMP("XTVS-PKGRPT-CMB-IDX",$J,PKGNME))) DO
. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=" "
. SET CMBARCT=CMBARCT+1
. DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$J_",""COMB-PFX-FLRNG"")",PKGNME,.CMBARCT)
. SET FLEHDR=1
;
IF 'FLEHDR DO
. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=" "
. SET CMBARCT=CMBARCT+1
;
SET NODETXT=" "_FTYPE_" "_$S(FTYPE="File #":$P(FLERNG,"-"),1:FLERNG)_$S(FTYPE="File #":" (in File List)",1:"")_", assignment intersects the following packages..."
SET NDTXTCMB=NODETXT
SET ERRARYCT=ERRARYCT+1
IF ($L(NODETXT)>79),(NODETXT["intersects") SET NODETXT=$$SPLITNDE(NODETXT,"FILERNG",.ERRARYCT,"intersects")
SET ^TMP("XTVS-ERROR",$J,"FILERNG",ERRARYCT)=NODETXT
SET CMBARCT=CMBARCT+1
IF ($L(NDTXTCMB)>79),(NDTXTCMB["intersects") SET NODETXT=$$SPLITNDE(NDTXTCMB,"COMB-PFX-FLRNG",.CMBARCT,"intersects")
SET ERRARYCT=ERRARYCT+1
SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
SET CMBARCT=CMBARCT+1
;
SET PKGRPRT=1
QUIT
;
RNGCHK(RNGBEG,RNGEND,STARTSUB,ENDSUB) ;Check Package file ranges against Range index
;Input:
; RNGBEG - Package File begin range to check
; RNGEND - Package File end range to check
; STARTSUB - Range Index - Start file Subscript
; ENDSUB - Range Index - End file Subscript
;
;Output:
; 1: Package file number OVERLAPS range
; 0: Package file number out of range
;
NEW INRNG
SET INRNG=0
IF RNGBEG'<STARTSUB,RNGBEG'>ENDSUB SET INRNG=1
IF RNGEND'<STARTSUB,RNGEND'>ENDSUB SET INRNG=1
IF RNGBEG<STARTSUB,RNGEND>ENDSUB SET INRNG=1
IF RNGBEG=STARTSUB,RNGEND=ENDSUB SET INRNG=1
QUIT INRNG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLPR1 13018 printed Dec 13, 2024@02:42:17 Page 2
XTVSLPR1 ;ALBANY FO/GTS - VistA Package Sizing Manager; 18-DEC-2018
+1 ;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;APIs
INCONSCK ;Check for overlaps in Forum Package file data
+1 ;Requires ^TMP("XTVS-PFXIDX",$J,<prefix>,<package name>) & ^TMP("XTVS-FRIDX",$J,<begin file #>,<end file #>,<package name>)
+2 NEW TMPROOT,PKGNME,PREFIX,ADPFXIND,OLDPKG
+3 SET TMPROOT="^TMP(""XTVS-PKGEDIT"","_$JOB_")"
+4 SET OLDPKG=$QSUBSCRIPT($QUERY(@TMPROOT),3)
+5 SET ADPFXIND=0
+6 FOR
SET TMPROOT=$QUERY(@TMPROOT)
if TMPROOT=""
QUIT
if $QSUBSCRIPT(TMPROOT,1)'="XTVS-PKGEDIT"
QUIT
if $QSUBSCRIPT(TMPROOT,2)'=$JOB
QUIT
Begin DoDot:1
+7 SET PKGNME=$QSUBSCRIPT(TMPROOT,3)
+8 SET PREFIX=$QSUBSCRIPT(TMPROOT,4)
+9 ; Execute "If" code when a new package is encountered
+10 IF (OLDPKG'=PKGNME)
Begin DoDot:2
+11 ;1st loop on pkg, check primary prefix
+12 IF ('ADPFXIND)
DO CHKPFX(PKGNME,PREFIX,"^TMP(""XTVS-PKGEDIT"","_$JOB_","""_PKGNME_""","""_PREFIX_""")",PREFIX)
+13 ;Reset the Add Prefix list found indicator after the first pass on the latest package
SET ADPFXIND=0
End DoDot:2
+14 SET OLDPKG=PKGNME
+15 ; Loop fields and data to check Prefix and File ranges
DO FLDDATLP(TMPROOT,PKGNME,PREFIX,.ADPFXIND)
End DoDot:1
+16 KILL ^TMP("XTVS-PKGRPT-PFX-IDX",$JOB),^TMP("XTVS-PKGRPT-FRNG-IDX",$JOB),^TMP("XTVS-PKGRPT-CMB-IDX",$JOB)
+17 QUIT
+18 ;
FLDDATLP(TMPROOT,PKGNME,PREFIX,ADPFXIND) ;Check Fields and Data for 'ADDPFX' and 'FLERNG' Nodes
+1 ; Input: TMPROOT - Package "XTVS-PKGEDIT" array root [^TMP("XTVS-PKGEDIT",$J,PKGNME,PREFIX)]
+2 ; PKGNME - Package Name using Prefix
+3 ; PREFIX - Additional Prefix used by Package
+4 ; ADPFXIND - Indicates that prefix has been checked
+5 ;
+6 NEW FLDSUB,DATASUB,FLERNGFD
+7 ;Set compare file ranges by first found : FILE RANGE, *LOWEST/*HIGHEST, FILE LIST
SET FLERNGFD=0
+8 ;Extract Field Subscript looking for Additional Prefixes and File Ranges
SET FLDSUB=""
+9 FOR
SET FLDSUB=$ORDER(@TMPROOT@(FLDSUB))
if FLDSUB=""
QUIT
Begin DoDot:1
+10 SET DATASUB=""
+11 FOR
SET DATASUB=$ORDER(@TMPROOT@(FLDSUB,DATASUB))
if DATASUB=""
QUIT
Begin DoDot:2
+12 ;NOTE: To change Field Subscript, check different value of FLDSUB
+13 IF FLDSUB="ADDPFX"
DO CHKPFX(PKGNME,DATASUB,TMPROOT,PREFIX)
SET ADPFXIND=1
+14 ;FILE RANGE
IF FLDSUB="F1-FLERNG"
Begin DoDot:3
+15 DO CHKFILE(PKGNME,DATASUB,TMPROOT,PREFIX,"F1")
+16 SET FLERNGFD=1
End DoDot:3
+17 ;*LOWEST - *HIGHEST
IF 'FLERNGFD
IF FLDSUB="F2-BEGFILE"
IF $DATA(@TMPROOT@("F2-ENDFILE"))
Begin DoDot:3
+18 DO CHKFILE(PKGNME,DATASUB,TMPROOT,PREFIX,"F2")
+19 IF $ORDER(@TMPROOT@(FLDSUB,DATASUB))=""
SET FLERNGFD=1
End DoDot:3
+20 ;FILE LIST
IF 'FLERNGFD
IF FLDSUB="F3-FNUM"
Begin DoDot:3
+21 DO CHKFILE(PKGNME,DATASUB,TMPROOT,PREFIX,"F3")
+22 IF $ORDER(@TMPROOT@(FLDSUB,DATASUB))=""
SET FLERNGFD=1
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
CHKPFX(PKGNME,PREFIX,TMPROOT,PKGPFX) ; Check Prefix for multiple use
+1 ; Input: PKGNME - Package Name using Prefix
+2 ; PREFIX - Additional Prefix used by Package
+3 ; TMPROOT - Package "XTVS-PKGEDIT" array root [^TMP("XTVS-PKGEDIT",J,PKGNME,PREFIX)]
+4 ; PKGPFX - Package Prefix
+5 ;
+6 ; Output: ^TMP("XTVS-ERROR",$J,"PREFIX") array
+7 ;
+8 NEW IDXROOT,PKGSUB,ERRARYCT,FILERPRT,ADDREMPX
+9 SET FILERPRT=0
+10 ;Use "PFXIDX" index
SET IDXROOT="^TMP(""XTVS-PFXIDX"","_$JOB_","""_PREFIX_""")"
+11 SET ADDREMPX=@IDXROOT@(PKGNME)
+12 SET ERRARYCT=+$ORDER(^TMP("XTVS-ERROR",$JOB,"PREFIX",""),-1)
+13 FOR
SET IDXROOT=$QUERY(@IDXROOT)
if IDXROOT=""
QUIT
if $QSUBSCRIPT(IDXROOT,1)'="XTVS-PFXIDX"
QUIT
if $QSUBSCRIPT(IDXROOT,3)'[PREFIX
QUIT
if $QSUBSCRIPT(IDXROOT,2)'=$JOB
QUIT
Begin DoDot:1
+14 SET PKGSUB=$QSUBSCRIPT(IDXROOT,4)
+15 IF PKGSUB'=PKGNME
Begin DoDot:2
+16 NEW IDXRT3
+17 SET IDXRT3=$QSUBSCRIPT(IDXROOT,3)
+18 IF IDXRT3=PREFIX
DO MLTPFX(TMPROOT,PKGSUB,PKGNME,IDXRT3,.ERRARYCT,.FILERPRT)
+19 IF (IDXRT3'=PREFIX)
IF (ADDREMPX'[IDXRT3)
DO MLTPFX(TMPROOT,PKGSUB,PKGNME,IDXRT3,.ERRARYCT,.FILERPRT)
End DoDot:2
End DoDot:1
+20 ;
+21 QUIT
+22 ;
CHKFILE(PKGNME,FLERNG,TMPROOT,PKGPFX,FSRC) ; Check File range for multiple use
+1 ; Input: PKGNME - Package Name using Prefix
+2 ; FILRNG - File Range used by Package Name
+3 ; TMPROOT - Package "XTVS-PKGEDIT" array root
+4 ; PKGPFX - Package Prefix
+5 ; FSRC - File Source
+6 ; F1 : File Range multiple
+7 ; F2 : *LOW/*HIGH fields
+8 ; F3 : File List multiple
+9 ;
+10 ; Output: ^TMP("XTVS-ERROR",$J,"FILERNG") array
+11 ;
+12 NEW IDXROOT,STARTSUB,ENDSUB,PKGSUB,ERRARYCT,RNGBEG,RNGEND,PKGRPRT,RNGIND,PARENT,PREFIX
+13 NEW NODETXT,CMBARCT,NDTXTCMB,FTYPE,OPFTCODE,OPFTYPE
+14 SET PKGRPRT=0
+15 SET FTYPE=$SELECT(FSRC="F1":"File Range:",FSRC="F2":"LOW/HIGH range:",FSRC="F3":"File #",1:"")
+16 SET RNGBEG=$PIECE(FLERNG,"-")
+17 SET RNGEND=$PIECE(FLERNG,"-",2)
+18 SET ERRARYCT=+$ORDER(^TMP("XTVS-ERROR",$JOB,"FILERNG",""),-1)
+19 SET IDXROOT="^TMP(""XTVS-FRIDX"","_$JOB_")"
+20 FOR
SET IDXROOT=$QUERY(@IDXROOT)
if IDXROOT=""
QUIT
if $QSUBSCRIPT(IDXROOT,1)'="XTVS-FRIDX"
QUIT
if $QSUBSCRIPT(IDXROOT,2)'=$JOB
QUIT
Begin DoDot:1
+21 SET STARTSUB=$QSUBSCRIPT(IDXROOT,3)
+22 SET ENDSUB=$QSUBSCRIPT(IDXROOT,4)
+23 SET PKGSUB=$QSUBSCRIPT(IDXROOT,5)
+24 IF PKGSUB'=PKGNME
Begin DoDot:2
+25 SET RNGIND=$$RNGCHK(RNGBEG,RNGEND,STARTSUB,ENDSUB)
+26 IF RNGIND
Begin DoDot:3
+27 SET ERRARYCT=ERRARYCT+1
+28 IF ERRARYCT=1
DO SETFLHDR("FILERNG",.ERRARYCT)
+29 ;
+30 SET CMBARCT=+$ORDER(^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",""),-1)
+31 IF +CMBARCT=0
DO CMBARST(.CMBARCT)
+32 ;
+33 ;Output Package being reported
IF 'PKGRPRT
DO NOPKGRT(TMPROOT,PKGNME,PKGPFX,FTYPE,.ERRARYCT,.CMBARCT,.PKGRPRT)
+34 SET PREFIX=$ORDER(^TMP("XTVS-PKGEDIT",$JOB,PKGSUB,""))
+35 SET PARENT=^TMP("XTVS-PKGEDIT",$JOB,PKGSUB,PREFIX,"PARENT")
+36 SET OPFTCODE=@IDXROOT
+37 SET OPFTYPE=$SELECT(OPFTCODE="FR":"File Range: ",OPFTCODE="LH":"LOW/HIGH range: ",OPFTCODE="FL":"File List number: ",1:"")
+38 SET NODETXT=" . "_PKGSUB_" ["_OPFTYPE_$SELECT(OPFTCODE="FL":STARTSUB,1:STARTSUB_"-"_ENDSUB)_"]"_$SELECT(PARENT]"":" (Parent: "_PARENT_")",1:"")
+39 SET NDTXTCMB=NODETXT
+40 IF ($LENGTH(NODETXT)>79)
IF (NODETXT["(Parent")
SET NODETXT=$$SPLITNDE(NODETXT,"FILERNG",.ERRARYCT,"(Parent")
+41 SET ^TMP("XTVS-ERROR",$JOB,"FILERNG",ERRARYCT)=NODETXT
+42 SET CMBARCT=CMBARCT+1
+43 IF ($LENGTH(NDTXTCMB)>79)
IF (NDTXTCMB["(Parent")
SET NODETXT=$$SPLITNDE(NDTXTCMB,"COMB-PFX-FLRNG",.CMBARCT,"(Parent")
+44 SET ^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
End DoDot:3
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
MLTPFX(TMPROOT,PKGSUB,PKGNME,SUBPFX,ERRARYCT,FILERPRT) ; Report multiple use of prefix
+1 NEW PARENT,CMBARCT,NODETXT,CMBHDR
+2 SET (CMBHDR,PKGHDOUT)=0
+3 SET PARENT=""
+4 SET ERRARYCT=ERRARYCT+1
+5 IF ERRARYCT=1
Begin DoDot:1
+6 SET ^TMP("XTVS-ERROR",$JOB,"PREFIX",1)="The Package Prefixes are overlapped by the subsequent package(s) listed:"
+7 SET ERRARYCT=2
End DoDot:1
+8 ;
+9 SET CMBARCT=+$ORDER(^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",""),-1)
+10 IF +CMBARCT=0
DO CMBARST(.CMBARCT)
+11 ;
+12 SET PKGPFX=$ORDER(^TMP("XTVS-PKGEDIT",$JOB,PKGSUB,""))
+13 ;
+14 ; IF not printed package header, print header
+15 IF 'FILERPRT
Begin DoDot:1
+16 SET ^TMP("XTVS-ERROR",$JOB,"PREFIX",ERRARYCT)=" "
+17 SET CMBARCT=CMBARCT+1
+18 SET ^TMP("XTVS-ERROR",$JOB,"XTVS-PKGRPT-CMB-IDX",ERRARYCT)=" "
+19 SET ERRARYCT=ERRARYCT+1
+20 IF '$DATA(^TMP("XTVS-PKGRPT-PFX-IDX",$JOB,PKGNME))
DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$JOB_",""PREFIX"")",PKGNME,.ERRARYCT)
+21 IF '$DATA(^TMP("XTVS-PKGRPT-CMB-IDX",$JOB,PKGNME))
Begin DoDot:2
+22 SET CMBARCT=CMBARCT+1
+23 SET ^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",CMBARCT)=" "
+24 SET CMBARCT=CMBARCT+1
+25 DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$JOB_",""COMB-PFX-FLRNG"")",PKGNME,.CMBARCT)
+26 SET CMBHDR=1
End DoDot:2
+27 ;
+28 IF 'CMBHDR
Begin DoDot:2
+29 SET CMBARCT=CMBARCT+1
+30 SET ^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",CMBARCT)=" "
End DoDot:2
+31 ;
+32 SET NODETXT=" Prefix: "_PREFIX_" ; intersects the following package prefix assignments..."
+33 SET ^TMP("XTVS-ERROR",$JOB,"PREFIX",ERRARYCT)=NODETXT
+34 SET ERRARYCT=ERRARYCT+1
+35 SET CMBARCT=CMBARCT+1
+36 SET ^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
+37 SET FILERPRT=1
End DoDot:1
+38 SET PARENT=^TMP("XTVS-PKGEDIT",$JOB,PKGSUB,PKGPFX,"PARENT")
+39 ;
+40 SET NODETXT=" . "_PKGSUB_" ["_SUBPFX_"] "_$SELECT(PARENT]"":" (Parent: "_PARENT_")",1:"")
+41 SET CMBARCT=CMBARCT+1
+42 IF ($LENGTH(NODETXT)>79)
IF (NODETXT["(Parent")
Begin DoDot:1
+43 NEW NDTXTCMB
+44 SET NDTXTCMB=NODETXT
+45 SET NODETXT=$$SPLITNDE(NODETXT,"PREFIX",.ERRARYCT,"(Parent")
+46 SET NODETXT=$$SPLITNDE(NDTXTCMB,"COMB-PFX-FLRNG",.CMBARCT,"(Parent")
End DoDot:1
+47 SET ^TMP("XTVS-ERROR",$JOB,"PREFIX",ERRARYCT)=NODETXT
+48 SET ^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
+49 QUIT
+50 ;
+51 ;
PKGERHDR(TMPROOT,ERRAYRT,PKGNME,ERRARYCT) ; Output Header info for PREFIX and FILE RANGE overlap arrays
+1 NEW PKGPFX
+2 ;Temporary index of Prefix overlap packages reported
if $QSUBSCRIPT(ERRAYRT,3)="PREFIX"
SET ^TMP("XTVS-PKGRPT-PFX-IDX",$JOB,PKGNME)=""
+3 ;Temporary index of File overlap packages reported
if $QSUBSCRIPT(ERRAYRT,3)="FILERNG"
SET ^TMP("XTVS-PKGRPT-FRNG-IDX",$JOB,PKGNME)=""
+4 ;Temporary index of File overlap packages reported
if $QSUBSCRIPT(ERRAYRT,3)="COMB-PFX-FLRNG"
SET ^TMP("XTVS-PKGRPT-CMB-IDX",$JOB,PKGNME)=""
+5 ;
+6 SET PKGPFX=$QSUBSCRIPT(TMPROOT,4)
+7 SET @ERRAYRT@(ERRARYCT)=" "
+8 SET ERRARYCT=ERRARYCT+1
+9 SET @ERRAYRT@(ERRARYCT)=" "_PKGNME_" [Primary Prefix: "_PKGPFX_"]"
+10 SET PARENT=@TMPROOT@("PARENT")
+11 SET ERRARYCT=ERRARYCT+1
+12 SET @ERRAYRT@(ERRARYCT)=" Parent: "_$SELECT(PARENT]"":PARENT,1:"None indicated")
+13 SET ERRARYCT=ERRARYCT+1
+14 QUIT
+15 ;
CMBARST(CMBARCT) ;Add Header to Combined Prefix and File Range overlap error array
+1 SET ^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",1)="The Package Prefixes are overlapped by the subsequent package(s) listed."
+2 SET CMBARCT=2
+3 DO SETFLHDR("COMB-PFX-FLRNG",.CMBARCT)
+4 QUIT
+5 ;
SETFLHDR(NODETYPE,ERRARYCT) ;Set File Header
+1 SET ^TMP("XTVS-ERROR",$JOB,NODETYPE,ERRARYCT)="The Packages Files overlapping the reported package are listed and identified"
+2 SET ERRARYCT=ERRARYCT+1
+3 SET ^TMP("XTVS-ERROR",$JOB,NODETYPE,ERRARYCT)=" by comparing assigned files for the reported package to the overlap package."
+4 SET ERRARYCT=ERRARYCT+1
+5 SET ^TMP("XTVS-ERROR",$JOB,NODETYPE,ERRARYCT)=" The VistA Size Report tool uses File assignments to count files in a package."
+6 SET ERRARYCT=ERRARYCT+1
+7 SET ^TMP("XTVS-ERROR",$JOB,NODETYPE,ERRARYCT)=" The Parameter File defines file assignments in 'File Ranges', '*Lowest File#'"
+8 SET ERRARYCT=ERRARYCT+1
+9 SET ^TMP("XTVS-ERROR",$JOB,NODETYPE,ERRARYCT)=" to '*Highest File#, and 'File Numbers' (List). Only one of these data elements"
+10 SET ERRARYCT=ERRARYCT+1
+11 SET ^TMP("XTVS-ERROR",$JOB,NODETYPE,ERRARYCT)=" is used to count files in a package and package file overlap as follows:"
+12 SET ERRARYCT=ERRARYCT+1
+13 SET ^TMP("XTVS-ERROR",$JOB,NODETYPE,ERRARYCT)=" 1) File Ranges ; 2) *Low/*High file numbers ; 3) File Numbers (List)"
+14 SET ERRARYCT=ERRARYCT+1
+15 SET ^TMP("XTVS-ERROR",$JOB,NODETYPE,ERRARYCT)=" The data element used is indicated in the File Overlap portion of this report."
+16 SET ERRARYCT=ERRARYCT+1
+17 QUIT
+18 ;
SPLITNDE(TEXT,NODESUB,ERRARYCT,SPTEXT) ;Split Error Node
+1 NEW SPLITPLC,TXTSLICE,NODETXTG
+2 SET SPLITPLC=$FIND(TEXT,SPTEXT)-$LENGTH(SPTEXT)
+3 SET TXTSLICE=$EXTRACT(TEXT,1,SPLITPLC-1)
+4 SET ^TMP("XTVS-ERROR",$JOB,NODESUB,ERRARYCT)=TXTSLICE
+5 SET ERRARYCT=ERRARYCT+1
+6 SET NODETXT=" "_$EXTRACT(TEXT,SPLITPLC,$LENGTH(TEXT))
+7 QUIT NODETXT
+8 ;
NOPKGRT(TMPROOT,PKGNME,PKGPFX,FTYPE,ERRARYCT,CMBARCT,PKGRPRT) ;Report Package for File section
+1 NEW NODETXT,FLEHDR,NDTXTCMB
+2 SET FLEHDR=0
+3 SET ^TMP("XTVS-ERROR",$JOB,"FILERNG",ERRARYCT)=" "
+4 SET ERRARYCT=ERRARYCT+1
+5 SET CMBARCT=CMBARCT+1
+6 IF ('$DATA(^TMP("XTVS-PKGRPT-FRNG-IDX",$JOB,PKGNME)))
DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$JOB_",""FILERNG"")",PKGNME,.ERRARYCT)
+7 IF ('$DATA(^TMP("XTVS-PKGRPT-CMB-IDX",$JOB,PKGNME)))
Begin DoDot:1
+8 SET ^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",CMBARCT)=" "
+9 SET CMBARCT=CMBARCT+1
+10 DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$JOB_",""COMB-PFX-FLRNG"")",PKGNME,.CMBARCT)
+11 SET FLEHDR=1
End DoDot:1
+12 ;
+13 IF 'FLEHDR
Begin DoDot:1
+14 SET ^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",CMBARCT)=" "
+15 SET CMBARCT=CMBARCT+1
End DoDot:1
+16 ;
+17 SET NODETXT=" "_FTYPE_" "_$SELECT(FTYPE="File #":$PIECE(FLERNG,"-"),1:FLERNG)_$SELECT(FTYPE="File #":" (in File List)",1:"")_", assignment intersects the following packages..."
+18 SET NDTXTCMB=NODETXT
+19 SET ERRARYCT=ERRARYCT+1
+20 IF ($LENGTH(NODETXT)>79)
IF (NODETXT["intersects")
SET NODETXT=$$SPLITNDE(NODETXT,"FILERNG",.ERRARYCT,"intersects")
+21 SET ^TMP("XTVS-ERROR",$JOB,"FILERNG",ERRARYCT)=NODETXT
+22 SET CMBARCT=CMBARCT+1
+23 IF ($LENGTH(NDTXTCMB)>79)
IF (NDTXTCMB["intersects")
SET NODETXT=$$SPLITNDE(NDTXTCMB,"COMB-PFX-FLRNG",.CMBARCT,"intersects")
+24 SET ERRARYCT=ERRARYCT+1
+25 SET ^TMP("XTVS-ERROR",$JOB,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
+26 SET CMBARCT=CMBARCT+1
+27 ;
+28 SET PKGRPRT=1
+29 QUIT
+30 ;
RNGCHK(RNGBEG,RNGEND,STARTSUB,ENDSUB) ;Check Package file ranges against Range index
+1 ;Input:
+2 ; RNGBEG - Package File begin range to check
+3 ; RNGEND - Package File end range to check
+4 ; STARTSUB - Range Index - Start file Subscript
+5 ; ENDSUB - Range Index - End file Subscript
+6 ;
+7 ;Output:
+8 ; 1: Package file number OVERLAPS range
+9 ; 0: Package file number out of range
+10 ;
+11 NEW INRNG
+12 SET INRNG=0
+13 IF RNGBEG'<STARTSUB
IF RNGBEG'>ENDSUB
SET INRNG=1
+14 IF RNGEND'<STARTSUB
IF RNGEND'>ENDSUB
SET INRNG=1
+15 IF RNGBEG<STARTSUB
IF RNGEND>ENDSUB
SET INRNG=1
+16 IF RNGBEG=STARTSUB
IF RNGEND=ENDSUB
SET INRNG=1
+17 QUIT INRNG
