- 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 Jan 18, 2025@03:43:24 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