- 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 Feb 19, 2025@00:08:39 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