XTVSLPDC ;Albany FO/GTS - VistA Package Sizing Manager - Caption display; 12-JUL-2016
;;7.3;TOOLKIT;**143**;Apr 25, 1995;Build 116
;
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,LASTSPKG
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,LASTSPKG,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)
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(ADPKG) ; Select Package to Edit from ^TMP("XTVS PKG MGR PARAM CAP",$J)
; INPUT:
; ADPKG : 0 - Do not allow add new package [Default]
; : 1 - Allow add new package
;
NEW PKGNME,DIR,DIRUT,DTOUT,DUOUT,X,Y
IF +$G(ADPKG)'=1 SET ADPKG=0 ;Default Add package to 'not allowed'
SET PKGNME=0
SET DIR("A")="Select Package: "
SET DIR(0)="FAO^2:40^K:'(X'?1P.E) X"
SET DIR("PRE")="DO CHKX^XTVSLPDC("_ADPKG_")"
SET DIR("?")="^DO PKGHLP^XTVSLPDC"
DO ^DIR
IF $P(X,"^",1)="+1" SET LASTSPKG=X
IF '$D(DIRUT) SET PKGNME=Y
QUIT PKGNME
;
CHKX(XADD) ;Check for Package
; INPUT:
; XADD : 0 - Do not allow add new package
; : 1 - Allow add new package
;
IF (X="^")!(X']"") QUIT ;Quit if user entry to exit
;
NEW SELARY,PKGLP,ITEMNUM,XVAL,DOADD
SET DOADD=0
IF $G(XADD)']"" SET XADD=0
IF X=" ",$G(LASTSPKG)]"" SET X=LASTSPKG W X
IF (X]""),('$D(^TMP("XTVS-PARAM-CAP",$J,X))) DO
. IF 'XADD DO PKGLIST(.X,.LASTSPKG)
. IF XADD,$E($G(X),1,1)'="?" DO
.. IF $L($G(X))>3 DO
... SET DOADD=$$YNCHK^XTVSLAPI("ADD ENTRY")
... IF '(+DOADD),($P(DOADD,"^",2)'=-1) DO PKGLIST(.X,.LASTSPKG)
... IF '(+DOADD),($P(DOADD,"^",2)=-1) K X
.. IF ($L($G(X))'>3),($G(X)'="") DO PKGLIST(.X,.LASTSPKG)
.. IF +DOADD DO
... 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")=""
. IF XADD,$E($G(X),1,1)="?" DO PKGLIST(.X,.LASTSPKG)
;
QUIT
;
PKGLIST(X,LASTSPKG) ;List packages from user entry [to support 'XADD' mod in CHKX]
SET ITEMNUM=0
SET PKGLP=$G(X)
FOR SET PKGLP=$O(^TMP("XTVS-PARAM-CAP",$J,PKGLP)) Q:PKGLP="" Q:($E(PKGLP,1,$L($G(X)))'=$G(X)) DO
. SET ITEMNUM=ITEMNUM+1
. SET SELARY(ITEMNUM)=PKGLP
IF ITEMNUM>0 DO
. SET XVAL=0
. DO LISTOUT^XTVSLAPI(.SELARY) ;List Packages for selection
. FOR READ !,"Enter number for Selected Package: ",XVAL:DTIME Q:'$T Q:$E(XVAL,1)="^" Q:XVAL="" Q:((+XVAL>0)&(+XVAL<(ITEMNUM+1))) DO
.. IF XVAL["?" W !,"Select a package. [Number 1 - "_ITEMNUM_"]"
.. IF XVAL'?1.3"?" W !,"??"
.. DO JUSTPAWS^XTVSLAPI(" Select from the listed packages. ['^' to exit]")
.. DO LISTOUT^XTVSLAPI(.SELARY) ; Relist packages
. ;
IF '((+$G(XVAL)>0)&(+$G(XVAL)<(ITEMNUM+1))) KILL X ;If didn't enter existing package or select from a list, require re-entry of package
IF (+$G(XVAL)>0)&(+$G(XVAL)<(ITEMNUM+1)) SET (LASTSPKG,X)=SELARY(XVAL) W " ",X
QUIT
;
PKGHLP(PRNT) ; Package selection help
WRITE:+$G(PRNT) !,"Select a Package from list of packages. [Package Name is case sensitive.]",!
WRITE:+$G(PRNT) !,"Parent Package indicates an association with a package that may include"
WRITE:+$G(PRNT) !," component intersections causing duplicate counting of Routines, Options,"
WRITE:+$G(PRNT) !," Protocols, Files, etc. by the VistA Package Size report. For the VistA"
WRITE:+$G(PRNT) !," Package Size Analysis Management tools, it is informational."
WRITE:+$G(PRNT) !," However for VistA development management teams, it can mean more.",!
IF +$$YNCHK^XTVSLAPI("Do you want a list of packages") DO
. NEW SELARY,ITEMNUM,PKGLP
. SET ITEMNUM=0
. SET PKGLP=""
. FOR SET PKGLP=$O(^TMP("XTVS-PARAM-CAP",$J,PKGLP)) Q:PKGLP="" DO
.. SET ITEMNUM=ITEMNUM+1
.. SET SELARY(ITEMNUM)=PKGLP
. DO LISTOUT^XTVSLAPI(.SELARY) ; Relist packages
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 '$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(" Existing 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)
. 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(" Existing 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLPDC 13139 printed Apr 09, 2024@21:44:11 Page 2
XTVSLPDC ;Albany FO/GTS - VistA Package Sizing Manager - Caption display; 12-JUL-2016
+1 ;;7.3;TOOLKIT;**143**;Apr 25, 1995;Build 116
+2 ;
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,LASTSPKG
+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,LASTSPKG,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)
+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(ADPKG) ; Select Package to Edit from ^TMP("XTVS PKG MGR PARAM CAP",$J)
+1 ; INPUT:
+2 ; ADPKG : 0 - Do not allow add new package [Default]
+3 ; : 1 - Allow add new package
+4 ;
+5 NEW PKGNME,DIR,DIRUT,DTOUT,DUOUT,X,Y
+6 ;Default Add package to 'not allowed'
IF +$GET(ADPKG)'=1
SET ADPKG=0
+7 SET PKGNME=0
+8 SET DIR("A")="Select Package: "
+9 SET DIR(0)="FAO^2:40^K:'(X'?1P.E) X"
+10 SET DIR("PRE")="DO CHKX^XTVSLPDC("_ADPKG_")"
+11 SET DIR("?")="^DO PKGHLP^XTVSLPDC"
+12 DO ^DIR
+13 IF $PIECE(X,"^",1)="+1"
SET LASTSPKG=X
+14 IF '$DATA(DIRUT)
SET PKGNME=Y
+15 QUIT PKGNME
+16 ;
CHKX(XADD) ;Check for Package
+1 ; INPUT:
+2 ; XADD : 0 - Do not allow add new package
+3 ; : 1 - Allow add new package
+4 ;
+5 ;Quit if user entry to exit
IF (X="^")!(X']"")
QUIT
+6 ;
+7 NEW SELARY,PKGLP,ITEMNUM,XVAL,DOADD
+8 SET DOADD=0
+9 IF $GET(XADD)']""
SET XADD=0
+10 IF X=" "
IF $GET(LASTSPKG)]""
SET X=LASTSPKG
WRITE X
+11 IF (X]"")
IF ('$DATA(^TMP("XTVS-PARAM-CAP",$JOB,X)))
Begin DoDot:1
+12 IF 'XADD
DO PKGLIST(.X,.LASTSPKG)
+13 IF XADD
IF $EXTRACT($GET(X),1,1)'="?"
Begin DoDot:2
+14 IF $LENGTH($GET(X))>3
Begin DoDot:3
+15 SET DOADD=$$YNCHK^XTVSLAPI("ADD ENTRY")
+16 IF '(+DOADD)
IF ($PIECE(DOADD,"^",2)'=-1)
DO PKGLIST(.X,.LASTSPKG)
+17 IF '(+DOADD)
IF ($PIECE(DOADD,"^",2)=-1)
KILL X
End DoDot:3
+18 IF ($LENGTH($GET(X))'>3)
IF ($GET(X)'="")
DO PKGLIST(.X,.LASTSPKG)
+19 IF +DOADD
Begin DoDot:3
+20 ;Create new entry in TMP global
SET ^TMP("XTVS-PARAM-CAP",$JOB,X)=X
+21 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,1,"Package Name")=X
+22 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,2,"Primary Prefix")=""
+23 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,3,"*Lowest File#")=""
+24 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,4,"*Highest File#")=""
+25 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,5,"Additional Prefixes")=""
+26 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,6,"Excepted Prefixes")=""
+27 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,7,"File Numbers")=""
+28 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,8,"File Ranges")=""
+29 SET ^TMP("XTVS-PARAM-CAP",$JOB,X,9,"Parent Package")=""
End DoDot:3
End DoDot:2
+30 IF XADD
IF $EXTRACT($GET(X),1,1)="?"
DO PKGLIST(.X,.LASTSPKG)
End DoDot:1
+31 ;
+32 QUIT
+33 ;
PKGLIST(X,LASTSPKG) ;List packages from user entry [to support 'XADD' mod in CHKX]
+1 SET ITEMNUM=0
+2 SET PKGLP=$GET(X)
+3 FOR
SET PKGLP=$ORDER(^TMP("XTVS-PARAM-CAP",$JOB,PKGLP))
if PKGLP=""
QUIT
if ($EXTRACT(PKGLP,1,$LENGTH($GET(X)))'=$GET(X))
QUIT
Begin DoDot:1
+4 SET ITEMNUM=ITEMNUM+1
+5 SET SELARY(ITEMNUM)=PKGLP
End DoDot:1
+6 IF ITEMNUM>0
Begin DoDot:1
+7 SET XVAL=0
+8 ;List Packages for selection
DO LISTOUT^XTVSLAPI(.SELARY)
+9 FOR
READ !,"Enter number for Selected Package: ",XVAL:DTIME
if '$TEST
QUIT
if $EXTRACT(XVAL,1)="^"
QUIT
if XVAL=""
QUIT
if ((+XVAL>0)&(+XVAL<(ITEMNUM+1)))
QUIT
Begin DoDot:2
+10 IF XVAL["?"
WRITE !,"Select a package. [Number 1 - "_ITEMNUM_"]"
+11 IF XVAL'?1.3"?"
WRITE !,"??"
+12 DO JUSTPAWS^XTVSLAPI(" Select from the listed packages. ['^' to exit]")
+13 ; Relist packages
DO LISTOUT^XTVSLAPI(.SELARY)
End DoDot:2
+14 ;
End DoDot:1
+15 ;If didn't enter existing package or select from a list, require re-entry of package
IF '((+$GET(XVAL)>0)&(+$GET(XVAL)<(ITEMNUM+1)))
KILL X
+16 IF (+$GET(XVAL)>0)&(+$GET(XVAL)<(ITEMNUM+1))
SET (LASTSPKG,X)=SELARY(XVAL)
WRITE " ",X
+17 QUIT
+18 ;
PKGHLP(PRNT) ; Package selection help
+1 if +$GET(PRNT)
WRITE !,"Select a Package from list of packages. [Package Name is case sensitive.]",!
+2 if +$GET(PRNT)
WRITE !,"Parent Package indicates an association with a package that may include"
+3 if +$GET(PRNT)
WRITE !," component intersections causing duplicate counting of Routines, Options,"
+4 if +$GET(PRNT)
WRITE !," Protocols, Files, etc. by the VistA Package Size report. For the VistA"
+5 if +$GET(PRNT)
WRITE !," Package Size Analysis Management tools, it is informational."
+6 if +$GET(PRNT)
WRITE !," However for VistA development management teams, it can mean more.",!
+7 IF +$$YNCHK^XTVSLAPI("Do you want a list of packages")
Begin DoDot:1
+8 NEW SELARY,ITEMNUM,PKGLP
+9 SET ITEMNUM=0
+10 SET PKGLP=""
+11 FOR
SET PKGLP=$ORDER(^TMP("XTVS-PARAM-CAP",$JOB,PKGLP))
if PKGLP=""
QUIT
Begin DoDot:2
+12 SET ITEMNUM=ITEMNUM+1
+13 SET SELARY(ITEMNUM)=PKGLP
End DoDot:2
+14 ; Relist packages
DO LISTOUT^XTVSLAPI(.SELARY)
End DoDot:1
+15 QUIT
+16 ;
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 IF '$DATA(^TMP("XTVS-PARAM-BI",$JOB,PKGNME))
DO BEFORIMG^XTVSLPD1(PKGNME)
+16 SET CAPARY="^TMP(""XTVS-PARAM-CAP"","_$JOB_","""_PKGNME_""")"
+17 DO EDPKGPRM^XTVSLPD1(PKGNME)
+18 SET EDPKG=$$EDCHK^XTVSLPD1(PKGNME)
+19 ;Update header
IF EDPKG
SET @CAPARY=$$SETSTR^XTVSLPD1(CAPARY)
+20 IF 'EDPKG
KILL ^TMP("XTVS-PARAM-BI",$JOB,PKGNME)
+21 SET CHNGMADE=$EXTRACT($DATA(^TMP("XTVS-PARAM-BI",$JOB)),1,1)
+22 ;
+23 SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
+24 SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
+25 IF $PIECE(LCKCHK,"^")=1
DO HDR
DO INIT
End DoDot:2
+26 ;
+27 IF PKGNME=0
DO JUSTPAWS^XTVSLAPI(" Existing Package Not Selected.")
DO MSG
End DoDot:1
+28 ;
+29 IF $PIECE(LCKCHK,"^")=1
SET VALMBCK="R"
+30 IF $PIECE(LCKCHK,"^")'=1
SET VALMQUIT=""
+31 QUIT
+32 ;
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)
+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(" Existing 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
