XTVSLP ;ALBANY FO/GTS - VistA Package Sizing Manager; 7-JUL-2016
;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point for XTVS PKG MGR PARAM DISPLAY
D EN^VALM("XTVS PKG MGR PARAM DISPLAY")
Q
;
HDR ; -- header code
NEW DEFDIR,SPCPAD,DIRHEAD
SET SPCPAD=""
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
SET VALMHDR(1)=" VistA Package Size Analysis Manager - Parameter Display"
SET VALMHDR(2)=" Version: "_$$VERNUM^XTVSLM()_" Build: "_$$BLDNUM^XTVSLM()
SET DIRHEAD="Default Directory: "_DEFDIR
SET $P(SPCPAD," ",(80-$L(DIRHEAD))/2)=""
SET VALMHDR(3)=SPCPAD_DIRHEAD
SET SPCPAD=""
SET DIRHEAD="Parameter file: "_XTVPSPRM
SET $P(SPCPAD," ",(80-$L(DIRHEAD))/2)=""
SET VALMHDR(4)=SPCPAD_DIRHEAD
DO MSG
QUIT
;
BUILD ; - Build local and global display arrays
NEW DEFDIR,LINEITEM
DO KILL ;Kill all processing & data arrays and video attributes & control arrays
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
DO OPEN^%ZISH("XTMP",DEFDIR,XTVPSPRM,"R")
U IO
SET VALMCNT=0
FOR S LINEITEM="" READ LINEITEM:5 Q:$$STATUS^%ZISH DO
. IF LINEITEM]"" DO
.. DO SCAPARY(LINEITEM) ;Creates ^TMP("XTVS-PARAM-CAP",$J) array
.. DO SPLITADD^XTVSLAPI(.VALMCNT,LINEITEM,1)
.. DO LOADTMP(LINEITEM) ;Store LineItem into ^TMP global & Index
D CLOSE^%ZISH("XTMP")
QUIT
;
INIT ; -- init variables and list array
NEW XTVSXFNM
DO FULL^VALM1
IF (+$G(FIRSTITM)>0),($G(LASTITM)>0) DO
. NEW CHKLKER,LCKCHK,DEFDIR
. SET XTVSXFNM=$$SELXTMP^XTVSLAPI(FIRSTITM,LASTITM)
. IF XTVSXFNM]"" DO
.. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
.. SET XTVPSPRM=XTVSXFNM
.. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM) ;Returns 1 when current process has lock
.. SET CHKLKER=$$REQLOCK^XTVSLAPI(XTVPSPRM) ;Returns 1 when any process has lock
.. IF (+CHKLKER=0)!(+LCKCHK=1) DO
... DO:(+CHKLKER=0) JUSTPAWS^XTVSLAPI($P(CHKLKER,"^",2))
... DO:(+LCKCHK=1) JUSTPAWS^XTVSLAPI(XTVPSPRM_" LOCK already held.")
... DO BUILD
.. IF (+CHKLKER=1),(+LCKCHK'=1) DO
... W !!," <* LOCK request denied! Try again later. *>"
... DO JUSTPAWS^XTVSLAPI($P(CHKLKER,"^",2))
... DO EXIT^XTVSLP S VALMQUIT=""
. IF XTVSXFNM']"" SET VALMQUIT=""
IF ((+$G(FIRSTITM)'>0)&(+$G(LASTITM)'>0))!($G(XTVSXFNM)']"") SET VALMQUIT=""
QUIT
;
HELP ; -- help code
IF $D(X),X'["??" DO
. SET X="?"
. DO DISP^XQORM1 W !
IF $D(X),X["??" DO
. DO CLEAR^VALM1
. DO FULL^VALM1
. WRITE !,"Parameter Display action help..."
. WRITE !,"List specific actions:",!
. DO DISP^XQORM1 W !!
. SET XTQVAR=Y
. IF XTQVAR DO
.. SET XTQVAR=0
.. FOR TXTCT=1:1 SET XTX=$P($T(LPTXT+TXTCT^XTVSHLP1),";",3,99) QUIT:XTX="$END" QUIT:XTQVAR DO
... IF XTX="$PAUSE" DO PAUSE^VALM1 D:Y CLEAR^VALM1 IF 'Y SET XTQVAR=1 QUIT
... W !,$S(XTX["$PAUSE":"",1:XTX)
. W !
S VALMBCK="R"
D MSG
K XTX,Y,TXTCT,XTQVAR
Q
;
EXIT ; -- exit code
NEW DEFDIR,LCKCHK
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
IF $G(XTVPSPRM)]"" SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
DO FULL^VALM1
IF ($P($G(LCKCHK),"^")=1) DO
. NEW UNLKRSLT
. SET UNLKRSLT=$$UNLCKPFL^XTVSLAPI(XTVPSPRM)
. IF ($P(UNLKRSLT,"^")'=1) W !!," <* UNLOCK ERROR. Check LOCK file Integrity. *>"
. DO JUSTPAWS^XTVSLAPI($P(UNLKRSLT,"^",2))
IF (($P($G(LCKCHK),"^")=0)!($P($G(LCKCHK),"^")=-1)),('$D(CHKLKER)) DO JUSTPAWS^XTVSLAPI($P(LCKCHK,"^",2))
;
DO KILL
Q
;
REFRESH ; -- refresh display
DO BUILD
SET VALMBCK="R"
QUIT
;
MSG(TEXT) ; -- set default message
IF $G(TEXT)]"" SET VALMSG=TEXT
IF $G(TEXT)']"" SET VALMSG="Enter ?? for more actions and Help"
QUIT
;
KILL ; - Cleanup local and global display arrays
DO CLEAN^VALM10 ;Kill data and video control arrays
DO KILL^VALM10() ;Kill Video attributes
DO CLNTMPGB
KILL ^TMP("XTVS PKG MAN PARM DISP",$JOB)
KILL DIR,X,Y,DTOUT,DIRUT,DUOUT
QUIT
;
;APIs
LOADTMP(LINEITEM) ;Store LineItem into ^TMP global
;Input : LINEITEM - A single Package lineitem from XTMPSIZE.DAT
;
;Output: ^TMP array in the following form:
; ^TMP("{package name}","{primary prefix}")=LINEITEM [Package line from XTMPSIZE.DAT]
; ^TMP("{package name}","{primary prefix}","ADDPFX","{added prefix}")=""
; ^TMP("{package name}","{primary prefix}","F1-FLERNG","{file range 1}")="" [File # range from LOW-HIGH RANGE multiple]
; ^TMP("{package name}","{primary prefix}","F2-BEGFILE")=file number [Start file #]
; ^TMP("{package name}","{primary prefix}","F2-ENDFILE")=file number [Ending file #]
; ^TMP("{package name}","{primary prefix}","F3-FNUM",{file#})="" [File # from FILE NUMBER multiple]
; ^TMP("{package name}","{primary prefix}","PARENT")=Package [PARENT PACKAGE field]
; ^TMP("{package name}","{primary prefix}","REMPFX","{removed prefix}")=""
;
NEW FSET,BEGFLNUM,ENDFLNUM,PCENUM,FNUM,APFX,APFXLST,FILELIST,PKGNAME,PKGPFX,RPFX,RPFXLST
SET FSET=0
SET PKGNAME=$P(LINEITEM,"^")
SET PKGPFX=$P(LINEITEM,"^",2)
SET BEGFLNUM=$P(LINEITEM,"^",3)
SET ENDFLNUM=$P(LINEITEM,"^",4)
;
;Load package components into ^TMP Global (loop)
SET ^TMP("XTVS-PKGEDIT",$J,PKGNAME,PKGPFX)=LINEITEM ;Define Data node
;
;Define File Range array nodes
SET FILELIST=$P(LINEITEM,"^",8)
;
;File Ranges [1st priority when defined]
IF FILELIST'="" DO
. SET PCENUM=0
. FOR SET PCENUM=PCENUM+1 SET FLERNG=$P(FILELIST,"|",PCENUM) QUIT:FLERNG']"" DO
.. SET ^TMP("XTVS-PKGEDIT",$J,PKGNAME,PKGPFX,"F1-FLERNG",FLERNG)=""
.. DO FILNDX(FLERNG,PKGNAME,"FR",.FSET) ;Set ^TMP("XTVS-FRIDX",$J,<begin file #>,<end file #>,<package name>)=""
;
;*Lowest File # & *Highest File # [2nd priority when defined and File Ranges Not defined]
IF FILELIST="" DO
. IF BEGFLNUM]"",ENDFLNUM]"" DO FILNDX(BEGFLNUM_"-"_ENDFLNUM,PKGNAME,"LH",.FSET) ;Set ^TMP("XTVS-FRIDX",$J,<begin file #>,<end file #>,<package name>)=""
;
;*File List [3rd priority when defined and File Ranges & *Low/*High not defined]
IF $P(LINEITEM,"^",7)'="" DO
. SET FILELIST=$P(LINEITEM,"^",7)
. SET PCENUM=0
. FOR SET PCENUM=PCENUM+1 SET FNUM=$P(FILELIST,"|",PCENUM) QUIT:FNUM']"" DO
.. SET ^TMP("XTVS-PKGEDIT",$J,PKGNAME,PKGPFX,"F3-FNUM",FNUM_"-"_FNUM)="" ;Define File Number array nodes
.. DO:'FSET FILNDX(FNUM_"-"_FNUM,PKGNAME,"FL",FSET) ;Set ^TMP("XTVS-FRIDX",$J,<file #>,<file #>,<package name>)=""
;
;Define Start/End File number array nodes
IF BEGFLNUM]"" SET ^TMP("XTVS-PKGEDIT",$J,PKGNAME,PKGPFX,"F2-BEGFILE",BEGFLNUM_"-"_ENDFLNUM)=BEGFLNUM
IF ENDFLNUM]"" SET ^TMP("XTVS-PKGEDIT",$J,PKGNAME,PKGPFX,"F2-ENDFILE",BEGFLNUM_"-"_ENDFLNUM)=ENDFLNUM
;
;Define Additional & Excepted Prefix Array nodes
SET APFXLST=PKGPFX_"|"_$P(LINEITEM,"^",5)
SET RPFXLST=$P(LINEITEM,"^",6)
SET PCENUM=0
FOR SET PCENUM=PCENUM+1 SET APFX=($P(APFXLST,"|",PCENUM)) QUIT:APFX']"" DO
. SET ^TMP("XTVS-PKGEDIT",$J,PKGNAME,PKGPFX,"ADDPFX",APFX)="" ;Additional Namespace
. DO PFXIDX(APFX,PKGNAME,APFXLST_"^"_RPFXLST) ;Set ^TMP("XTVS-PFXIDX",$J,,<namespace prefix>,<package name>)="" [Additional & Excepted Prefixe Index]
DO:PKGPFX]"" PFXIDX(PKGPFX,PKGNAME,APFXLST_"^"_RPFXLST) ;Set ^TMP("XTVS-PFXIDX",$J,<namespace prefix>,<package name>)="" [Primary Prefix index]
;
SET PCENUM=0
FOR SET PCENUM=PCENUM+1 SET RPFX=($P(RPFXLST,"|",PCENUM)) QUIT:RPFX']"" DO
. SET ^TMP("XTVS-PKGEDIT",$J,PKGNAME,PKGPFX,"REMPFX",RPFX)="" ;Excepted Namespace
;
;Define Parent array node
SET ^TMP("XTVS-PKGEDIT",$J,PKGNAME,PKGPFX,"PARENT")=$P(LINEITEM,"^",9)
;
QUIT
;
;
;"XTVS-FRIDX" USAGE NOTE: Supports File Range Overlap report
; In CHKFILE^XTVSLPR1, loop ^TMP("XTVS-FRIDX,"$J)
; Retrieve Begin/End Range values for "F1-FLERNG" [Subscripts 3 & 4]
; Check File Range of checked package for:
; If RNGEND < "F1-FLERNG" node begin # ...QUIT check
; If RNGBEG > "F1-FLERNG" node end # ...QUIT check
;
; If RNGBEG '< "F1-FLERNG" begin node, check for package name
; If not package name, create a File overlap error node indicating "F1-FLERNG" package, overlapping files and RNG package
; If RNGEND '> "F1-FLERNG" end node, check for package name
; If not package name, create a File overlap error node indicating "F1-FLERNG" package, overlapping files and RNG package
;
FILNDX(FLRNGE,PKGNAME,TYPE,FSET) ; Set File Number Index [^TMP("XTVS-FRIDX",$J)]
;Input: FLRNGE - File Range
; PKGNAME - Package name
; TYPE - Type of File data
; FR : File Range multiple
; LH : *Lowest & *Highest fields
; FL : File List multiple
; FSET - File Data set indicator for ^XTMP("XTVS-FRIDX")
; 0 : Not set
; 1 : Set
;
;Output : File Range Node [^TMP("XTVS-FRIDX",$J,<begin file #>,<end file #>,<package name>)=""]
;
; <begin file #> and <end file #> are defined from the data in the following order:
; 1) Package 'File Range' multiple'
; If Overlap package 'File Range' is not defined, then...
; 2) Package file range defined by '*Lowest File#' & '*Highest File#'
;
NEW BEGFNUM,ENDFNUM
SET BEGFNUM=$P(FLRNGE,"-")
SET ENDFNUM=$P(FLRNGE,"-",2)
SET ^TMP("XTVS-FRIDX",$J,BEGFNUM,ENDFNUM,PKGNAME)=TYPE
SET FSET=1
QUIT
;
;
;"XTVS-PFXIDX" USAGE NOTE: Supports Prefix Overlap report
; In CHKPFX^XTVSLPR1, loop ^TMP("XTVS-PFXIDX",$J,<prefix>,<package name>)
; Extract Primary Prefix (4th subscript) and added Prefixes from "ADDPFX" (6th subscript)
; If <package name> in Array subscript doesn't equal "package name"...
; create a Prefix overlap error node indicating "ADDPFX" package, overlapping prefix and "PFXIDX" package [MLTPFX^XTVSLPR1]
;
PFXIDX(PKGPFX,PKGNAME,PFXLST) ;Set ^TMP("XTVS-PFXIDX",$J,<namespace prefix>,<package name>)=<list of prefixes>
SET PFXLST=$G(PFXLST)
SET ^TMP("XTVS-PFXIDX",$J,PKGPFX,PKGNAME)=PFXLST
QUIT
;
SCAPARY(LINEITEM) ; Set single line Array & caption display array for action processing
NEW PARMDAT,PKG
;
;Set Caption Display Array
SET PKG=$P(LINEITEM,"^")
SET ^TMP("XTVS-PARAM-CAP",$J,PKG)=LINEITEM
SET PARMDAT=$P(LINEITEM,"^")
SET ^TMP("XTVS-PARAM-CAP",$J,PKG,1,"Package Name")=PARMDAT
SET PARMDAT=$P(LINEITEM,"^",2)
SET ^TMP("XTVS-PARAM-CAP",$J,PKG,2,"Primary Prefix")=PARMDAT
SET PARMDAT=$P(LINEITEM,"^",3)
SET ^TMP("XTVS-PARAM-CAP",$J,PKG,3,"*Lowest File#")=PARMDAT
SET PARMDAT=$P(LINEITEM,"^",4)
SET ^TMP("XTVS-PARAM-CAP",$J,PKG,4,"*Highest File#")=PARMDAT
SET PARMDAT=$P(LINEITEM,"^",5)
SET ^TMP("XTVS-PARAM-CAP",$J,PKG,5,"Additional Prefixes")=PARMDAT
SET PARMDAT=$P(LINEITEM,"^",6)
SET ^TMP("XTVS-PARAM-CAP",$J,PKG,6,"Excepted Prefixes")=PARMDAT
SET PARMDAT=$P(LINEITEM,"^",7)
SET ^TMP("XTVS-PARAM-CAP",$J,PKG,7,"File Numbers")=PARMDAT
SET PARMDAT=$P(LINEITEM,"^",8)
SET ^TMP("XTVS-PARAM-CAP",$J,PKG,8,"File Ranges")=PARMDAT
SET PARMDAT=$P(LINEITEM,"^",9)
SET ^TMP("XTVS-PARAM-CAP",$J,PKG,9,"Parent Package")=PARMDAT
QUIT
;
CLNTMPGB ;Kill temporary globals
KILL ^TMP("XTVS-PKGEDIT",$J),^TMP("XTVS-ERROR",$J),^TMP("XTVS-FRIDX",$J),^TMP("XTVS-PFXIDX",$J)
KILL ^TMP("XTVS-PARAM-CAP",$J)
QUIT
;
PRMFLIST(FLESRCH,PAWSOUT) ;List parameter files for selection
NEW DEFDIR,FILENME,FILELIST,LSTRSLT,SELARY,ITEMNUM,XVAL
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
IF $G(FLESRCH)="" SET FLESRCH="XTMPSIZE*"
IF $G(PAWSOUT)="" SET PAWSOUT=" There are no XTMPSIZE files for comparison!"
SET FILENME(FLESRCH)=""
SET LSTRSLT=$$LIST^%ZISH(DEFDIR,"FILENME","FILELIST")
SET FILENME=""
IF LSTRSLT DO
.; Move XTMPSIZE files to SELARY
.SET ITEMNUM=0
.FOR SET FILENME=$O(FILELIST(FILENME)) Q:FILENME="" DO
..IF (FLESRCH'[".LCK"),(FILENME'[".LCK") SET ITEMNUM=ITEMNUM+1 SET SELARY(ITEMNUM)=FILENME ;Parameter list
..IF (FLESRCH[".LCK") SET ITEMNUM=ITEMNUM+1 SET SELARY(ITEMNUM)=FILENME ; Lock list
.;
.IF ITEMNUM>0 DO
.. NEW PARAMSTR,QSTHLP1
.. IF FLESRCH'[".LCK" DO
... SET QSTHLP1=" Enter the name or number (1-"_ITEMNUM_") of the desired parameter file to compare."
... SET PARAMSTR("MINLNG")=10
..;
.. IF FLESRCH[".LCK" DO
... DO LISTOUT^XTVSLAPI(.SELARY)
... SET QSTHLP1=" Enter the name or number (1-"_ITEMNUM_") LOCK to release."
... SET PARAMSTR("MINLNG")=8
..;
.. SET PARAMSTR("PATRN")="1""XTMPSIZE"".ANP"
.. SET PARAMSTR("DEFANS")=""
.. SET PARAMSTR("MAXLNG")=30
.. SET PARAMSTR("ADDITM")=0
.. SET XVAL=+$$SELITEM(QSTHLP1,.ITEMNUM,.SELARY,.PARAMSTR)
.. ;
..IF (+$G(XVAL)>0)&(+$G(XVAL)<(ITEMNUM+1)) SET FILENME=SELARY(XVAL) W " ",FILENME
..IF ITEMNUM'>0 DO JUSTPAWS^XTVSLAPI(PAWSOUT)
;
IF 'LSTRSLT DO JUSTPAWS^XTVSLAPI(PAWSOUT)
QUIT FILENME
;
SELITEM(QSTHLP1,ITEMNUM,SELARY,PARAMSTR) ; Select Package Parameter file from SELARY
; INPUT: QSTHLP1 - Help string for 1 question mark help [Optional]
; ITEMNUM - Number of items in SELARY
; SELARY - Array of Package Parameter files
; PARAMSTR - Array of string parameters as follows:
; PARAMSTR("ADDITM") - 0: Adding item to SELARY NOT Allowed; 1: Adding unique item to SELARY Allowed 1^1: Add duplicates allowed
; PARAMSTR("DEFANS") - Only pertains to Package selection. Not Null: Last selected Package
; PARAMSTR("MAXLNG") - Maximum length of entered string [default 30, or 10 more than MINLNG when MINLNG>MAXLNG]
; PARAMSTR("MINLNG") - Minumum length of entered string [default 10] - DEV NOTE: MINLNG must be > or = #Chars in PATRN begin & end strings
; PARAMSTR("PATRN") - Pattern match definition for text [default .ANP)
; PARAMSTR("XTUPCASE") - 0: case matters, 1: All item text translated to upper case [default]
;
;
; OUTPUT: Y - Item # for selected Parameter file
;
NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,MINLG,MAXLG,ADDITEM,DEFANS
IF +$G(PARAMSTR("ADDITM"))=0 SET ADDITEM=0 ;Default - No adding items
IF +$G(PARAMSTR("ADDITM"))>0 SET ADDITEM=+$G(PARAMSTR("ADDITM"))
IF $G(PARAMSTR("XTUPCASE"))="" SET PARAMSTR("XTUPCASE")=1
IF $G(PARAMSTR("PATRN"))="" SET PARAMSTR("PATRN")=".ANP"
SET DEFANS=$G(PARAMSTR("DEFANS"))
SET MINLG=+$G(PARAMSTR("MINLNG"))
SET MAXLG=+$G(PARAMSTR("MAXLNG"))
IF MINLG=0 SET (MINLG,PARAMSTR("MINLNG"))=10
IF (MINLG<30),(MINLG>MAXLG) SET (MAXLG,PARAMSTR("MAXLNG"))=30
IF (MINLG>29),(MINLG>MAXLG) SET PARAMSTR("MAXLNG")=MINLG+10
SET DIR("A")="Select File: "
SET DIR(0)="NAO^1:"_(ITEMNUM+1)_"^K:(X'?.N) X I $D(X),(X>ITEMNUM) K X"
SET DIR("PRE")="D PRECHK^XTVSLP(DEFANS,.X,.SELARY,.ITEMNUM)"
IF '$D(QSTHLP1) DO
. SET DIR("?",1)=" Enter the name or number (1-"_ITEMNUM_") of the desired item."
. IF '$P(ADDITEM,"^",2) SET DIR("?",2)=" Duplicates are not allowed."
. SET DIR("?")=" [Enter '??' for a numbered list of items OR '^' to exit]"
IF $D(QSTHLP1) DO
. SET DIR("?",1)=QSTHLP1
. IF QSTHLP1'["LOCK" DO
.. IF 'ADDITEM SET DIR("?",2)=" New items cannot be added."
.. IF ADDITEM,('$P(ADDITEM,"^",2)) SET DIR("?",2)=" New items can be added but duplicates are not allowed."
. SET DIR("?")=" [Enter '??' for a numbered list of items OR '^' to exit]"
SET DIR("??")="^DO LISTOUT^XTVSLAPI(.SELARY)"
DO ^DIR
QUIT Y
;
PRECHK(DEFANS,X,SELARY,ITEMNUM) ; SELITEM X value DIR("PRE") pre-check
IF X=" ",$G(DEFANS)]"" SET X=DEFANS W " ",X
IF X]"",'$D(DTOUT),$E(X,1)'="^" DO
. IF ((X'?.N)&($E(X,1)'["?")) DO SELLIST^XTVSLPR2(.SELARY,.ITEMNUM,.X,.PARAMSTR)
QUIT
;
PARMMAP ; Map of Parameter data elements
;
;Parameter List data map to Package file (#9.4):
;-----------------------------------------------
; ^ pce 1 : Package Name
; [Source: NAME (#.01)]
; ^ pce 2 : Primary Prefix
; [Source: PREFIX (#1)]
; ^ pce 3 : *Lowest File #
; [Source: *LOWEST FILE NUMBER (#10.6)]
; ^ pce 4 : *Highest File #
; [Source: *HIGHEST FILE NUMBER (#11)]
; ^ pce 5 : Pipe character (|) delimited list of Additional Prefixes
; [Source: ADDITIONAL PREFIXES multiple (#14)]
; ^ pce 6 : Pipe character (|) delimited list of Excepted Prefixes
; [Source: EXCLUDED NAME SPACE multiple (#919)]
; ^ pce 7 : Pipe character (|) delimited list of File Number entries
; [Source: FILE NUMBER multiple (#15001)]
; ^ pce 8 : Pipe character (|) delimited list of File Range entries
; [Source: LOW-HIGH RANGE multiple (#15001.1)]
; ^ pce 9 : Parent Package
; [Source: PARENT PACKAGE field (#15003)]
;
;$END
;
;PROTOCOL entry points
;
PKGERR ; -- Package Parameter Errors
; -- Protocol: XTVS PKG MGR PARAM ERR DISP ACTION
DO EN^XTVSLPER
DO REFRESH
DO MSG
QUIT
;
PARAMRPT ; -- Package Parameter Caption list
; -- Protocol: XTVS PKG MGR PARAM DISP CAPTION ACTION
NEW LCKCHK
DO EN^XTVSLPDC
SET LCKCHK=$$CHKPID^XTVSLAPI($$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I"),XTVPSPRM)
IF $P(LCKCHK,"^")=1 DO
. DO REFRESH
. DO MSG
IF $P(LCKCHK,"^")'=1 S VALMQUIT=""
QUIT
;
PARAMAP ; -- Display Data Map for Parameter File
; -- Protocol: XTVS PKG MGR PARAM DATA MAP HELP ACTION
NEW HLPTEXT,LNENUM
DO FULL^VALM1
FOR LNENUM=1:1 SET HLPTEXT=$P($TEXT(PARMMAP+LNENUM),";",2) Q:HLPTEXT="$END" W !,HLPTEXT
DO JUSTPAWS^XTVSLAPI
;
DO REFRESH
DO MSG
QUIT
;
PARAMCMP ; -- Package Parameter Comparison report
; -- Protocol: XTVS PKG MGR PARAM COMPARE ACTION
NEW CMPRFNME
DO FULL^VALM1
SET CMPRFNME=$$PRMFLIST^XTVSLP() ;Select a File to compare
IF CMPRFNME["XTMPSIZE" DO
. DO EN^XTVSLPC(CMPRFNME)
IF CMPRFNME'["XTMPSIZE" DO JUSTPAWS^XTVSLAPI("Comparison XTMPSIZE.DAT file NOT selected!")
DO REFRESH
DO MSG
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLP 17958 printed Dec 13, 2024@02:42:11 Page 2
XTVSLP ;ALBANY FO/GTS - VistA Package Sizing Manager; 7-JUL-2016
+1 ;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point for XTVS PKG MGR PARAM DISPLAY
+1 DO EN^VALM("XTVS PKG MGR PARAM DISPLAY")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW DEFDIR,SPCPAD,DIRHEAD
+2 SET SPCPAD=""
+3 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+4 SET VALMHDR(1)=" VistA Package Size Analysis Manager - Parameter Display"
+5 SET VALMHDR(2)=" Version: "_$$VERNUM^XTVSLM()_" Build: "_$$BLDNUM^XTVSLM()
+6 SET DIRHEAD="Default Directory: "_DEFDIR
+7 SET $PIECE(SPCPAD," ",(80-$LENGTH(DIRHEAD))/2)=""
+8 SET VALMHDR(3)=SPCPAD_DIRHEAD
+9 SET SPCPAD=""
+10 SET DIRHEAD="Parameter file: "_XTVPSPRM
+11 SET $PIECE(SPCPAD," ",(80-$LENGTH(DIRHEAD))/2)=""
+12 SET VALMHDR(4)=SPCPAD_DIRHEAD
+13 DO MSG
+14 QUIT
+15 ;
BUILD ; - Build local and global display arrays
+1 NEW DEFDIR,LINEITEM
+2 ;Kill all processing & data arrays and video attributes & control arrays
DO KILL
+3 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+4 DO OPEN^%ZISH("XTMP",DEFDIR,XTVPSPRM,"R")
+5 USE IO
+6 SET VALMCNT=0
+7 FOR
SET LINEITEM=""
READ LINEITEM:5
if $$STATUS^%ZISH
QUIT
Begin DoDot:1
+8 IF LINEITEM]""
Begin DoDot:2
+9 ;Creates ^TMP("XTVS-PARAM-CAP",$J) array
DO SCAPARY(LINEITEM)
+10 DO SPLITADD^XTVSLAPI(.VALMCNT,LINEITEM,1)
+11 ;Store LineItem into ^TMP global & Index
DO LOADTMP(LINEITEM)
End DoDot:2
End DoDot:1
+12 DO CLOSE^%ZISH("XTMP")
+13 QUIT
+14 ;
INIT ; -- init variables and list array
+1 NEW XTVSXFNM
+2 DO FULL^VALM1
+3 IF (+$GET(FIRSTITM)>0)
IF ($GET(LASTITM)>0)
Begin DoDot:1
+4 NEW CHKLKER,LCKCHK,DEFDIR
+5 SET XTVSXFNM=$$SELXTMP^XTVSLAPI(FIRSTITM,LASTITM)
+6 IF XTVSXFNM]""
Begin DoDot:2
+7 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+8 SET XTVPSPRM=XTVSXFNM
+9 ;Returns 1 when current process has lock
SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
+10 ;Returns 1 when any process has lock
SET CHKLKER=$$REQLOCK^XTVSLAPI(XTVPSPRM)
+11 IF (+CHKLKER=0)!(+LCKCHK=1)
Begin DoDot:3
+12 if (+CHKLKER=0)
DO JUSTPAWS^XTVSLAPI($PIECE(CHKLKER,"^",2))
+13 if (+LCKCHK=1)
DO JUSTPAWS^XTVSLAPI(XTVPSPRM_" LOCK already held.")
+14 DO BUILD
End DoDot:3
+15 IF (+CHKLKER=1)
IF (+LCKCHK'=1)
Begin DoDot:3
+16 WRITE !!," <* LOCK request denied! Try again later. *>"
+17 DO JUSTPAWS^XTVSLAPI($PIECE(CHKLKER,"^",2))
+18 DO EXIT^XTVSLP
SET VALMQUIT=""
End DoDot:3
End DoDot:2
+19 IF XTVSXFNM']""
SET VALMQUIT=""
End DoDot:1
+20 IF ((+$GET(FIRSTITM)'>0)&(+$GET(LASTITM)'>0))!($GET(XTVSXFNM)']"")
SET VALMQUIT=""
+21 QUIT
+22 ;
HELP ; -- help code
+1 IF $DATA(X)
IF X'["??"
Begin DoDot:1
+2 SET X="?"
+3 DO DISP^XQORM1
WRITE !
End DoDot:1
+4 IF $DATA(X)
IF X["??"
Begin DoDot:1
+5 DO CLEAR^VALM1
+6 DO FULL^VALM1
+7 WRITE !,"Parameter Display action help..."
+8 WRITE !,"List specific actions:",!
+9 DO DISP^XQORM1
WRITE !!
+10 SET XTQVAR=Y
+11 IF XTQVAR
Begin DoDot:2
+12 SET XTQVAR=0
+13 FOR TXTCT=1:1
SET XTX=$PIECE($TEXT(LPTXT+TXTCT^XTVSHLP1),";",3,99)
if XTX="$END"
QUIT
if XTQVAR
QUIT
Begin DoDot:3
+14 IF XTX="$PAUSE"
DO PAUSE^VALM1
if Y
DO CLEAR^VALM1
IF 'Y
SET XTQVAR=1
QUIT
+15 WRITE !,$SELECT(XTX["$PAUSE":"",1:XTX)
End DoDot:3
End DoDot:2
+16 WRITE !
End DoDot:1
+17 SET VALMBCK="R"
+18 DO MSG
+19 KILL XTX,Y,TXTCT,XTQVAR
+20 QUIT
+21 ;
EXIT ; -- exit code
+1 NEW DEFDIR,LCKCHK
+2 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+3 IF $GET(XTVPSPRM)]""
SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
+4 DO FULL^VALM1
+5 IF ($PIECE($GET(LCKCHK),"^")=1)
Begin DoDot:1
+6 NEW UNLKRSLT
+7 SET UNLKRSLT=$$UNLCKPFL^XTVSLAPI(XTVPSPRM)
+8 IF ($PIECE(UNLKRSLT,"^")'=1)
WRITE !!," <* UNLOCK ERROR. Check LOCK file Integrity. *>"
+9 DO JUSTPAWS^XTVSLAPI($PIECE(UNLKRSLT,"^",2))
End DoDot:1
+10 IF (($PIECE($GET(LCKCHK),"^")=0)!($PIECE($GET(LCKCHK),"^")=-1))
IF ('$DATA(CHKLKER))
DO JUSTPAWS^XTVSLAPI($PIECE(LCKCHK,"^",2))
+11 ;
+12 DO KILL
+13 QUIT
+14 ;
REFRESH ; -- refresh display
+1 DO BUILD
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
MSG(TEXT) ; -- set default message
+1 IF $GET(TEXT)]""
SET VALMSG=TEXT
+2 IF $GET(TEXT)']""
SET VALMSG="Enter ?? for more actions and Help"
+3 QUIT
+4 ;
KILL ; - Cleanup local and global display arrays
+1 ;Kill data and video control arrays
DO CLEAN^VALM10
+2 ;Kill Video attributes
DO KILL^VALM10()
+3 DO CLNTMPGB
+4 KILL ^TMP("XTVS PKG MAN PARM DISP",$JOB)
+5 KILL DIR,X,Y,DTOUT,DIRUT,DUOUT
+6 QUIT
+7 ;
+8 ;APIs
LOADTMP(LINEITEM) ;Store LineItem into ^TMP global
+1 ;Input : LINEITEM - A single Package lineitem from XTMPSIZE.DAT
+2 ;
+3 ;Output: ^TMP array in the following form:
+4 ; ^TMP("{package name}","{primary prefix}")=LINEITEM [Package line from XTMPSIZE.DAT]
+5 ; ^TMP("{package name}","{primary prefix}","ADDPFX","{added prefix}")=""
+6 ; ^TMP("{package name}","{primary prefix}","F1-FLERNG","{file range 1}")="" [File # range from LOW-HIGH RANGE multiple]
+7 ; ^TMP("{package name}","{primary prefix}","F2-BEGFILE")=file number [Start file #]
+8 ; ^TMP("{package name}","{primary prefix}","F2-ENDFILE")=file number [Ending file #]
+9 ; ^TMP("{package name}","{primary prefix}","F3-FNUM",{file#})="" [File # from FILE NUMBER multiple]
+10 ; ^TMP("{package name}","{primary prefix}","PARENT")=Package [PARENT PACKAGE field]
+11 ; ^TMP("{package name}","{primary prefix}","REMPFX","{removed prefix}")=""
+12 ;
+13 NEW FSET,BEGFLNUM,ENDFLNUM,PCENUM,FNUM,APFX,APFXLST,FILELIST,PKGNAME,PKGPFX,RPFX,RPFXLST
+14 SET FSET=0
+15 SET PKGNAME=$PIECE(LINEITEM,"^")
+16 SET PKGPFX=$PIECE(LINEITEM,"^",2)
+17 SET BEGFLNUM=$PIECE(LINEITEM,"^",3)
+18 SET ENDFLNUM=$PIECE(LINEITEM,"^",4)
+19 ;
+20 ;Load package components into ^TMP Global (loop)
+21 ;Define Data node
SET ^TMP("XTVS-PKGEDIT",$JOB,PKGNAME,PKGPFX)=LINEITEM
+22 ;
+23 ;Define File Range array nodes
+24 SET FILELIST=$PIECE(LINEITEM,"^",8)
+25 ;
+26 ;File Ranges [1st priority when defined]
+27 IF FILELIST'=""
Begin DoDot:1
+28 SET PCENUM=0
+29 FOR
SET PCENUM=PCENUM+1
SET FLERNG=$PIECE(FILELIST,"|",PCENUM)
if FLERNG']""
QUIT
Begin DoDot:2
+30 SET ^TMP("XTVS-PKGEDIT",$JOB,PKGNAME,PKGPFX,"F1-FLERNG",FLERNG)=""
+31 ;Set ^TMP("XTVS-FRIDX",$J,<begin file #>,<end file #>,<package name>)=""
DO FILNDX(FLERNG,PKGNAME,"FR",.FSET)
End DoDot:2
End DoDot:1
+32 ;
+33 ;*Lowest File # & *Highest File # [2nd priority when defined and File Ranges Not defined]
+34 IF FILELIST=""
Begin DoDot:1
+35 ;Set ^TMP("XTVS-FRIDX",$J,<begin file #>,<end file #>,<package name>)=""
IF BEGFLNUM]""
IF ENDFLNUM]""
DO FILNDX(BEGFLNUM_"-"_ENDFLNUM,PKGNAME,"LH",.FSET)
End DoDot:1
+36 ;
+37 ;*File List [3rd priority when defined and File Ranges & *Low/*High not defined]
+38 IF $PIECE(LINEITEM,"^",7)'=""
Begin DoDot:1
+39 SET FILELIST=$PIECE(LINEITEM,"^",7)
+40 SET PCENUM=0
+41 FOR
SET PCENUM=PCENUM+1
SET FNUM=$PIECE(FILELIST,"|",PCENUM)
if FNUM']""
QUIT
Begin DoDot:2
+42 ;Define File Number array nodes
SET ^TMP("XTVS-PKGEDIT",$JOB,PKGNAME,PKGPFX,"F3-FNUM",FNUM_"-"_FNUM)=""
+43 ;Set ^TMP("XTVS-FRIDX",$J,<file #>,<file #>,<package name>)=""
if 'FSET
DO FILNDX(FNUM_"-"_FNUM,PKGNAME,"FL",FSET)
End DoDot:2
End DoDot:1
+44 ;
+45 ;Define Start/End File number array nodes
+46 IF BEGFLNUM]""
SET ^TMP("XTVS-PKGEDIT",$JOB,PKGNAME,PKGPFX,"F2-BEGFILE",BEGFLNUM_"-"_ENDFLNUM)=BEGFLNUM
+47 IF ENDFLNUM]""
SET ^TMP("XTVS-PKGEDIT",$JOB,PKGNAME,PKGPFX,"F2-ENDFILE",BEGFLNUM_"-"_ENDFLNUM)=ENDFLNUM
+48 ;
+49 ;Define Additional & Excepted Prefix Array nodes
+50 SET APFXLST=PKGPFX_"|"_$PIECE(LINEITEM,"^",5)
+51 SET RPFXLST=$PIECE(LINEITEM,"^",6)
+52 SET PCENUM=0
+53 FOR
SET PCENUM=PCENUM+1
SET APFX=($PIECE(APFXLST,"|",PCENUM))
if APFX']""
QUIT
Begin DoDot:1
+54 ;Additional Namespace
SET ^TMP("XTVS-PKGEDIT",$JOB,PKGNAME,PKGPFX,"ADDPFX",APFX)=""
+55 ;Set ^TMP("XTVS-PFXIDX",$J,,<namespace prefix>,<package name>)="" [Additional & Excepted Prefixe Index]
DO PFXIDX(APFX,PKGNAME,APFXLST_"^"_RPFXLST)
End DoDot:1
+56 ;Set ^TMP("XTVS-PFXIDX",$J,<namespace prefix>,<package name>)="" [Primary Prefix index]
if PKGPFX]""
DO PFXIDX(PKGPFX,PKGNAME,APFXLST_"^"_RPFXLST)
+57 ;
+58 SET PCENUM=0
+59 FOR
SET PCENUM=PCENUM+1
SET RPFX=($PIECE(RPFXLST,"|",PCENUM))
if RPFX']""
QUIT
Begin DoDot:1
+60 ;Excepted Namespace
SET ^TMP("XTVS-PKGEDIT",$JOB,PKGNAME,PKGPFX,"REMPFX",RPFX)=""
End DoDot:1
+61 ;
+62 ;Define Parent array node
+63 SET ^TMP("XTVS-PKGEDIT",$JOB,PKGNAME,PKGPFX,"PARENT")=$PIECE(LINEITEM,"^",9)
+64 ;
+65 QUIT
+66 ;
+67 ;
+68 ;"XTVS-FRIDX" USAGE NOTE: Supports File Range Overlap report
+69 ; In CHKFILE^XTVSLPR1, loop ^TMP("XTVS-FRIDX,"$J)
+70 ; Retrieve Begin/End Range values for "F1-FLERNG" [Subscripts 3 & 4]
+71 ; Check File Range of checked package for:
+72 ; If RNGEND < "F1-FLERNG" node begin # ...QUIT check
+73 ; If RNGBEG > "F1-FLERNG" node end # ...QUIT check
+74 ;
+75 ; If RNGBEG '< "F1-FLERNG" begin node, check for package name
+76 ; If not package name, create a File overlap error node indicating "F1-FLERNG" package, overlapping files and RNG package
+77 ; If RNGEND '> "F1-FLERNG" end node, check for package name
+78 ; If not package name, create a File overlap error node indicating "F1-FLERNG" package, overlapping files and RNG package
+79 ;
FILNDX(FLRNGE,PKGNAME,TYPE,FSET) ; Set File Number Index [^TMP("XTVS-FRIDX",$J)]
+1 ;Input: FLRNGE - File Range
+2 ; PKGNAME - Package name
+3 ; TYPE - Type of File data
+4 ; FR : File Range multiple
+5 ; LH : *Lowest & *Highest fields
+6 ; FL : File List multiple
+7 ; FSET - File Data set indicator for ^XTMP("XTVS-FRIDX")
+8 ; 0 : Not set
+9 ; 1 : Set
+10 ;
+11 ;Output : File Range Node [^TMP("XTVS-FRIDX",$J,<begin file #>,<end file #>,<package name>)=""]
+12 ;
+13 ; <begin file #> and <end file #> are defined from the data in the following order:
+14 ; 1) Package 'File Range' multiple'
+15 ; If Overlap package 'File Range' is not defined, then...
+16 ; 2) Package file range defined by '*Lowest File#' & '*Highest File#'
+17 ;
+18 NEW BEGFNUM,ENDFNUM
+19 SET BEGFNUM=$PIECE(FLRNGE,"-")
+20 SET ENDFNUM=$PIECE(FLRNGE,"-",2)
+21 SET ^TMP("XTVS-FRIDX",$JOB,BEGFNUM,ENDFNUM,PKGNAME)=TYPE
+22 SET FSET=1
+23 QUIT
+24 ;
+25 ;
+26 ;"XTVS-PFXIDX" USAGE NOTE: Supports Prefix Overlap report
+27 ; In CHKPFX^XTVSLPR1, loop ^TMP("XTVS-PFXIDX",$J,<prefix>,<package name>)
+28 ; Extract Primary Prefix (4th subscript) and added Prefixes from "ADDPFX" (6th subscript)
+29 ; If <package name> in Array subscript doesn't equal "package name"...
+30 ; create a Prefix overlap error node indicating "ADDPFX" package, overlapping prefix and "PFXIDX" package [MLTPFX^XTVSLPR1]
+31 ;
PFXIDX(PKGPFX,PKGNAME,PFXLST) ;Set ^TMP("XTVS-PFXIDX",$J,<namespace prefix>,<package name>)=<list of prefixes>
+1 SET PFXLST=$GET(PFXLST)
+2 SET ^TMP("XTVS-PFXIDX",$JOB,PKGPFX,PKGNAME)=PFXLST
+3 QUIT
+4 ;
SCAPARY(LINEITEM) ; Set single line Array & caption display array for action processing
+1 NEW PARMDAT,PKG
+2 ;
+3 ;Set Caption Display Array
+4 SET PKG=$PIECE(LINEITEM,"^")
+5 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG)=LINEITEM
+6 SET PARMDAT=$PIECE(LINEITEM,"^")
+7 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG,1,"Package Name")=PARMDAT
+8 SET PARMDAT=$PIECE(LINEITEM,"^",2)
+9 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG,2,"Primary Prefix")=PARMDAT
+10 SET PARMDAT=$PIECE(LINEITEM,"^",3)
+11 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG,3,"*Lowest File#")=PARMDAT
+12 SET PARMDAT=$PIECE(LINEITEM,"^",4)
+13 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG,4,"*Highest File#")=PARMDAT
+14 SET PARMDAT=$PIECE(LINEITEM,"^",5)
+15 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG,5,"Additional Prefixes")=PARMDAT
+16 SET PARMDAT=$PIECE(LINEITEM,"^",6)
+17 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG,6,"Excepted Prefixes")=PARMDAT
+18 SET PARMDAT=$PIECE(LINEITEM,"^",7)
+19 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG,7,"File Numbers")=PARMDAT
+20 SET PARMDAT=$PIECE(LINEITEM,"^",8)
+21 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG,8,"File Ranges")=PARMDAT
+22 SET PARMDAT=$PIECE(LINEITEM,"^",9)
+23 SET ^TMP("XTVS-PARAM-CAP",$JOB,PKG,9,"Parent Package")=PARMDAT
+24 QUIT
+25 ;
CLNTMPGB ;Kill temporary globals
+1 KILL ^TMP("XTVS-PKGEDIT",$JOB),^TMP("XTVS-ERROR",$JOB),^TMP("XTVS-FRIDX",$JOB),^TMP("XTVS-PFXIDX",$JOB)
+2 KILL ^TMP("XTVS-PARAM-CAP",$JOB)
+3 QUIT
+4 ;
PRMFLIST(FLESRCH,PAWSOUT) ;List parameter files for selection
+1 NEW DEFDIR,FILENME,FILELIST,LSTRSLT,SELARY,ITEMNUM,XVAL
+2 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+3 IF $GET(FLESRCH)=""
SET FLESRCH="XTMPSIZE*"
+4 IF $GET(PAWSOUT)=""
SET PAWSOUT=" There are no XTMPSIZE files for comparison!"
+5 SET FILENME(FLESRCH)=""
+6 SET LSTRSLT=$$LIST^%ZISH(DEFDIR,"FILENME","FILELIST")
+7 SET FILENME=""
+8 IF LSTRSLT
Begin DoDot:1
+9 ; Move XTMPSIZE files to SELARY
+10 SET ITEMNUM=0
+11 FOR
SET FILENME=$ORDER(FILELIST(FILENME))
if FILENME=""
QUIT
Begin DoDot:2
+12 ;Parameter list
IF (FLESRCH'[".LCK")
IF (FILENME'[".LCK")
SET ITEMNUM=ITEMNUM+1
SET SELARY(ITEMNUM)=FILENME
+13 ; Lock list
IF (FLESRCH[".LCK")
SET ITEMNUM=ITEMNUM+1
SET SELARY(ITEMNUM)=FILENME
End DoDot:2
+14 ;
+15 IF ITEMNUM>0
Begin DoDot:2
+16 NEW PARAMSTR,QSTHLP1
+17 IF FLESRCH'[".LCK"
Begin DoDot:3
+18 SET QSTHLP1=" Enter the name or number (1-"_ITEMNUM_") of the desired parameter file to compare."
+19 SET PARAMSTR("MINLNG")=10
End DoDot:3
+20 ;
+21 IF FLESRCH[".LCK"
Begin DoDot:3
+22 DO LISTOUT^XTVSLAPI(.SELARY)
+23 SET QSTHLP1=" Enter the name or number (1-"_ITEMNUM_") LOCK to release."
+24 SET PARAMSTR("MINLNG")=8
End DoDot:3
+25 ;
+26 SET PARAMSTR("PATRN")="1""XTMPSIZE"".ANP"
+27 SET PARAMSTR("DEFANS")=""
+28 SET PARAMSTR("MAXLNG")=30
+29 SET PARAMSTR("ADDITM")=0
+30 SET XVAL=+$$SELITEM(QSTHLP1,.ITEMNUM,.SELARY,.PARAMSTR)
+31 ;
+32 IF (+$GET(XVAL)>0)&(+$GET(XVAL)<(ITEMNUM+1))
SET FILENME=SELARY(XVAL)
WRITE " ",FILENME
+33 IF ITEMNUM'>0
DO JUSTPAWS^XTVSLAPI(PAWSOUT)
End DoDot:2
End DoDot:1
+34 ;
+35 IF 'LSTRSLT
DO JUSTPAWS^XTVSLAPI(PAWSOUT)
+36 QUIT FILENME
+37 ;
SELITEM(QSTHLP1,ITEMNUM,SELARY,PARAMSTR) ; Select Package Parameter file from SELARY
+1 ; INPUT: QSTHLP1 - Help string for 1 question mark help [Optional]
+2 ; ITEMNUM - Number of items in SELARY
+3 ; SELARY - Array of Package Parameter files
+4 ; PARAMSTR - Array of string parameters as follows:
+5 ; PARAMSTR("ADDITM") - 0: Adding item to SELARY NOT Allowed; 1: Adding unique item to SELARY Allowed 1^1: Add duplicates allowed
+6 ; PARAMSTR("DEFANS") - Only pertains to Package selection. Not Null: Last selected Package
+7 ; PARAMSTR("MAXLNG") - Maximum length of entered string [default 30, or 10 more than MINLNG when MINLNG>MAXLNG]
+8 ; PARAMSTR("MINLNG") - Minumum length of entered string [default 10] - DEV NOTE: MINLNG must be > or = #Chars in PATRN begin & end strings
+9 ; PARAMSTR("PATRN") - Pattern match definition for text [default .ANP)
+10 ; PARAMSTR("XTUPCASE") - 0: case matters, 1: All item text translated to upper case [default]
+11 ;
+12 ;
+13 ; OUTPUT: Y - Item # for selected Parameter file
+14 ;
+15 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,MINLG,MAXLG,ADDITEM,DEFANS
+16 ;Default - No adding items
IF +$GET(PARAMSTR("ADDITM"))=0
SET ADDITEM=0
+17 IF +$GET(PARAMSTR("ADDITM"))>0
SET ADDITEM=+$GET(PARAMSTR("ADDITM"))
+18 IF $GET(PARAMSTR("XTUPCASE"))=""
SET PARAMSTR("XTUPCASE")=1
+19 IF $GET(PARAMSTR("PATRN"))=""
SET PARAMSTR("PATRN")=".ANP"
+20 SET DEFANS=$GET(PARAMSTR("DEFANS"))
+21 SET MINLG=+$GET(PARAMSTR("MINLNG"))
+22 SET MAXLG=+$GET(PARAMSTR("MAXLNG"))
+23 IF MINLG=0
SET (MINLG,PARAMSTR("MINLNG"))=10
+24 IF (MINLG<30)
IF (MINLG>MAXLG)
SET (MAXLG,PARAMSTR("MAXLNG"))=30
+25 IF (MINLG>29)
IF (MINLG>MAXLG)
SET PARAMSTR("MAXLNG")=MINLG+10
+26 SET DIR("A")="Select File: "
+27 SET DIR(0)="NAO^1:"_(ITEMNUM+1)_"^K:(X'?.N) X I $D(X),(X>ITEMNUM) K X"
+28 SET DIR("PRE")="D PRECHK^XTVSLP(DEFANS,.X,.SELARY,.ITEMNUM)"
+29 IF '$DATA(QSTHLP1)
Begin DoDot:1
+30 SET DIR("?",1)=" Enter the name or number (1-"_ITEMNUM_") of the desired item."
+31 IF '$PIECE(ADDITEM,"^",2)
SET DIR("?",2)=" Duplicates are not allowed."
+32 SET DIR("?")=" [Enter '??' for a numbered list of items OR '^' to exit]"
End DoDot:1
+33 IF $DATA(QSTHLP1)
Begin DoDot:1
+34 SET DIR("?",1)=QSTHLP1
+35 IF QSTHLP1'["LOCK"
Begin DoDot:2
+36 IF 'ADDITEM
SET DIR("?",2)=" New items cannot be added."
+37 IF ADDITEM
IF ('$PIECE(ADDITEM,"^",2))
SET DIR("?",2)=" New items can be added but duplicates are not allowed."
End DoDot:2
+38 SET DIR("?")=" [Enter '??' for a numbered list of items OR '^' to exit]"
End DoDot:1
+39 SET DIR("??")="^DO LISTOUT^XTVSLAPI(.SELARY)"
+40 DO ^DIR
+41 QUIT Y
+42 ;
PRECHK(DEFANS,X,SELARY,ITEMNUM) ; SELITEM X value DIR("PRE") pre-check
+1 IF X=" "
IF $GET(DEFANS)]""
SET X=DEFANS
WRITE " ",X
+2 IF X]""
IF '$DATA(DTOUT)
IF $EXTRACT(X,1)'="^"
Begin DoDot:1
+3 IF ((X'?.N)&($EXTRACT(X,1)'["?"))
DO SELLIST^XTVSLPR2(.SELARY,.ITEMNUM,.X,.PARAMSTR)
End DoDot:1
+4 QUIT
+5 ;
PARMMAP ; Map of Parameter data elements
+1 ;
+2 ;Parameter List data map to Package file (#9.4):
+3 ;-----------------------------------------------
+4 ; ^ pce 1 : Package Name
+5 ; [Source: NAME (#.01)]
+6 ; ^ pce 2 : Primary Prefix
+7 ; [Source: PREFIX (#1)]
+8 ; ^ pce 3 : *Lowest File #
+9 ; [Source: *LOWEST FILE NUMBER (#10.6)]
+10 ; ^ pce 4 : *Highest File #
+11 ; [Source: *HIGHEST FILE NUMBER (#11)]
+12 ; ^ pce 5 : Pipe character (|) delimited list of Additional Prefixes
+13 ; [Source: ADDITIONAL PREFIXES multiple (#14)]
+14 ; ^ pce 6 : Pipe character (|) delimited list of Excepted Prefixes
+15 ; [Source: EXCLUDED NAME SPACE multiple (#919)]
+16 ; ^ pce 7 : Pipe character (|) delimited list of File Number entries
+17 ; [Source: FILE NUMBER multiple (#15001)]
+18 ; ^ pce 8 : Pipe character (|) delimited list of File Range entries
+19 ; [Source: LOW-HIGH RANGE multiple (#15001.1)]
+20 ; ^ pce 9 : Parent Package
+21 ; [Source: PARENT PACKAGE field (#15003)]
+22 ;
+23 ;$END
+24 ;
+25 ;PROTOCOL entry points
+26 ;
PKGERR ; -- Package Parameter Errors
+1 ; -- Protocol: XTVS PKG MGR PARAM ERR DISP ACTION
+2 DO EN^XTVSLPER
+3 DO REFRESH
+4 DO MSG
+5 QUIT
+6 ;
PARAMRPT ; -- Package Parameter Caption list
+1 ; -- Protocol: XTVS PKG MGR PARAM DISP CAPTION ACTION
+2 NEW LCKCHK
+3 DO EN^XTVSLPDC
+4 SET LCKCHK=$$CHKPID^XTVSLAPI($$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I"),XTVPSPRM)
+5 IF $PIECE(LCKCHK,"^")=1
Begin DoDot:1
+6 DO REFRESH
+7 DO MSG
End DoDot:1
+8 IF $PIECE(LCKCHK,"^")'=1
SET VALMQUIT=""
+9 QUIT
+10 ;
PARAMAP ; -- Display Data Map for Parameter File
+1 ; -- Protocol: XTVS PKG MGR PARAM DATA MAP HELP ACTION
+2 NEW HLPTEXT,LNENUM
+3 DO FULL^VALM1
+4 FOR LNENUM=1:1
SET HLPTEXT=$PIECE($TEXT(PARMMAP+LNENUM),";",2)
if HLPTEXT="$END"
QUIT
WRITE !,HLPTEXT
+5 DO JUSTPAWS^XTVSLAPI
+6 ;
+7 DO REFRESH
+8 DO MSG
+9 QUIT
+10 ;
PARAMCMP ; -- Package Parameter Comparison report
+1 ; -- Protocol: XTVS PKG MGR PARAM COMPARE ACTION
+2 NEW CMPRFNME
+3 DO FULL^VALM1
+4 ;Select a File to compare
SET CMPRFNME=$$PRMFLIST^XTVSLP()
+5 IF CMPRFNME["XTMPSIZE"
Begin DoDot:1
+6 DO EN^XTVSLPC(CMPRFNME)
End DoDot:1
+7 IF CMPRFNME'["XTMPSIZE"
DO JUSTPAWS^XTVSLAPI("Comparison XTMPSIZE.DAT file NOT selected!")
+8 DO REFRESH
+9 DO MSG
+10 QUIT
