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

XTVSLPR1.m

Go to the documentation of this file.
  1. XTVSLPR1 ;ALBANY FO/GTS - VistA Package Sizing Manager; 18-DEC-2018
  1. ;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;APIs
  1. 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>)
  1. NEW TMPROOT,PKGNME,PREFIX,ADPFXIND,OLDPKG
  1. SET TMPROOT="^TMP(""XTVS-PKGEDIT"","_$J_")"
  1. SET OLDPKG=$QSUBSCRIPT($QUERY(@TMPROOT),3)
  1. SET ADPFXIND=0
  1. FOR SET TMPROOT=$QUERY(@TMPROOT) QUIT:TMPROOT="" Q:$QSUBSCRIPT(TMPROOT,1)'="XTVS-PKGEDIT" Q:$QSUBSCRIPT(TMPROOT,2)'=$JOB DO
  1. . SET PKGNME=$QSUBSCRIPT(TMPROOT,3)
  1. . SET PREFIX=$QSUBSCRIPT(TMPROOT,4)
  1. . ; Execute "If" code when a new package is encountered
  1. . IF (OLDPKG'=PKGNME) DO
  1. .. ;1st loop on pkg, check primary prefix
  1. .. IF ('ADPFXIND) DO CHKPFX(PKGNME,PREFIX,"^TMP(""XTVS-PKGEDIT"","_$J_","""_PKGNME_""","""_PREFIX_""")",PREFIX)
  1. .. SET ADPFXIND=0 ;Reset the Add Prefix list found indicator after the first pass on the latest package
  1. . SET OLDPKG=PKGNME
  1. . DO FLDDATLP(TMPROOT,PKGNME,PREFIX,.ADPFXIND) ; Loop fields and data to check Prefix and File ranges
  1. KILL ^TMP("XTVS-PKGRPT-PFX-IDX",$J),^TMP("XTVS-PKGRPT-FRNG-IDX",$J),^TMP("XTVS-PKGRPT-CMB-IDX",$J)
  1. QUIT
  1. ;
  1. 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)]
  1. ; PKGNME - Package Name using Prefix
  1. ; PREFIX - Additional Prefix used by Package
  1. ; ADPFXIND - Indicates that prefix has been checked
  1. ;
  1. NEW FLDSUB,DATASUB,FLERNGFD
  1. SET FLERNGFD=0 ;Set compare file ranges by first found : FILE RANGE, *LOWEST/*HIGHEST, FILE LIST
  1. SET FLDSUB="" ;Extract Field Subscript looking for Additional Prefixes and File Ranges
  1. FOR SET FLDSUB=$O(@TMPROOT@(FLDSUB)) Q:FLDSUB="" DO
  1. . SET DATASUB=""
  1. . FOR SET DATASUB=$O(@TMPROOT@(FLDSUB,DATASUB)) Q:DATASUB="" DO
  1. .. ;NOTE: To change Field Subscript, check different value of FLDSUB
  1. .. IF FLDSUB="ADDPFX" DO CHKPFX(PKGNME,DATASUB,TMPROOT,PREFIX) SET ADPFXIND=1
  1. .. IF FLDSUB="F1-FLERNG" DO ;FILE RANGE
  1. ... DO CHKFILE(PKGNME,DATASUB,TMPROOT,PREFIX,"F1")
  1. ... SET FLERNGFD=1
  1. .. IF 'FLERNGFD,FLDSUB="F2-BEGFILE",$D(@TMPROOT@("F2-ENDFILE")) DO ;*LOWEST - *HIGHEST
  1. ... DO CHKFILE(PKGNME,DATASUB,TMPROOT,PREFIX,"F2")
  1. ... IF $O(@TMPROOT@(FLDSUB,DATASUB))="" SET FLERNGFD=1
  1. .. IF 'FLERNGFD,FLDSUB="F3-FNUM" DO ;FILE LIST
  1. ... DO CHKFILE(PKGNME,DATASUB,TMPROOT,PREFIX,"F3")
  1. ... IF $O(@TMPROOT@(FLDSUB,DATASUB))="" SET FLERNGFD=1
  1. QUIT
  1. ;
  1. CHKPFX(PKGNME,PREFIX,TMPROOT,PKGPFX) ; Check Prefix for multiple use
  1. ; Input: PKGNME - Package Name using Prefix
  1. ; PREFIX - Additional Prefix used by Package
  1. ; TMPROOT - Package "XTVS-PKGEDIT" array root [^TMP("XTVS-PKGEDIT",J,PKGNME,PREFIX)]
  1. ; PKGPFX - Package Prefix
  1. ;
  1. ; Output: ^TMP("XTVS-ERROR",$J,"PREFIX") array
  1. ;
  1. NEW IDXROOT,PKGSUB,ERRARYCT,FILERPRT,ADDREMPX
  1. SET FILERPRT=0
  1. SET IDXROOT="^TMP(""XTVS-PFXIDX"","_$J_","""_PREFIX_""")" ;Use "PFXIDX" index
  1. SET ADDREMPX=@IDXROOT@(PKGNME)
  1. SET ERRARYCT=+$O(^TMP("XTVS-ERROR",$J,"PREFIX",""),-1)
  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
  1. . SET PKGSUB=$QSUBSCRIPT(IDXROOT,4)
  1. . IF PKGSUB'=PKGNME DO
  1. .. NEW IDXRT3
  1. .. SET IDXRT3=$QSUBSCRIPT(IDXROOT,3)
  1. .. IF IDXRT3=PREFIX DO MLTPFX(TMPROOT,PKGSUB,PKGNME,IDXRT3,.ERRARYCT,.FILERPRT)
  1. .. IF (IDXRT3'=PREFIX),(ADDREMPX'[IDXRT3) DO MLTPFX(TMPROOT,PKGSUB,PKGNME,IDXRT3,.ERRARYCT,.FILERPRT)
  1. ;
  1. QUIT
  1. ;
  1. CHKFILE(PKGNME,FLERNG,TMPROOT,PKGPFX,FSRC) ; Check File range for multiple use
  1. ; Input: PKGNME - Package Name using Prefix
  1. ; FILRNG - File Range used by Package Name
  1. ; TMPROOT - Package "XTVS-PKGEDIT" array root
  1. ; PKGPFX - Package Prefix
  1. ; FSRC - File Source
  1. ; F1 : File Range multiple
  1. ; F2 : *LOW/*HIGH fields
  1. ; F3 : File List multiple
  1. ;
  1. ; Output: ^TMP("XTVS-ERROR",$J,"FILERNG") array
  1. ;
  1. NEW IDXROOT,STARTSUB,ENDSUB,PKGSUB,ERRARYCT,RNGBEG,RNGEND,PKGRPRT,RNGIND,PARENT,PREFIX
  1. NEW NODETXT,CMBARCT,NDTXTCMB,FTYPE,OPFTCODE,OPFTYPE
  1. SET PKGRPRT=0
  1. SET FTYPE=$S(FSRC="F1":"File Range:",FSRC="F2":"LOW/HIGH range:",FSRC="F3":"File #",1:"")
  1. SET RNGBEG=$P(FLERNG,"-")
  1. SET RNGEND=$P(FLERNG,"-",2)
  1. SET ERRARYCT=+$O(^TMP("XTVS-ERROR",$J,"FILERNG",""),-1)
  1. SET IDXROOT="^TMP(""XTVS-FRIDX"","_$J_")"
  1. FOR SET IDXROOT=$QUERY(@IDXROOT) Q:IDXROOT="" Q:$QSUBSCRIPT(IDXROOT,1)'="XTVS-FRIDX" Q:$QSUBSCRIPT(IDXROOT,2)'=$JOB DO
  1. . SET STARTSUB=$QSUBSCRIPT(IDXROOT,3)
  1. . SET ENDSUB=$QSUBSCRIPT(IDXROOT,4)
  1. . SET PKGSUB=$QSUBSCRIPT(IDXROOT,5)
  1. . IF PKGSUB'=PKGNME DO
  1. .. SET RNGIND=$$RNGCHK(RNGBEG,RNGEND,STARTSUB,ENDSUB)
  1. .. IF RNGIND DO
  1. ... SET ERRARYCT=ERRARYCT+1
  1. ... IF ERRARYCT=1 DO SETFLHDR("FILERNG",.ERRARYCT)
  1. ... ;
  1. ... SET CMBARCT=+$O(^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",""),-1)
  1. ... IF +CMBARCT=0 DO CMBARST(.CMBARCT)
  1. ... ;
  1. ... IF 'PKGRPRT DO NOPKGRT(TMPROOT,PKGNME,PKGPFX,FTYPE,.ERRARYCT,.CMBARCT,.PKGRPRT) ;Output Package being reported
  1. ... SET PREFIX=$O(^TMP("XTVS-PKGEDIT",$J,PKGSUB,""))
  1. ... SET PARENT=^TMP("XTVS-PKGEDIT",$J,PKGSUB,PREFIX,"PARENT")
  1. ... SET OPFTCODE=@IDXROOT
  1. ... SET OPFTYPE=$S(OPFTCODE="FR":"File Range: ",OPFTCODE="LH":"LOW/HIGH range: ",OPFTCODE="FL":"File List number: ",1:"")
  1. ... SET NODETXT=" . "_PKGSUB_" ["_OPFTYPE_$S(OPFTCODE="FL":STARTSUB,1:STARTSUB_"-"_ENDSUB)_"]"_$S(PARENT]"":" (Parent: "_PARENT_")",1:"")
  1. ... SET NDTXTCMB=NODETXT
  1. ... IF ($L(NODETXT)>79),(NODETXT["(Parent") SET NODETXT=$$SPLITNDE(NODETXT,"FILERNG",.ERRARYCT,"(Parent")
  1. ... SET ^TMP("XTVS-ERROR",$J,"FILERNG",ERRARYCT)=NODETXT
  1. ... SET CMBARCT=CMBARCT+1
  1. ... IF ($L(NDTXTCMB)>79),(NDTXTCMB["(Parent") SET NODETXT=$$SPLITNDE(NDTXTCMB,"COMB-PFX-FLRNG",.CMBARCT,"(Parent")
  1. ... SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
  1. QUIT
  1. ;
  1. MLTPFX(TMPROOT,PKGSUB,PKGNME,SUBPFX,ERRARYCT,FILERPRT) ; Report multiple use of prefix
  1. NEW PARENT,CMBARCT,NODETXT,CMBHDR
  1. SET (CMBHDR,PKGHDOUT)=0
  1. SET PARENT=""
  1. SET ERRARYCT=ERRARYCT+1
  1. IF ERRARYCT=1 DO
  1. . SET ^TMP("XTVS-ERROR",$J,"PREFIX",1)="The Package Prefixes are overlapped by the subsequent package(s) listed:"
  1. . SET ERRARYCT=2
  1. ;
  1. SET CMBARCT=+$O(^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",""),-1)
  1. IF +CMBARCT=0 DO CMBARST(.CMBARCT)
  1. ;
  1. SET PKGPFX=$O(^TMP("XTVS-PKGEDIT",$J,PKGSUB,""))
  1. ;
  1. ; IF not printed package header, print header
  1. IF 'FILERPRT DO
  1. . SET ^TMP("XTVS-ERROR",$J,"PREFIX",ERRARYCT)=" "
  1. . SET CMBARCT=CMBARCT+1
  1. . SET ^TMP("XTVS-ERROR",$J,"XTVS-PKGRPT-CMB-IDX",ERRARYCT)=" "
  1. . SET ERRARYCT=ERRARYCT+1
  1. . IF '$D(^TMP("XTVS-PKGRPT-PFX-IDX",$J,PKGNME)) DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$J_",""PREFIX"")",PKGNME,.ERRARYCT)
  1. . IF '$D(^TMP("XTVS-PKGRPT-CMB-IDX",$J,PKGNME)) DO
  1. .. SET CMBARCT=CMBARCT+1
  1. .. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=" "
  1. .. SET CMBARCT=CMBARCT+1
  1. .. DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$J_",""COMB-PFX-FLRNG"")",PKGNME,.CMBARCT)
  1. .. SET CMBHDR=1
  1. . ;
  1. . IF 'CMBHDR DO
  1. .. SET CMBARCT=CMBARCT+1
  1. .. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=" "
  1. . ;
  1. . SET NODETXT=" Prefix: "_PREFIX_" ; intersects the following package prefix assignments..."
  1. . SET ^TMP("XTVS-ERROR",$J,"PREFIX",ERRARYCT)=NODETXT
  1. . SET ERRARYCT=ERRARYCT+1
  1. . SET CMBARCT=CMBARCT+1
  1. . SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
  1. . SET FILERPRT=1
  1. SET PARENT=^TMP("XTVS-PKGEDIT",$J,PKGSUB,PKGPFX,"PARENT")
  1. ;
  1. SET NODETXT=" . "_PKGSUB_" ["_SUBPFX_"] "_$S(PARENT]"":" (Parent: "_PARENT_")",1:"")
  1. SET CMBARCT=CMBARCT+1
  1. IF ($L(NODETXT)>79),(NODETXT["(Parent") DO
  1. . NEW NDTXTCMB
  1. . SET NDTXTCMB=NODETXT
  1. . SET NODETXT=$$SPLITNDE(NODETXT,"PREFIX",.ERRARYCT,"(Parent")
  1. . SET NODETXT=$$SPLITNDE(NDTXTCMB,"COMB-PFX-FLRNG",.CMBARCT,"(Parent")
  1. SET ^TMP("XTVS-ERROR",$J,"PREFIX",ERRARYCT)=NODETXT
  1. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
  1. QUIT
  1. ;
  1. ;
  1. PKGERHDR(TMPROOT,ERRAYRT,PKGNME,ERRARYCT) ; Output Header info for PREFIX and FILE RANGE overlap arrays
  1. NEW PKGPFX
  1. SET:$QSUBSCRIPT(ERRAYRT,3)="PREFIX" ^TMP("XTVS-PKGRPT-PFX-IDX",$J,PKGNME)="" ;Temporary index of Prefix overlap packages reported
  1. SET:$QSUBSCRIPT(ERRAYRT,3)="FILERNG" ^TMP("XTVS-PKGRPT-FRNG-IDX",$J,PKGNME)="" ;Temporary index of File overlap packages reported
  1. SET:$QSUBSCRIPT(ERRAYRT,3)="COMB-PFX-FLRNG" ^TMP("XTVS-PKGRPT-CMB-IDX",$J,PKGNME)="" ;Temporary index of File overlap packages reported
  1. ;
  1. SET PKGPFX=$QSUBSCRIPT(TMPROOT,4)
  1. SET @ERRAYRT@(ERRARYCT)=" "
  1. SET ERRARYCT=ERRARYCT+1
  1. SET @ERRAYRT@(ERRARYCT)=" "_PKGNME_" [Primary Prefix: "_PKGPFX_"]"
  1. SET PARENT=@TMPROOT@("PARENT")
  1. SET ERRARYCT=ERRARYCT+1
  1. SET @ERRAYRT@(ERRARYCT)=" Parent: "_$S(PARENT]"":PARENT,1:"None indicated")
  1. SET ERRARYCT=ERRARYCT+1
  1. QUIT
  1. ;
  1. CMBARST(CMBARCT) ;Add Header to Combined Prefix and File Range overlap error array
  1. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",1)="The Package Prefixes are overlapped by the subsequent package(s) listed."
  1. SET CMBARCT=2
  1. DO SETFLHDR("COMB-PFX-FLRNG",.CMBARCT)
  1. QUIT
  1. ;
  1. SETFLHDR(NODETYPE,ERRARYCT) ;Set File Header
  1. SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)="The Packages Files overlapping the reported package are listed and identified"
  1. SET ERRARYCT=ERRARYCT+1
  1. SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" by comparing assigned files for the reported package to the overlap package."
  1. SET ERRARYCT=ERRARYCT+1
  1. SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" The VistA Size Report tool uses File assignments to count files in a package."
  1. SET ERRARYCT=ERRARYCT+1
  1. SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" The Parameter File defines file assignments in 'File Ranges', '*Lowest File#'"
  1. SET ERRARYCT=ERRARYCT+1
  1. SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" to '*Highest File#, and 'File Numbers' (List). Only one of these data elements"
  1. SET ERRARYCT=ERRARYCT+1
  1. SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" is used to count files in a package and package file overlap as follows:"
  1. SET ERRARYCT=ERRARYCT+1
  1. SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" 1) File Ranges ; 2) *Low/*High file numbers ; 3) File Numbers (List)"
  1. SET ERRARYCT=ERRARYCT+1
  1. SET ^TMP("XTVS-ERROR",$J,NODETYPE,ERRARYCT)=" The data element used is indicated in the File Overlap portion of this report."
  1. SET ERRARYCT=ERRARYCT+1
  1. QUIT
  1. ;
  1. SPLITNDE(TEXT,NODESUB,ERRARYCT,SPTEXT) ;Split Error Node
  1. NEW SPLITPLC,TXTSLICE,NODETXTG
  1. SET SPLITPLC=$FIND(TEXT,SPTEXT)-$L(SPTEXT)
  1. SET TXTSLICE=$E(TEXT,1,SPLITPLC-1)
  1. SET ^TMP("XTVS-ERROR",$J,NODESUB,ERRARYCT)=TXTSLICE
  1. SET ERRARYCT=ERRARYCT+1
  1. SET NODETXT=" "_$E(TEXT,SPLITPLC,$L(TEXT))
  1. QUIT NODETXT
  1. ;
  1. NOPKGRT(TMPROOT,PKGNME,PKGPFX,FTYPE,ERRARYCT,CMBARCT,PKGRPRT) ;Report Package for File section
  1. NEW NODETXT,FLEHDR,NDTXTCMB
  1. SET FLEHDR=0
  1. SET ^TMP("XTVS-ERROR",$J,"FILERNG",ERRARYCT)=" "
  1. SET ERRARYCT=ERRARYCT+1
  1. SET CMBARCT=CMBARCT+1
  1. IF ('$D(^TMP("XTVS-PKGRPT-FRNG-IDX",$J,PKGNME))) DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$J_",""FILERNG"")",PKGNME,.ERRARYCT)
  1. IF ('$D(^TMP("XTVS-PKGRPT-CMB-IDX",$J,PKGNME))) DO
  1. . SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=" "
  1. . SET CMBARCT=CMBARCT+1
  1. . DO PKGERHDR(TMPROOT,"^TMP(""XTVS-ERROR"","_$J_",""COMB-PFX-FLRNG"")",PKGNME,.CMBARCT)
  1. . SET FLEHDR=1
  1. ;
  1. IF 'FLEHDR DO
  1. . SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=" "
  1. . SET CMBARCT=CMBARCT+1
  1. ;
  1. SET NODETXT=" "_FTYPE_" "_$S(FTYPE="File #":$P(FLERNG,"-"),1:FLERNG)_$S(FTYPE="File #":" (in File List)",1:"")_", assignment intersects the following packages..."
  1. SET NDTXTCMB=NODETXT
  1. SET ERRARYCT=ERRARYCT+1
  1. IF ($L(NODETXT)>79),(NODETXT["intersects") SET NODETXT=$$SPLITNDE(NODETXT,"FILERNG",.ERRARYCT,"intersects")
  1. SET ^TMP("XTVS-ERROR",$J,"FILERNG",ERRARYCT)=NODETXT
  1. SET CMBARCT=CMBARCT+1
  1. IF ($L(NDTXTCMB)>79),(NDTXTCMB["intersects") SET NODETXT=$$SPLITNDE(NDTXTCMB,"COMB-PFX-FLRNG",.CMBARCT,"intersects")
  1. SET ERRARYCT=ERRARYCT+1
  1. SET ^TMP("XTVS-ERROR",$J,"COMB-PFX-FLRNG",CMBARCT)=NODETXT
  1. SET CMBARCT=CMBARCT+1
  1. ;
  1. SET PKGRPRT=1
  1. QUIT
  1. ;
  1. RNGCHK(RNGBEG,RNGEND,STARTSUB,ENDSUB) ;Check Package file ranges against Range index
  1. ;Input:
  1. ; RNGBEG - Package File begin range to check
  1. ; RNGEND - Package File end range to check
  1. ; STARTSUB - Range Index - Start file Subscript
  1. ; ENDSUB - Range Index - End file Subscript
  1. ;
  1. ;Output:
  1. ; 1: Package file number OVERLAPS range
  1. ; 0: Package file number out of range
  1. ;
  1. NEW INRNG
  1. SET INRNG=0
  1. IF RNGBEG'<STARTSUB,RNGBEG'>ENDSUB SET INRNG=1
  1. IF RNGEND'<STARTSUB,RNGEND'>ENDSUB SET INRNG=1
  1. IF RNGBEG<STARTSUB,RNGEND>ENDSUB SET INRNG=1
  1. IF RNGBEG=STARTSUB,RNGEND=ENDSUB SET INRNG=1
  1. QUIT INRNG