XTVSLPDC ;ALBANY FO/GTS - VistA Package Sizing Manager - Caption display; 12-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 CAPTN DISP
NEW CHNGMADE
SET CHNGMADE=0
KILL ^TMP("XTVS-PARAM-BI",$J)
DO EN^VALM("XTVS PKG MGR PARAM CAPTN DISP")
QUIT
;
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 - Captioned List"
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_$S(+$G(CHNGMADE)>0:" {EDITED}",1:"")
SET $P(SPCPAD," ",(80-$L(DIRHEAD))/2)=""
SET VALMHDR(4)=SPCPAD_DIRHEAD
DO MSG
QUIT
;
INIT ; -- init variables and list array
NEW DATAITEM,PRMLNLP,PKG,CAPDAT,LPNM,LNENUM,DEFDIR,FILENAME,LCKCHK
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
IF $P(LCKCHK,"^")=1 DO
. DO KILL
. SET PKG=""
. SET VALMCNT=0
. FOR SET PKG=$O(^TMP("XTVS-PARAM-CAP",$J,PKG)) Q:PKG="" DO
.. SET LNENUM=0
.. SET CAPDAT=""
.. DO ADD^XTVSLAPI(.VALMCNT," ")
.. DO ADD^XTVSLAPI(.VALMCNT," ")
.. FOR SET LNENUM=$O(^TMP("XTVS-PARAM-CAP",$J,PKG,LNENUM)) Q:+LNENUM'>0 DO
... FOR SET CAPDAT=$O(^TMP("XTVS-PARAM-CAP",$J,PKG,LNENUM,CAPDAT)) Q:CAPDAT="" DO
.... SET DATAITEM=^TMP("XTVS-PARAM-CAP",$J,PKG,LNENUM,CAPDAT)
.... DO SPLITADD^XTVSLAPI(.VALMCNT,CAPDAT_": "_DATAITEM)
;
IF ($P(LCKCHK,"^")'=1) SET VALMQUIT="" DO EXIT^XTVSLPDC
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 !,"Captioned List 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(LPDCTXT+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 !
DO HDR,INIT
S VALMBCK="R"
K XTX,Y,TXTCT,XTQVAR
QUIT
;
EXIT ; -- exit code
NEW SVEDT
SET LCKCHK=$$CHKPID^XTVSLAPI($$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I"),XTVPSPRM)
IF $P(LCKCHK,"^")=1 DO
. IF +$G(CHNGMADE)>0 DO
.. DO FULL^VALM1
.. WRITE !,"You have unsaved Package edits in this Parameter file!"
.. SET SVEDT=+$$YNCHK^XTVSLAPI("Do you want to save the Parameter edits before exiting","YES")
.. IF SVEDT DO PKGSAVE
.. IF $G(CHNGMADE)>0 DO JUSTPAWS^XTVSLAPI(" Package edits NOT saved!")
.. IF $G(CHNGMADE)'>0 DO JUSTPAWS^XTVSLAPI(" Package edits saved!")
;
IF ($P(LCKCHK,"^")'=1) DO
. DO FULL^VALM1
. W !!," <* LOCK ERROR. LOCK required to proceed. Check LOCK file Integrity. *>"
. DO JUSTPAWS^XTVSLAPI($P(LCKCHK,"^",2))
;
KILL ^TMP("XTVS-PARAM-BI",$J),LASTSPKG
DO KILL
Q
;
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
KILL ^TMP("XTVS PKG MGR PARAM CAP",$J)
QUIT
;
SELPKG(ADDITM,DELIND) ; Select Package to Edit/Delete from ^TMP("XTVS PKG MGR PARAM CAP",$J)
; INPUT:
; ADDITM : 0 - Do not allow add new package [Default]
; : 1 - Allow add new package
; DELIND : 0 - Called to select a package for add/edit [Default]
; 1 - Called to select a package to delete
;
; Set: 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("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]
;
;
; RETURN - Name of the selected Package
;
NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,MINLG,MAXLG,PARAMSTR,SELARY,ITEMNUM,PKGNME
SET PARAMSTR("ADDITM")=+$G(ADDITM) ;Default - 0 No adding items
SET PARAMSTR("XTUPCASE")=0 ; Case matters
SET PARAMSTR("PATRN")=".ANP"
SET PARAMSTR("MINLNG")=4
SET PARAMSTR("MAXLNG")=50
SET DELIND=+$G(DELIND) ; Default 0 (add/edit)
SET PARAMSTR("DELIND")=DELIND
SET SELARY=""
;
SET ITEMNUM=$$SETSELAY(.SELARY)
SET PARAMSTR("ITEMNUM")=ITEMNUM
;
IF +ITEMNUM=0 DO JUSTPAWS^XTVSLAPI(" No packages to select. Corrupted Package parameter file!") QUIT ;Nothing to select
;
SET DIR("A")="Select Package: "
SET DIR(0)="NAO^1:"_(ITEMNUM+1)_"^K:(X'?.N) X I $D(X),(X>ITEMNUM) K X"
SET DIR("PRE")="D PRECHK^XTVSLPDC(.X,.LASTSPKG,.SELARY,.ITEMNUM,.PARAMSTR)"
IF 'ADDITM,('DELIND) SET DIR("?",2)=" New items cannot be added."
IF ADDITM,('$P(ADDITM,"^",2)) SET DIR("?",2)=" New items can be added but duplicates are not allowed."
SET DIR("?",1)=" Enter the name or number (1-"_ITEMNUM_") of the Package."
SET DIR("?")=" [Enter '??' for a numbered list of items OR '^' to exit]"
SET DIR("??")="^DO LISTOUT^XTVSLAPI(.SELARY)"
DO ^DIR
;
SET PKGNME=$S(+$G(X)>0:SELARY(X),1:0) ; Return 0 if package not selected
IF PKGNME'=0 SET LASTSPKG=PKGNME W " ",PKGNME
;
QUIT PKGNME
;
PRECHK(X,LASTSPKG,SELARY,ITEMNUM,PARAMSTR) ; SELPKG X value DIR("PRE") pre-check
NEW XTVSSAVX,DELIND
SET DELIND=+$G(PARAMSTR("DELIND"))
IF (X=" "),($G(LASTSPKG)]"") SET (XTVSSAVX,X)=LASTSPKG W " ",LASTSPKG
IF (X]""),('$D(DTOUT)),($E(X,1)'="^") DO
. IF (X'?.N),($E(X,1)'["?") DO SELLIST^XTVSLPR2(.SELARY,.ITEMNUM,.X,.PARAMSTR)
IF DELIND,($G(XTVSSAVX)]""),('$D(X)!($D(X)&$G(X)']"")) D SPCPKGCK(XTVSSAVX,ITEMNUM,.SELARY)
QUIT
;
EDITPRM ; Edit parameters for a package
; -- Protocol: XTVS PKG MGR EDIT PACKAGE PARM ACTION
;
;Logic notes:
; Select package name
; Edit package data in ^TMP("XTVS-PARAM-CAP") array
; Redisplay all 'Edited' packages to screen, set "Edit" [CHNGMADE] param to allow Write Edited pkgs action
;
NEW PKGNME,EDITARY,CAPARY,EDPKG,DEFDIR,LCKCHK
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
IF $P(LCKCHK,"^")=1 DO
. DO FULL^VALM1
. SET PKGNME=$$SELPKG(1)
. IF PKGNME'=0 DO
..;
.. IF PKGNME["""" DO ;Assumes that " only in PKGNME via Add New Package (XT*7.3*152)
... SET PKGNME=$REPLACE(PKGNME,"""","''")
... SET LASTSPKG=PKGNME
... DO JUSTPAWS^XTVSLAPI("Quotation marks changed to apostrophes in "_PKGNME_" name.")
..;
.. IF '$D(^TMP("XTVS-PARAM-CAP",$J,PKGNME)) DO SETADD(PKGNME)
.. IF '$D(^TMP("XTVS-PARAM-BI",$J,PKGNME)) DO BEFORIMG^XTVSLPD1(PKGNME)
.. SET CAPARY="^TMP(""XTVS-PARAM-CAP"","_$J_","""_PKGNME_""")"
.. DO EDPKGPRM^XTVSLPD1(PKGNME)
.. SET EDPKG=$$EDCHK^XTVSLPD1(PKGNME)
.. IF EDPKG SET @CAPARY=$$SETSTR^XTVSLPD1(CAPARY) ;Update header
.. IF 'EDPKG KILL ^TMP("XTVS-PARAM-BI",$J,PKGNME)
.. SET CHNGMADE=$E($D(^TMP("XTVS-PARAM-BI",$J)),1,1)
..;
.. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
.. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
.. IF $P(LCKCHK,"^")=1 DO HDR,INIT
.;
. IF PKGNME=0 DO JUSTPAWS^XTVSLAPI(" Package Not Selected.") DO MSG
;
IF $P(LCKCHK,"^")=1 SET VALMBCK="R"
IF $P(LCKCHK,"^")'=1 SET VALMQUIT=""
QUIT
;
DELPMPKG ; Delete parameters from a package
; -- Protocol: XTVS PKG MGR DEL PACKAGE PARM ACTION
;
NEW PKGNME,CAPARY,DELPKG,LCKCHK,DEFDIR
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
IF $P(LCKCHK,"^")=1 DO
. DO FULL^VALM1
. SET PKGNME=$$SELPKG(0,1)
. IF PKGNME'=0 DO
.. SET CAPARY="^TMP(""XTVS-PARAM-CAP"","_$J_","""_PKGNME_""")"
.. WRITE !,"You have chosen to delete the "_PKGNME_" entry"
.. WRITE !," from the "_XTVPSPRM_" Package Parameter file.",!
.. WRITE !,"[If deleted, "_PKGNME_" will not be included"
.. WRITE !," in any VistA Size Report derived from "_XTVPSPRM_"!]",!
.. SET DELPKG=+$$YNCHK^XTVSLAPI("Are you SURE you want to delete the parameters for this package")
.. IF 'DELPKG DO MSG
.. IF DELPKG DO
... IF '$D(^TMP("XTVS-PARAM-BI",$J,PKGNME)) DO BEFORIMG^XTVSLPD1(PKGNME) ; Create BI when delete an existing, unedited package.
... KILL @CAPARY
... IF $D(^TMP("XTVS-PARAM-BI",$J,PKGNME,2,"Primary Prefix")),((^TMP("XTVS-PARAM-BI",$J,PKGNME,2,"Primary Prefix"))="") KILL ^TMP("XTVS-PARAM-BI",$J,PKGNME)
... SET CHNGMADE=$E($D(^TMP("XTVS-PARAM-BI",$J)),1,1)
... DO:$P($$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM),"^")=1 HDR,INIT
.;
. IF PKGNME=0 DO JUSTPAWS^XTVSLAPI(" Package Not Selected.") DO MSG
.;
. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
;
IF $P(LCKCHK,"^")=1 SET VALMBCK="R"
IF $P(LCKCHK,"^")'=1 SET VALMBCK="Q" SET VALMQUIT=""
QUIT
;
SAVPMPKG ; Save Package Parameters file
; -- Protocol: XTVS PKG MGR SAVE PACKAGE PARM ACTION
;
NEW LCKCHK,DEFDIR
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
IF $P(LCKCHK,"^")=1 DO
. DO FULL^VALM1
. IF +$G(CHNGMADE)'>0 DO JUSTPAWS^XTVSLAPI("File Content not edited. No modifications to save!") DO MSG
. IF +$G(CHNGMADE)>0 DO
.. DO PKGSAVE
.. IF $G(CHNGMADE)'>0 DO HDR,INIT
.. IF $G(CHNGMADE)>0 DO MSG
. SET VALMBCK="R"
;
IF $P(LCKCHK,"^")'=1 SET VALMQUIT=""
QUIT
;
PKGSAVE ;Save Package Changes
NEW NOWDT,INITIAL,PKGNME,WNFILE,WOFILE,FILENME,DEFDIR
SET NOWDT=$$FMTE^XLFDT($$NOW^XLFDT,"2M")
SET NOWDT=$TR(NOWDT,"/","-")
SET NOWDT=$TR(NOWDT,"@","_")
SET NOWDT=$TR(NOWDT,":","")
SET INITIAL=$P($G(^VA(200,DUZ,0)),"^",2)
IF INITIAL']"" SET INITIAL="<unk>"
SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
;
SET (WNFILE,WOFILE)=0
SET WNFILE=+$$YNCHK^XTVSLAPI("Do you want to create a new package parameters file")
SET:'WNFILE WOFILE=+$$YNCHK^XTVSLAPI("Do you want to OVERWRITE the existing package parameters file")
IF (WNFILE)!(WOFILE) DO
. NEW DELRSLT
. IF WNFILE SET FILENME="XTMPSIZE"_"_"_INITIAL_NOWDT_".DAT" ;Output a New Parameter file
. ;
. SET DELRSLT=1 ; Initialize DELRSLT (delete Result) variable
. IF WOFILE DO ;Write Old File: FILENME remains the selected/displayed parameter file
.. NEW DELFLE,OLDFNME,CHKLKER
.. SET FILENME=XTVPSPRM
.. IF FILENME[";" SET FILENME=$P(FILENME,";")
.. SET OLDFNME=$P(FILENME,".")_".BAK"
.. SET DELFLE(OLDFNME)="" SET DELRSLT=$$DEL^%ZISH(DEFDIR,$NA(DELFLE)) K DELFLE(OLDFNME) ;Delete current Parameter file
.. SET DELRSLT=$$MV^%ZISH(DEFDIR,XTVPSPRM,DEFDIR,OLDFNME) ;Save current file to "BAK" before overwriting
.. IF DELRSLT SET DELFLE(XTVPSPRM)="" SET DELRSLT=$$DEL^%ZISH(DEFDIR,$NA(DELFLE)) ;Delete current Parameter file
.. SET FILENME=XTVPSPRM
.. DO CRTFLE(DEFDIR,FILENME,WNFILE)
. ;
. ; If file name definitions and copies were completed successfully, create the Parameter file
. IF DELRSLT DO
.. IF WNFILE DO ;Write New File
... SET UNLKRSLT=$$UNLCKPFL^XTVSLAPI(XTVPSPRM)
... IF ($P(UNLKRSLT,"^")'=1) W !!," <* UNLOCK ERROR. Check LOCK file Integrity. *>"
... DO JUSTPAWS^XTVSLAPI($P(UNLKRSLT,"^",2))
... IF ($P(UNLKRSLT,"^")=1) DO CRTFLE(DEFDIR,FILENME,WNFILE)
;
QUIT
;
CRTFLE(DEFDIR,FILENME,WNFILE) ; Update old file/Write New file
NEW POPERR,CHKLKER
SET POPERR=0
DO OPEN^%ZISH("XTMP",DEFDIR,FILENME,"A")
SET:POP POPERR=POP
IF 'POPERR DO
. U IO
. SET PKGNME=""
. FOR SET PKGNME=$O(^TMP("XTVS-PARAM-CAP",$J,PKGNME)) QUIT:PKGNME']"" WRITE !,^TMP("XTVS-PARAM-CAP",$J,PKGNME)
. D CLOSE^%ZISH("XTMP")
. SET XTVPSPRM=FILENME
. SET CHNGMADE=0
. KILL ^TMP("XTVS-PARAM-BI",$J)
. IF WNFILE DO
.. SET CHKLKER=$$REQLOCK^XTVSLAPI(XTVPSPRM)
.. DO JUSTPAWS^XTVSLAPI($P(CHKLKER,"^",2))
QUIT
;
SETADD(X) ; Add a new package to ^TMP("XTVS-PARAM-CAP")
SET ^TMP("XTVS-PARAM-CAP",$J,X)=X ;Create new entry in TMP global
SET ^TMP("XTVS-PARAM-CAP",$J,X,1,"Package Name")=X
SET ^TMP("XTVS-PARAM-CAP",$J,X,2,"Primary Prefix")=""
SET ^TMP("XTVS-PARAM-CAP",$J,X,3,"*Lowest File#")=""
SET ^TMP("XTVS-PARAM-CAP",$J,X,4,"*Highest File#")=""
SET ^TMP("XTVS-PARAM-CAP",$J,X,5,"Additional Prefixes")=""
SET ^TMP("XTVS-PARAM-CAP",$J,X,6,"Excepted Prefixes")=""
SET ^TMP("XTVS-PARAM-CAP",$J,X,7,"File Numbers")=""
SET ^TMP("XTVS-PARAM-CAP",$J,X,8,"File Ranges")=""
SET ^TMP("XTVS-PARAM-CAP",$J,X,9,"Parent Package")=""
QUIT
;
SETSELAY(SELARY) ; Move Package names to SELARY from ^TMP("XTVS-PARAM-CAP") array
NEW ITEMNUM,FILENME
SET FILENME=""
SET ITEMNUM=0
FOR SET FILENME=$O(^TMP("XTVS-PARAM-CAP",$J,FILENME)) Q:FILENME="" DO
. SET ITEMNUM=ITEMNUM+1 SET SELARY(ITEMNUM)=FILENME ;Parameter list
QUIT ITEMNUM
;
SPCPKGCK(XTVSSAVX,ITEMNUM,SELARY) ; Check for existence of the <SPACE> select package in SELARY
NEW SELARYCT
FOR SELARYCT=1:1:ITEMNUM QUIT:(SELARY(SELARYCT)=XTVSSAVX)
IF (+SELARYCT+1)>(+ITEMNUM) W !!,"?? ",XTVSSAVX_" VistA package is undefined."
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLPDC 13838 printed Dec 13, 2024@02:42:15 Page 2
XTVSLPDC ;ALBANY FO/GTS - VistA Package Sizing Manager - Caption display; 12-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 CAPTN DISP
+1 NEW CHNGMADE
+2 SET CHNGMADE=0
+3 KILL ^TMP("XTVS-PARAM-BI",$JOB)
+4 DO EN^VALM("XTVS PKG MGR PARAM CAPTN DISP")
+5 QUIT
+6 ;
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 - Captioned List"
+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_$SELECT(+$GET(CHNGMADE)>0:" {EDITED}",1:"")
+11 SET $PIECE(SPCPAD," ",(80-$LENGTH(DIRHEAD))/2)=""
+12 SET VALMHDR(4)=SPCPAD_DIRHEAD
+13 DO MSG
+14 QUIT
+15 ;
INIT ; -- init variables and list array
+1 NEW DATAITEM,PRMLNLP,PKG,CAPDAT,LPNM,LNENUM,DEFDIR,FILENAME,LCKCHK
+2 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+3 SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
+4 IF $PIECE(LCKCHK,"^")=1
Begin DoDot:1
+5 DO KILL
+6 SET PKG=""
+7 SET VALMCNT=0
+8 FOR
SET PKG=$ORDER(^TMP("XTVS-PARAM-CAP",$JOB,PKG))
if PKG=""
QUIT
Begin DoDot:2
+9 SET LNENUM=0
+10 SET CAPDAT=""
+11 DO ADD^XTVSLAPI(.VALMCNT," ")
+12 DO ADD^XTVSLAPI(.VALMCNT," ")
+13 FOR
SET LNENUM=$ORDER(^TMP("XTVS-PARAM-CAP",$JOB,PKG,LNENUM))
if +LNENUM'>0
QUIT
Begin DoDot:3
+14 FOR
SET CAPDAT=$ORDER(^TMP("XTVS-PARAM-CAP",$JOB,PKG,LNENUM,CAPDAT))
if CAPDAT=""
QUIT
Begin DoDot:4
+15 SET DATAITEM=^TMP("XTVS-PARAM-CAP",$JOB,PKG,LNENUM,CAPDAT)
+16 DO SPLITADD^XTVSLAPI(.VALMCNT,CAPDAT_": "_DATAITEM)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;
+18 IF ($PIECE(LCKCHK,"^")'=1)
SET VALMQUIT=""
DO EXIT^XTVSLPDC
+19 QUIT
+20 ;
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 !,"Captioned List 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(LPDCTXT+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 DO HDR
DO INIT
+18 SET VALMBCK="R"
+19 KILL XTX,Y,TXTCT,XTQVAR
+20 QUIT
+21 ;
EXIT ; -- exit code
+1 NEW SVEDT
+2 SET LCKCHK=$$CHKPID^XTVSLAPI($$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I"),XTVPSPRM)
+3 IF $PIECE(LCKCHK,"^")=1
Begin DoDot:1
+4 IF +$GET(CHNGMADE)>0
Begin DoDot:2
+5 DO FULL^VALM1
+6 WRITE !,"You have unsaved Package edits in this Parameter file!"
+7 SET SVEDT=+$$YNCHK^XTVSLAPI("Do you want to save the Parameter edits before exiting","YES")
+8 IF SVEDT
DO PKGSAVE
+9 IF $GET(CHNGMADE)>0
DO JUSTPAWS^XTVSLAPI(" Package edits NOT saved!")
+10 IF $GET(CHNGMADE)'>0
DO JUSTPAWS^XTVSLAPI(" Package edits saved!")
End DoDot:2
End DoDot:1
+11 ;
+12 IF ($PIECE(LCKCHK,"^")'=1)
Begin DoDot:1
+13 DO FULL^VALM1
+14 WRITE !!," <* LOCK ERROR. LOCK required to proceed. Check LOCK file Integrity. *>"
+15 DO JUSTPAWS^XTVSLAPI($PIECE(LCKCHK,"^",2))
End DoDot:1
+16 ;
+17 KILL ^TMP("XTVS-PARAM-BI",$JOB),LASTSPKG
+18 DO KILL
+19 QUIT
+20 ;
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 KILL ^TMP("XTVS PKG MGR PARAM CAP",$JOB)
+4 QUIT
+5 ;
SELPKG(ADDITM,DELIND) ; Select Package to Edit/Delete from ^TMP("XTVS PKG MGR PARAM CAP",$J)
+1 ; INPUT:
+2 ; ADDITM : 0 - Do not allow add new package [Default]
+3 ; : 1 - Allow add new package
+4 ; DELIND : 0 - Called to select a package for add/edit [Default]
+5 ; 1 - Called to select a package to delete
+6 ;
+7 ; Set: ITEMNUM - Number of items in SELARY
+8 ; SELARY - Array of Package Parameter files
+9 ; PARAMSTR - Array of string parameters as follows:
+10 ; PARAMSTR("ADDITM") - 0: Adding item to SELARY NOT Allowed; 1: Adding unique item to SELARY Allowed 1^1: Add duplicates allowed
+11 ; PARAMSTR("MAXLNG") - Maximum length of entered string [default 30, or 10 more than MINLNG when MINLNG>MAXLNG]
+12 ; PARAMSTR("MINLNG") - Minumum length of entered string [default 10] - DEV NOTE: MINLNG must be > or = #Chars in PATRN begin & end strings
+13 ; PARAMSTR("PATRN") - Pattern match definition for text [default .ANP)
+14 ; PARAMSTR("XTUPCASE") - 0: case matters, 1: All item text translated to upper case [default]
+15 ;
+16 ;
+17 ; RETURN - Name of the selected Package
+18 ;
+19 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,MINLG,MAXLG,PARAMSTR,SELARY,ITEMNUM,PKGNME
+20 ;Default - 0 No adding items
SET PARAMSTR("ADDITM")=+$GET(ADDITM)
+21 ; Case matters
SET PARAMSTR("XTUPCASE")=0
+22 SET PARAMSTR("PATRN")=".ANP"
+23 SET PARAMSTR("MINLNG")=4
+24 SET PARAMSTR("MAXLNG")=50
+25 ; Default 0 (add/edit)
SET DELIND=+$GET(DELIND)
+26 SET PARAMSTR("DELIND")=DELIND
+27 SET SELARY=""
+28 ;
+29 SET ITEMNUM=$$SETSELAY(.SELARY)
+30 SET PARAMSTR("ITEMNUM")=ITEMNUM
+31 ;
+32 ;Nothing to select
IF +ITEMNUM=0
DO JUSTPAWS^XTVSLAPI(" No packages to select. Corrupted Package parameter file!")
QUIT
+33 ;
+34 SET DIR("A")="Select Package: "
+35 SET DIR(0)="NAO^1:"_(ITEMNUM+1)_"^K:(X'?.N) X I $D(X),(X>ITEMNUM) K X"
+36 SET DIR("PRE")="D PRECHK^XTVSLPDC(.X,.LASTSPKG,.SELARY,.ITEMNUM,.PARAMSTR)"
+37 IF 'ADDITM
IF ('DELIND)
SET DIR("?",2)=" New items cannot be added."
+38 IF ADDITM
IF ('$PIECE(ADDITM,"^",2))
SET DIR("?",2)=" New items can be added but duplicates are not allowed."
+39 SET DIR("?",1)=" Enter the name or number (1-"_ITEMNUM_") of the Package."
+40 SET DIR("?")=" [Enter '??' for a numbered list of items OR '^' to exit]"
+41 SET DIR("??")="^DO LISTOUT^XTVSLAPI(.SELARY)"
+42 DO ^DIR
+43 ;
+44 ; Return 0 if package not selected
SET PKGNME=$SELECT(+$GET(X)>0:SELARY(X),1:0)
+45 IF PKGNME'=0
SET LASTSPKG=PKGNME
WRITE " ",PKGNME
+46 ;
+47 QUIT PKGNME
+48 ;
PRECHK(X,LASTSPKG,SELARY,ITEMNUM,PARAMSTR) ; SELPKG X value DIR("PRE") pre-check
+1 NEW XTVSSAVX,DELIND
+2 SET DELIND=+$GET(PARAMSTR("DELIND"))
+3 IF (X=" ")
IF ($GET(LASTSPKG)]"")
SET (XTVSSAVX,X)=LASTSPKG
WRITE " ",LASTSPKG
+4 IF (X]"")
IF ('$DATA(DTOUT))
IF ($EXTRACT(X,1)'="^")
Begin DoDot:1
+5 IF (X'?.N)
IF ($EXTRACT(X,1)'["?")
DO SELLIST^XTVSLPR2(.SELARY,.ITEMNUM,.X,.PARAMSTR)
End DoDot:1
+6 IF DELIND
IF ($GET(XTVSSAVX)]"")
IF ('$DATA(X)!($DATA(X)&$GET(X)']""))
DO SPCPKGCK(XTVSSAVX,ITEMNUM,.SELARY)
+7 QUIT
+8 ;
EDITPRM ; Edit parameters for a package
+1 ; -- Protocol: XTVS PKG MGR EDIT PACKAGE PARM ACTION
+2 ;
+3 ;Logic notes:
+4 ; Select package name
+5 ; Edit package data in ^TMP("XTVS-PARAM-CAP") array
+6 ; Redisplay all 'Edited' packages to screen, set "Edit" [CHNGMADE] param to allow Write Edited pkgs action
+7 ;
+8 NEW PKGNME,EDITARY,CAPARY,EDPKG,DEFDIR,LCKCHK
+9 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+10 SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
+11 IF $PIECE(LCKCHK,"^")=1
Begin DoDot:1
+12 DO FULL^VALM1
+13 SET PKGNME=$$SELPKG(1)
+14 IF PKGNME'=0
Begin DoDot:2
+15 ;
+16 ;Assumes that " only in PKGNME via Add New Package (XT*7.3*152)
IF PKGNME[""""
Begin DoDot:3
+17
*** ERROR ***
SET PKGNME=$REPLACE(PKGNME,"""","''")
+18 SET LASTSPKG=PKGNME
+19 DO JUSTPAWS^XTVSLAPI("Quotation marks changed to apostrophes in "_PKGNME_" name.")
End DoDot:3
+20 ;
+21 IF '$DATA(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME))
DO SETADD(PKGNME)
+22 IF '$DATA(^TMP("XTVS-PARAM-BI",$JOB,PKGNME))
DO BEFORIMG^XTVSLPD1(PKGNME)
+23 SET CAPARY="^TMP(""XTVS-PARAM-CAP"","_$JOB_","""_PKGNME_""")"
+24 DO EDPKGPRM^XTVSLPD1(PKGNME)
+25 SET EDPKG=$$EDCHK^XTVSLPD1(PKGNME)
+26 ;Update header
IF EDPKG
SET @CAPARY=$$SETSTR^XTVSLPD1(CAPARY)
+27 IF 'EDPKG
KILL ^TMP("XTVS-PARAM-BI",$JOB,PKGNME)
+28 SET CHNGMADE=$EXTRACT($DATA(^TMP("XTVS-PARAM-BI",$JOB)),1,1)
+29 ;
+30 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+31 SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
+32 IF $PIECE(LCKCHK,"^")=1
DO HDR
DO INIT
End DoDot:2
+33 ;
+34 IF PKGNME=0
DO JUSTPAWS^XTVSLAPI(" Package Not Selected.")
DO MSG
End DoDot:1
+35 ;
+36 IF $PIECE(LCKCHK,"^")=1
SET VALMBCK="R"
+37 IF $PIECE(LCKCHK,"^")'=1
SET VALMQUIT=""
+38 QUIT
+39 ;
DELPMPKG ; Delete parameters from a package
+1 ; -- Protocol: XTVS PKG MGR DEL PACKAGE PARM ACTION
+2 ;
+3 NEW PKGNME,CAPARY,DELPKG,LCKCHK,DEFDIR
+4 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+5 SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
+6 IF $PIECE(LCKCHK,"^")=1
Begin DoDot:1
+7 DO FULL^VALM1
+8 SET PKGNME=$$SELPKG(0,1)
+9 IF PKGNME'=0
Begin DoDot:2
+10 SET CAPARY="^TMP(""XTVS-PARAM-CAP"","_$JOB_","""_PKGNME_""")"
+11 WRITE !,"You have chosen to delete the "_PKGNME_" entry"
+12 WRITE !," from the "_XTVPSPRM_" Package Parameter file.",!
+13 WRITE !,"[If deleted, "_PKGNME_" will not be included"
+14 WRITE !," in any VistA Size Report derived from "_XTVPSPRM_"!]",!
+15 SET DELPKG=+$$YNCHK^XTVSLAPI("Are you SURE you want to delete the parameters for this package")
+16 IF 'DELPKG
DO MSG
+17 IF DELPKG
Begin DoDot:3
+18 ; Create BI when delete an existing, unedited package.
IF '$DATA(^TMP("XTVS-PARAM-BI",$JOB,PKGNME))
DO BEFORIMG^XTVSLPD1(PKGNME)
+19 KILL @CAPARY
+20 IF $DATA(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,2,"Primary Prefix"))
IF ((^TMP("XTVS-PARAM-BI",$JOB,PKGNME,2,"Primary Prefix"))="")
KILL ^TMP("XTVS-PARAM-BI",$JOB,PKGNME)
+21 SET CHNGMADE=$EXTRACT($DATA(^TMP("XTVS-PARAM-BI",$JOB)),1,1)
+22 if $PIECE($$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM),"^")=1
DO HDR
DO INIT
End DoDot:3
End DoDot:2
+23 ;
+24 IF PKGNME=0
DO JUSTPAWS^XTVSLAPI(" Package Not Selected.")
DO MSG
+25 ;
+26 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+27 SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
End DoDot:1
+28 ;
+29 IF $PIECE(LCKCHK,"^")=1
SET VALMBCK="R"
+30 IF $PIECE(LCKCHK,"^")'=1
SET VALMBCK="Q"
SET VALMQUIT=""
+31 QUIT
+32 ;
SAVPMPKG ; Save Package Parameters file
+1 ; -- Protocol: XTVS PKG MGR SAVE PACKAGE PARM ACTION
+2 ;
+3 NEW LCKCHK,DEFDIR
+4 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+5 SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
+6 IF $PIECE(LCKCHK,"^")=1
Begin DoDot:1
+7 DO FULL^VALM1
+8 IF +$GET(CHNGMADE)'>0
DO JUSTPAWS^XTVSLAPI("File Content not edited. No modifications to save!")
DO MSG
+9 IF +$GET(CHNGMADE)>0
Begin DoDot:2
+10 DO PKGSAVE
+11 IF $GET(CHNGMADE)'>0
DO HDR
DO INIT
+12 IF $GET(CHNGMADE)>0
DO MSG
End DoDot:2
+13 SET VALMBCK="R"
End DoDot:1
+14 ;
+15 IF $PIECE(LCKCHK,"^")'=1
SET VALMQUIT=""
+16 QUIT
+17 ;
PKGSAVE ;Save Package Changes
+1 NEW NOWDT,INITIAL,PKGNME,WNFILE,WOFILE,FILENME,DEFDIR
+2 SET NOWDT=$$FMTE^XLFDT($$NOW^XLFDT,"2M")
+3 SET NOWDT=$TRANSLATE(NOWDT,"/","-")
+4 SET NOWDT=$TRANSLATE(NOWDT,"@","_")
+5 SET NOWDT=$TRANSLATE(NOWDT,":","")
+6 SET INITIAL=$PIECE($GET(^VA(200,DUZ,0)),"^",2)
+7 IF INITIAL']""
SET INITIAL="<unk>"
+8 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+9 ;
+10 SET (WNFILE,WOFILE)=0
+11 SET WNFILE=+$$YNCHK^XTVSLAPI("Do you want to create a new package parameters file")
+12 if 'WNFILE
SET WOFILE=+$$YNCHK^XTVSLAPI("Do you want to OVERWRITE the existing package parameters file")
+13 IF (WNFILE)!(WOFILE)
Begin DoDot:1
+14 NEW DELRSLT
+15 ;Output a New Parameter file
IF WNFILE
SET FILENME="XTMPSIZE"_"_"_INITIAL_NOWDT_".DAT"
+16 ;
+17 ; Initialize DELRSLT (delete Result) variable
SET DELRSLT=1
+18 ;Write Old File: FILENME remains the selected/displayed parameter file
IF WOFILE
Begin DoDot:2
+19 NEW DELFLE,OLDFNME,CHKLKER
+20 SET FILENME=XTVPSPRM
+21 IF FILENME[";"
SET FILENME=$PIECE(FILENME,";")
+22 SET OLDFNME=$PIECE(FILENME,".")_".BAK"
+23 ;Delete current Parameter file
SET DELFLE(OLDFNME)=""
SET DELRSLT=$$DEL^%ZISH(DEFDIR,$NAME(DELFLE))
KILL DELFLE(OLDFNME)
+24 ;Save current file to "BAK" before overwriting
SET DELRSLT=$$MV^%ZISH(DEFDIR,XTVPSPRM,DEFDIR,OLDFNME)
+25 ;Delete current Parameter file
IF DELRSLT
SET DELFLE(XTVPSPRM)=""
SET DELRSLT=$$DEL^%ZISH(DEFDIR,$NAME(DELFLE))
+26 SET FILENME=XTVPSPRM
+27 DO CRTFLE(DEFDIR,FILENME,WNFILE)
End DoDot:2
+28 ;
+29 ; If file name definitions and copies were completed successfully, create the Parameter file
+30 IF DELRSLT
Begin DoDot:2
+31 ;Write New File
IF WNFILE
Begin DoDot:3
+32 SET UNLKRSLT=$$UNLCKPFL^XTVSLAPI(XTVPSPRM)
+33 IF ($PIECE(UNLKRSLT,"^")'=1)
WRITE !!," <* UNLOCK ERROR. Check LOCK file Integrity. *>"
+34 DO JUSTPAWS^XTVSLAPI($PIECE(UNLKRSLT,"^",2))
+35 IF ($PIECE(UNLKRSLT,"^")=1)
DO CRTFLE(DEFDIR,FILENME,WNFILE)
End DoDot:3
End DoDot:2
End DoDot:1
+36 ;
+37 QUIT
+38 ;
CRTFLE(DEFDIR,FILENME,WNFILE) ; Update old file/Write New file
+1 NEW POPERR,CHKLKER
+2 SET POPERR=0
+3 DO OPEN^%ZISH("XTMP",DEFDIR,FILENME,"A")
+4 if POP
SET POPERR=POP
+5 IF 'POPERR
Begin DoDot:1
+6 USE IO
+7 SET PKGNME=""
+8 FOR
SET PKGNME=$ORDER(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME))
if PKGNME']""
QUIT
WRITE !,^TMP("XTVS-PARAM-CAP",$JOB,PKGNME)
+9 DO CLOSE^%ZISH("XTMP")
+10 SET XTVPSPRM=FILENME
+11 SET CHNGMADE=0
+12 KILL ^TMP("XTVS-PARAM-BI",$JOB)
+13 IF WNFILE
Begin DoDot:2
+14 SET CHKLKER=$$REQLOCK^XTVSLAPI(XTVPSPRM)
+15 DO JUSTPAWS^XTVSLAPI($PIECE(CHKLKER,"^",2))
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
SETADD(X) ; Add a new package to ^TMP("XTVS-PARAM-CAP")
+1 ;Create new entry in TMP global
SET ^TMP("XTVS-PARAM-CAP",$JOB,X)=X
+2 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,1,"Package Name")=X
+3 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,2,"Primary Prefix")=""
+4 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,3,"*Lowest File#")=""
+5 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,4,"*Highest File#")=""
+6 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,5,"Additional Prefixes")=""
+7 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,6,"Excepted Prefixes")=""
+8 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,7,"File Numbers")=""
+9 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,8,"File Ranges")=""
+10 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,9,"Parent Package")=""
+11 QUIT
+12 ;
SETSELAY(SELARY) ; Move Package names to SELARY from ^TMP("XTVS-PARAM-CAP") array
+1 NEW ITEMNUM,FILENME
+2 SET FILENME=""
+3 SET ITEMNUM=0
+4 FOR
SET FILENME=$ORDER(^TMP("XTVS-PARAM-CAP",$JOB,FILENME))
if FILENME=""
QUIT
Begin DoDot:1
+5 ;Parameter list
SET ITEMNUM=ITEMNUM+1
SET SELARY(ITEMNUM)=FILENME
End DoDot:1
+6 QUIT ITEMNUM
+7 ;
SPCPKGCK(XTVSSAVX,ITEMNUM,SELARY) ; Check for existence of the <SPACE> select package in SELARY
+1 NEW SELARYCT
+2 FOR SELARYCT=1:1:ITEMNUM
if (SELARY(SELARYCT)=XTVSSAVX)
QUIT
+3 IF (+SELARYCT+1)>(+ITEMNUM)
WRITE !!,"?? ",XTVSSAVX_" VistA package is undefined."
+4 QUIT
