A1VSLPDC ;Albany FO/GTS - VistA Package Sizing Manager - Caption display; 12-JUL-2016
;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
;
EN ; -- main entry point for A1VS PKG MGR PARAM CAPTN DISP
NEW CHNGMADE
SET CHNGMADE=0
D EN^VALM("A1VS PKG MGR PARAM CAPTN DISP")
Q
;
HDR ; -- header code
NEW DEFDIR,SPCPAD,DIRHEAD,LASTSPKG
SET SPCPAD=""
SET DEFDIR=$$GET^XPAR("SYS","A1VS PACKAGE MGR DEFAULT DIR",1,"I")
SET VALMHDR(1)=" VistA Package Size Analysis Manager - Captioned List"
SET VALMHDR(2)=" Version: "_$$VERNUM^A1VSLM()_" Build: "_$$BLDNUM^A1VSLM()
SET DIRHEAD="Default Directory: "_DEFDIR
SET $P(SPCPAD," ",(80-$L(DIRHEAD))/2)=""
SET VALMHDR(3)=SPCPAD_DIRHEAD
SET SPCPAD=""
SET DIRHEAD="Parameter file: "_A1VPSPRM_$S(+$G(CHNGMADE)>0:" {EDITED}",1:"")
SET $P(SPCPAD," ",(80-$L(DIRHEAD))/2)=""
SET VALMHDR(4)=SPCPAD_DIRHEAD
QUIT
;
INIT ; -- init variables and list array
NEW DATAITEM,PRMLNLP,PKG,LASTPKG,CAPDAT,LPNM,LNENUM
DO KILL
SET PKG=""
SET VALMCNT=0
FOR SET PKG=$O(^TMP("A1VS-PARAM-CAP",$J,PKG)) Q:PKG="" DO
. SET LNENUM=0
. SET CAPDAT=""
. DO ADD^A1VSLAPI(.VALMCNT," ")
. DO ADD^A1VSLAPI(.VALMCNT," ")
. FOR SET LNENUM=$O(^TMP("A1VS-PARAM-CAP",$J,PKG,LNENUM)) Q:+LNENUM'>0 DO
.. FOR SET CAPDAT=$O(^TMP("A1VS-PARAM-CAP",$J,PKG,LNENUM,CAPDAT)) Q:CAPDAT="" DO
... SET DATAITEM=^TMP("A1VS-PARAM-CAP",$J,PKG,LNENUM,CAPDAT)
... DO SPLITADD^A1VSLAPI(.VALMCNT,CAPDAT_": "_DATAITEM)
QUIT
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
KILL ; - Cleanup local and global display arrays
DO CLEAN^VALM10 ;Kill data and video control arrays
DO KILL^VALM10() ;Kill Video attributes
KILL ^TMP("A1VS PKG MGR PARAM CAP",$J) ;,^TMP("A1VS-PARAM-EDIT",$J)
QUIT
;
SELPKG(ADPKG) ; Select Package to Edit from ^TMP("A1VS 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:ADPKG DIR(0)="FAO^4:40^K:'(X'?1P.E) X"
;SET:'ADPKG DIR(0)="FAO^2:40^K:'(X'?1P.E) X"
SET DIR(0)="FAO^2:40^K:'(X'?1P.E) X"
SET DIR("PRE")="DO CHKX^A1VSLPDC("_ADPKG_")"
SET DIR("?")="^DO PKGHLP^A1VSLPDC"
DO ^DIR
IF $P(X,"^",1)="+1" SET LASTSPKG=X
IF '$D(DIRUT) SET PKGNME=Y
QUIT PKGNME
;
DATACHK(PKG) ; Check for existence of entered package in ^TMP("A1VS PKG MGR PARAM CAP",$J)
NEW RESULT
SET RESULT=0
IF $D(^TMP("A1VS-PARAM-CAP",$J,PKG)) SET RESULT=1
QUIT RESULT
;
EDPKGPRM(PKGNME) ; Edit Package Parameters
NEW CHNGMADE,DATANUM,EDITARY,DATANAME,GETOUT,UPDATLST
;SET EDITARY="^TMP(""A1VS-PARAM-EDIT"","_$J_","""_PKGNME_""")"
SET EDITARY="^TMP(""A1VS-PARAM-CAP"","_$J_","""_PKGNME_""")"
SET (CHNGMADE,DATANUM)=0
FOR SET DATANUM=$O(@EDITARY@(DATANUM)) QUIT:+DATANUM=0 QUIT:($D(DTOUT)!($D(DUOUT))) DO
. SET DATANAME=$O(@EDITARY@(DATANUM,""))
. NEW DIR,X,Y
. SET DIR("A")=DATANAME_": " ;Set DIR("A") default prompt
. IF @EDITARY@(DATANUM,DATANAME)]"" SET DIR("B")=@EDITARY@(DATANUM,DATANAME) ;Set Prompt for DIR read
. ;
. ;Primary Prefix (2)
. IF (DATANUM=2) DO
.. SET DIR("?",1)=" Enter Package Prefix from 2 to 4 characters."
.. SET DIR("?")="(1 upper case letter followed by 1 - 3 upper case letters or numbers.)"
.. SET DIR(0)="FA^2:4^K:$L(X)>4!(X'?1U1.3NU) X"
.. DO ^DIR
.. IF ('$D(DTOUT)&('$D(DUOUT))) DO
... IF ($D(DIRUT)) DO UPDTNODE^A1VSLPD1(DIRUT,EDITARY,DATANUM,DATANAME,X,.CHNGMADE)
... IF '$D(DIRUT),(@EDITARY@(DATANUM,DATANAME)'=X) SET @EDITARY@(DATANUM,DATANAME)=Y SET CHNGMADE=1
... KILL DIRUT
. ;
. ;*Lowest File# (3) & *Highest File# (4)
. IF ((DATANUM=3)!(DATANUM=4)) DO
.. SET DIR("?",1)=" Enter File Number 0 - 999999999, decimals allowed."
.. SET DIR(0)="NOA^0:999999999:6"
.. DO ^DIR
.. IF ('$D(DTOUT)&('$D(DUOUT))) DO
... IF ($D(DIRUT)) DO UPDTNODE^A1VSLPD1(DIRUT,EDITARY,DATANUM,DATANAME,X,.CHNGMADE)
... IF '$D(DIRUT),(@EDITARY@(DATANUM,DATANAME)'=X) SET @EDITARY@(DATANUM,DATANAME)=Y SET CHNGMADE=1
... KILL DIRUT
. ;
. ;Additional Prefixes (5) & Excepted Prefixes (6)
. IF ((DATANUM=5)!(DATANUM=6)) DO
.. NEW LISTDATA ;,PPRMT
.. SET GETOUT=0
.. FOR QUIT:GETOUT DO ;Edit Prefix List Loop
... SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
... DO SPLITOUT^A1VSLPD1(DATANAME,LISTDATA) ;Display Listed data to screen for user
... SET PPRMT="Enter "_$S(DATANUM=5:"Additional",1:"Excepted")_" Prefix: "
... SET DIR("A")=PPRMT ;RESET DIR("A") default prompt
... KILL DIR("B") ;No default, select from list
... SET DIR("?")=" Enter a new Prefix or one from list. [Note: Entry is case sensitive.]"
... SET DIR(0)="FAO^2:6^K:(X'?1U1.5NU) X"
... DO ^DIR
... IF (Y=-1)!(Y="")!(Y="@")!($D(DTOUT))!($D(DUOUT)) SET GETOUT=1
... SET UPDATLST=0
... IF 'GETOUT DO EDITPRFX^A1VSLPD1(Y,.LISTDATA,.UPDATLST)
... IF UPDATLST SET @EDITARY@(DATANUM,DATANAME)=LISTDATA SET CHNGMADE=1
. ;
. ; File Numbers (7)
. IF (DATANUM=7) DO
.. NEW LISTDATA
.. SET GETOUT=0
.. FOR QUIT:GETOUT DO ;Edit Prefix List Loop
... SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
... DO SPLITOUT^A1VSLPD1(DATANAME,LISTDATA) ;Display Listed data to screen for user
... SET DIR("A")="Enter File Number: " ;RESET DIR("A") default prompt
... KILL DIR("B") ;No default, select from list
... SET DIR("?",1)=" Enter a new File Number or one from list."
... SET DIR("?")="New file numbers only between 1.9999 and 99999999.999999"
... SET DIR(0)="NAO^1.9999:99999999.999999:6"
... DO ^DIR
... IF (Y=-1)!(Y="")!(Y="@")!($D(DTOUT))!($D(DUOUT)) SET GETOUT=1
... SET UPDATLST=0
... IF 'GETOUT DO EDITFNUM^A1VSLPD1(Y,.LISTDATA,.UPDATLST)
... IF UPDATLST SET @EDITARY@(DATANUM,DATANAME)=LISTDATA SET CHNGMADE=1
. ;
. ; File Ranges (8)
. IF (DATANUM=8) DO
.. NEW LISTDATA
.. SET GETOUT=0
.. FOR QUIT:GETOUT DO ;Edit Prefix List Loop
... SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
... DO SPLITOUT^A1VSLPD1(DATANAME,LISTDATA) ;Display Listed data to screen for user
... SET DIR("A")="Enter File Number Range: " ;RESET DIR("A") default prompt
... KILL DIR("B") ;No default, select from list
... SET DIR("?",1)=" Enter a new File Number Range or one from the list."
... SET DIR("?")="New file number ranges only between 1.9999 and 99999999.999999"
... SET DIR(0)="FAO^3:31^K:$$BADRNG^A1VSLPD1(X) X"
... DO ^DIR
... IF (Y=-1)!(Y="")!(Y="@")!($D(DTOUT))!($D(DUOUT)) SET GETOUT=1
... SET UPDATLST=0
... IF 'GETOUT DO EDITFRNG^A1VSLPD1(Y,.LISTDATA,.UPDATLST)
... IF UPDATLST SET @EDITARY@(DATANUM,DATANAME)=LISTDATA SET CHNGMADE=1
. ;
. ;Parent Package (9)
. IF (DATANUM=9) DO
.. SET DIR("A",1)=" "
.. SET DIR("PRE")="DO:X'=""@"" CHKX^A1VSLPDC(0)" ;Check X for existing package
.. SET DIR("?")="^DO PKGHLP^A1VSLPDC"
.. SET DIR(0)="FAOr^4:30^K:('(X'?1P.E)) X"
.. DO ^DIR
.. IF ('$D(DTOUT)&('$D(DUOUT))) DO
... IF ($D(DIRUT)) DO UPDTNODE^A1VSLPD1(DIRUT,EDITARY,DATANUM,DATANAME,X,.CHNGMADE)
... IF '$D(DIRUT),(@EDITARY@(DATANUM,DATANAME)'=X) SET @EDITARY@(DATANUM,DATANAME)=Y SET CHNGMADE=1
. ;
. KILL DIR,X,Y
;
KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
QUIT CHNGMADE
;
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("A1VS-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^A1VSLAPI("ADD ENTRY")
... IF 'DOADD DO PKGLIST(.X,.LASTSPKG)
.. IF $L($G(X))'>3 DO PKGLIST(.X,.LASTSPKG)
.. IF DOADD DO
... SET ^TMP("A1VS-PARAM-CAP",$J,X)=X ;Create new entry in TMP global
... SET ^TMP("A1VS-PARAM-CAP",$J,X,1,"Package Name")=X
... SET ^TMP("A1VS-PARAM-CAP",$J,X,2,"Primary Prefix")=""
... SET ^TMP("A1VS-PARAM-CAP",$J,X,3,"*Lowest File#")=""
... SET ^TMP("A1VS-PARAM-CAP",$J,X,4,"*Highest File#")=""
... SET ^TMP("A1VS-PARAM-CAP",$J,X,5,"Additional Prefixes")=""
... SET ^TMP("A1VS-PARAM-CAP",$J,X,6,"Excepted Prefixes")=""
... SET ^TMP("A1VS-PARAM-CAP",$J,X,7,"File Numbers")=""
... SET ^TMP("A1VS-PARAM-CAP",$J,X,8,"File Ranges")=""
... SET ^TMP("A1VS-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("A1VS-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^A1VSLAPI(.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^A1VSLAPI(" Select from the listed packages. ['^' to exit]")
.. DO LISTOUT^A1VSLAPI(.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 ; Package selection help
WRITE !," Select a Package from list of packages. [Package Name is case sensitive.]"
IF +$$YNCHK^A1VSLAPI("Do you want a list of packages") DO
. NEW SELARY,ITEMNUM,PKGLP
. SET ITEMNUM=0
. SET PKGLP=""
. FOR SET PKGLP=$O(^TMP("A1VS-PARAM-CAP",$J,PKGLP)) Q:PKGLP="" DO
.. SET ITEMNUM=ITEMNUM+1
.. SET SELARY(ITEMNUM)=PKGLP
. DO LISTOUT^A1VSLAPI(.SELARY) ; Relist packages
QUIT
;
EDITPRM ; Edit parameters for a package
; -- Protocol: A1VS PKG MGR EDIT PACKAGE PARM ACTION
;
;Logic notes:
; Select package name
; Create EDIT version of "A1VS-PARAM-CAP" array ["A1VS-PARAM-EDIT"]
; Execute DIR to prompt data in selected package
; Update ^TMP("A1VS-PARAM-CAP") array from "A1VS-PARAM-EDIT" array
; Redisplay all 'Edited' packages to screen, set "Edit" param to allow Write Edited pkgs action
; [Need an action to write "edited" packages]
; [. Walk through ^TMP("A1VS-PARAM-CAP",$J,<package name>) nodes @ write to file named in "A1VPSPRM" variable]
;
NEW PKGNME,EDITARY,CAPARY
DO FULL^VALM1
SET PKGNME=$$SELPKG(1)
IF PKGNME'=0 DO
. SET CAPARY="^TMP(""A1VS-PARAM-CAP"","_$J_","""_PKGNME_""")"
. SET CHNGMADE=$$EDPKGPRM(PKGNME)
. IF CHNGMADE DO ;MERGE @CAPARY=@EDITARY DO
.. SET @CAPARY=$$SETSTR^A1VSLPD1(CAPARY)
.. DO HDR,INIT
;
IF PKGNME=0 DO JUSTPAWS^A1VSLAPI(" Existing Package Not Selected.")
;
SET VALMBCK="R"
QUIT
;
DELPMPKG ; Delete parameters from a package
; -- Protocol: A1VS PKG MGR DEL PACKAGE PARM ACTION
;
NEW PKGNME,CAPARY
DO FULL^VALM1
SET PKGNME=$$SELPKG(0)
IF PKGNME'=0 DO
. SET CAPARY="^TMP(""A1VS-PARAM-CAP"","_$J_","""_PKGNME_""")"
. WRITE !,"You have chosen to delete the "_PKGNME_" entry"
. WRITE !," from the "_A1VPSPRM_" Package Parameter file.",!
. WRITE !,"[If deleted, "_PKGNME_" will not be included"
. WRITE !," in the VistA Size Report!]",!
. SET CHNGMADE=+$$YNCHK^A1VSLAPI("Are you SURE you want to delete the parameters for this package")
. IF CHNGMADE KILL @CAPARY DO HDR,INIT
;
IF PKGNME=0 DO JUSTPAWS^A1VSLAPI(" Existing Package Not Selected.")
;
SET VALMBCK="R"
QUIT
;
SAVPMPKG ; Save Package Parameters file
; -- Protocol: A1VS PKG MGR SAVE PACKAGE PARM ACTION
;
DO FULL^VALM1
IF +$G(CHNGMADE)'>0 DO JUSTPAWS^A1VSLAPI("No Edits have been made. Nothing new to save!")
IF +$G(CHNGMADE)>0 DO
. NEW POPERR,NOWDT,INITIAL,PKGNME,WNFILE,WOFILE,FILENME,DEFDIR
. SET POPERR=0
. 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","A1VS PACKAGE MGR DEFAULT DIR",1,"I")
. ;
. SET (WNFILE,WOFILE)=0
. SET WNFILE=+$$YNCHK^A1VSLAPI("Do you want to create a new package parameters file")
. SET:'WNFILE WOFILE=+$$YNCHK^A1VSLAPI("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 ;FILENME remains the selected/displayed parameter file
... NEW DELFLE,OLDFNME
... SET FILENME=A1VPSPRM
... 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,A1VPSPRM,DEFDIR,OLDFNME) ;Save current file to "OLD" before overwriting
... IF DELRSLT SET DELFLE(A1VPSPRM)="" SET DELRSLT=$$DEL^%ZISH(DEFDIR,$NA(DELFLE)) ;Delete current Parameter file
... SET FILENME=A1VPSPRM
.. ;
.. ; If file name definitions and copies were completed successfully, create the Parameter file
.. IF DELRSLT DO
... DO OPEN^%ZISH("XTMP",DEFDIR,FILENME,"A")
... SET:POP POPERR=POP
... QUIT:POPERR
... U IO
... SET PKGNME=""
... FOR SET PKGNME=$O(^TMP("A1VS-PARAM-CAP",$J,PKGNME)) QUIT:PKGNME']"" WRITE !,^TMP("A1VS-PARAM-CAP",$J,PKGNME)
... D CLOSE^%ZISH("XTMP")
... SET A1VPSPRM=FILENME
... SET CHNGMADE=0
... DO HDR,INIT
;
SET VALMBCK="R"
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1VSLPDC 13920 printed Sep 23, 2025@19:14:45 Page 2
A1VSLPDC ;Albany FO/GTS - VistA Package Sizing Manager - Caption display; 12-JUL-2016
+1 ;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
+2 ;
EN ; -- main entry point for A1VS PKG MGR PARAM CAPTN DISP
+1 NEW CHNGMADE
+2 SET CHNGMADE=0
+3 DO EN^VALM("A1VS PKG MGR PARAM CAPTN DISP")
+4 QUIT
+5 ;
HDR ; -- header code
+1 NEW DEFDIR,SPCPAD,DIRHEAD,LASTSPKG
+2 SET SPCPAD=""
+3 SET DEFDIR=$$GET^XPAR("SYS","A1VS PACKAGE MGR DEFAULT DIR",1,"I")
+4 SET VALMHDR(1)=" VistA Package Size Analysis Manager - Captioned List"
+5 SET VALMHDR(2)=" Version: "_$$VERNUM^A1VSLM()_" Build: "_$$BLDNUM^A1VSLM()
+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: "_A1VPSPRM_$SELECT(+$GET(CHNGMADE)>0:" {EDITED}",1:"")
+11 SET $PIECE(SPCPAD," ",(80-$LENGTH(DIRHEAD))/2)=""
+12 SET VALMHDR(4)=SPCPAD_DIRHEAD
+13 QUIT
+14 ;
INIT ; -- init variables and list array
+1 NEW DATAITEM,PRMLNLP,PKG,LASTPKG,CAPDAT,LPNM,LNENUM
+2 DO KILL
+3 SET PKG=""
+4 SET VALMCNT=0
+5 FOR
SET PKG=$ORDER(^TMP("A1VS-PARAM-CAP",$JOB,PKG))
if PKG=""
QUIT
Begin DoDot:1
+6 SET LNENUM=0
+7 SET CAPDAT=""
+8 DO ADD^A1VSLAPI(.VALMCNT," ")
+9 DO ADD^A1VSLAPI(.VALMCNT," ")
+10 FOR
SET LNENUM=$ORDER(^TMP("A1VS-PARAM-CAP",$JOB,PKG,LNENUM))
if +LNENUM'>0
QUIT
Begin DoDot:2
+11 FOR
SET CAPDAT=$ORDER(^TMP("A1VS-PARAM-CAP",$JOB,PKG,LNENUM,CAPDAT))
if CAPDAT=""
QUIT
Begin DoDot:3
+12 SET DATAITEM=^TMP("A1VS-PARAM-CAP",$JOB,PKG,LNENUM,CAPDAT)
+13 DO SPLITADD^A1VSLAPI(.VALMCNT,CAPDAT_": "_DATAITEM)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
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 ;,^TMP("A1VS-PARAM-EDIT",$J)
KILL ^TMP("A1VS PKG MGR PARAM CAP",$JOB)
+4 QUIT
+5 ;
SELPKG(ADPKG) ; Select Package to Edit from ^TMP("A1VS 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:ADPKG DIR(0)="FAO^4:40^K:'(X'?1P.E) X"
+10 ;SET:'ADPKG DIR(0)="FAO^2:40^K:'(X'?1P.E) X"
+11 SET DIR(0)="FAO^2:40^K:'(X'?1P.E) X"
+12 SET DIR("PRE")="DO CHKX^A1VSLPDC("_ADPKG_")"
+13 SET DIR("?")="^DO PKGHLP^A1VSLPDC"
+14 DO ^DIR
+15 IF $PIECE(X,"^",1)="+1"
SET LASTSPKG=X
+16 IF '$DATA(DIRUT)
SET PKGNME=Y
+17 QUIT PKGNME
+18 ;
DATACHK(PKG) ; Check for existence of entered package in ^TMP("A1VS PKG MGR PARAM CAP",$J)
+1 NEW RESULT
+2 SET RESULT=0
+3 IF $DATA(^TMP("A1VS-PARAM-CAP",$JOB,PKG))
SET RESULT=1
+4 QUIT RESULT
+5 ;
EDPKGPRM(PKGNME) ; Edit Package Parameters
+1 NEW CHNGMADE,DATANUM,EDITARY,DATANAME,GETOUT,UPDATLST
+2 ;SET EDITARY="^TMP(""A1VS-PARAM-EDIT"","_$J_","""_PKGNME_""")"
+3 SET EDITARY="^TMP(""A1VS-PARAM-CAP"","_$JOB_","""_PKGNME_""")"
+4 SET (CHNGMADE,DATANUM)=0
+5 FOR
SET DATANUM=$ORDER(@EDITARY@(DATANUM))
if +DATANUM=0
QUIT
if ($DATA(DTOUT)!($DATA(DUOUT)))
QUIT
Begin DoDot:1
+6 SET DATANAME=$ORDER(@EDITARY@(DATANUM,""))
+7 NEW DIR,X,Y
+8 ;Set DIR("A") default prompt
SET DIR("A")=DATANAME_": "
+9 ;Set Prompt for DIR read
IF @EDITARY@(DATANUM,DATANAME)]""
SET DIR("B")=@EDITARY@(DATANUM,DATANAME)
+10 ;
+11 ;Primary Prefix (2)
+12 IF (DATANUM=2)
Begin DoDot:2
+13 SET DIR("?",1)=" Enter Package Prefix from 2 to 4 characters."
+14 SET DIR("?")="(1 upper case letter followed by 1 - 3 upper case letters or numbers.)"
+15 SET DIR(0)="FA^2:4^K:$L(X)>4!(X'?1U1.3NU) X"
+16 DO ^DIR
+17 IF ('$DATA(DTOUT)&('$DATA(DUOUT)))
Begin DoDot:3
+18 IF ($DATA(DIRUT))
DO UPDTNODE^A1VSLPD1(DIRUT,EDITARY,DATANUM,DATANAME,X,.CHNGMADE)
+19 IF '$DATA(DIRUT)
IF (@EDITARY@(DATANUM,DATANAME)'=X)
SET @EDITARY@(DATANUM,DATANAME)=Y
SET CHNGMADE=1
+20 KILL DIRUT
End DoDot:3
End DoDot:2
+21 ;
+22 ;*Lowest File# (3) & *Highest File# (4)
+23 IF ((DATANUM=3)!(DATANUM=4))
Begin DoDot:2
+24 SET DIR("?",1)=" Enter File Number 0 - 999999999, decimals allowed."
+25 SET DIR(0)="NOA^0:999999999:6"
+26 DO ^DIR
+27 IF ('$DATA(DTOUT)&('$DATA(DUOUT)))
Begin DoDot:3
+28 IF ($DATA(DIRUT))
DO UPDTNODE^A1VSLPD1(DIRUT,EDITARY,DATANUM,DATANAME,X,.CHNGMADE)
+29 IF '$DATA(DIRUT)
IF (@EDITARY@(DATANUM,DATANAME)'=X)
SET @EDITARY@(DATANUM,DATANAME)=Y
SET CHNGMADE=1
+30 KILL DIRUT
End DoDot:3
End DoDot:2
+31 ;
+32 ;Additional Prefixes (5) & Excepted Prefixes (6)
+33 IF ((DATANUM=5)!(DATANUM=6))
Begin DoDot:2
+34 ;,PPRMT
NEW LISTDATA
+35 SET GETOUT=0
+36 ;Edit Prefix List Loop
FOR
if GETOUT
QUIT
Begin DoDot:3
+37 SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
+38 ;Display Listed data to screen for user
DO SPLITOUT^A1VSLPD1(DATANAME,LISTDATA)
+39 SET PPRMT="Enter "_$SELECT(DATANUM=5:"Additional",1:"Excepted")_" Prefix: "
+40 ;RESET DIR("A") default prompt
SET DIR("A")=PPRMT
+41 ;No default, select from list
KILL DIR("B")
+42 SET DIR("?")=" Enter a new Prefix or one from list. [Note: Entry is case sensitive.]"
+43 SET DIR(0)="FAO^2:6^K:(X'?1U1.5NU) X"
+44 DO ^DIR
+45 IF (Y=-1)!(Y="")!(Y="@")!($DATA(DTOUT))!($DATA(DUOUT))
SET GETOUT=1
+46 SET UPDATLST=0
+47 IF 'GETOUT
DO EDITPRFX^A1VSLPD1(Y,.LISTDATA,.UPDATLST)
+48 IF UPDATLST
SET @EDITARY@(DATANUM,DATANAME)=LISTDATA
SET CHNGMADE=1
End DoDot:3
End DoDot:2
+49 ;
+50 ; File Numbers (7)
+51 IF (DATANUM=7)
Begin DoDot:2
+52 NEW LISTDATA
+53 SET GETOUT=0
+54 ;Edit Prefix List Loop
FOR
if GETOUT
QUIT
Begin DoDot:3
+55 SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
+56 ;Display Listed data to screen for user
DO SPLITOUT^A1VSLPD1(DATANAME,LISTDATA)
+57 ;RESET DIR("A") default prompt
SET DIR("A")="Enter File Number: "
+58 ;No default, select from list
KILL DIR("B")
+59 SET DIR("?",1)=" Enter a new File Number or one from list."
+60 SET DIR("?")="New file numbers only between 1.9999 and 99999999.999999"
+61 SET DIR(0)="NAO^1.9999:99999999.999999:6"
+62 DO ^DIR
+63 IF (Y=-1)!(Y="")!(Y="@")!($DATA(DTOUT))!($DATA(DUOUT))
SET GETOUT=1
+64 SET UPDATLST=0
+65 IF 'GETOUT
DO EDITFNUM^A1VSLPD1(Y,.LISTDATA,.UPDATLST)
+66 IF UPDATLST
SET @EDITARY@(DATANUM,DATANAME)=LISTDATA
SET CHNGMADE=1
End DoDot:3
End DoDot:2
+67 ;
+68 ; File Ranges (8)
+69 IF (DATANUM=8)
Begin DoDot:2
+70 NEW LISTDATA
+71 SET GETOUT=0
+72 ;Edit Prefix List Loop
FOR
if GETOUT
QUIT
Begin DoDot:3
+73 SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
+74 ;Display Listed data to screen for user
DO SPLITOUT^A1VSLPD1(DATANAME,LISTDATA)
+75 ;RESET DIR("A") default prompt
SET DIR("A")="Enter File Number Range: "
+76 ;No default, select from list
KILL DIR("B")
+77 SET DIR("?",1)=" Enter a new File Number Range or one from the list."
+78 SET DIR("?")="New file number ranges only between 1.9999 and 99999999.999999"
+79 SET DIR(0)="FAO^3:31^K:$$BADRNG^A1VSLPD1(X) X"
+80 DO ^DIR
+81 IF (Y=-1)!(Y="")!(Y="@")!($DATA(DTOUT))!($DATA(DUOUT))
SET GETOUT=1
+82 SET UPDATLST=0
+83 IF 'GETOUT
DO EDITFRNG^A1VSLPD1(Y,.LISTDATA,.UPDATLST)
+84 IF UPDATLST
SET @EDITARY@(DATANUM,DATANAME)=LISTDATA
SET CHNGMADE=1
End DoDot:3
End DoDot:2
+85 ;
+86 ;Parent Package (9)
+87 IF (DATANUM=9)
Begin DoDot:2
+88 SET DIR("A",1)=" "
+89 ;Check X for existing package
SET DIR("PRE")="DO:X'=""@"" CHKX^A1VSLPDC(0)"
+90 SET DIR("?")="^DO PKGHLP^A1VSLPDC"
+91 SET DIR(0)="FAOr^4:30^K:('(X'?1P.E)) X"
+92 DO ^DIR
+93 IF ('$DATA(DTOUT)&('$DATA(DUOUT)))
Begin DoDot:3
+94 IF ($DATA(DIRUT))
DO UPDTNODE^A1VSLPD1(DIRUT,EDITARY,DATANUM,DATANAME,X,.CHNGMADE)
+95 IF '$DATA(DIRUT)
IF (@EDITARY@(DATANUM,DATANAME)'=X)
SET @EDITARY@(DATANUM,DATANAME)=Y
SET CHNGMADE=1
End DoDot:3
End DoDot:2
+96 ;
+97 KILL DIR,X,Y
End DoDot:1
+98 ;
+99 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+100 QUIT CHNGMADE
+101 ;
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("A1VS-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^A1VSLAPI("ADD ENTRY")
+16 IF 'DOADD
DO PKGLIST(.X,.LASTSPKG)
End DoDot:3
+17 IF $LENGTH($GET(X))'>3
DO PKGLIST(.X,.LASTSPKG)
+18 IF DOADD
Begin DoDot:3
+19 ;Create new entry in TMP global
SET ^TMP("A1VS-PARAM-CAP",$JOB,X)=X
+20 SET ^TMP("A1VS-PARAM-CAP",$JOB,X,1,"Package Name")=X
+21 SET ^TMP("A1VS-PARAM-CAP",$JOB,X,2,"Primary Prefix")=""
+22 SET ^TMP("A1VS-PARAM-CAP",$JOB,X,3,"*Lowest File#")=""
+23 SET ^TMP("A1VS-PARAM-CAP",$JOB,X,4,"*Highest File#")=""
+24 SET ^TMP("A1VS-PARAM-CAP",$JOB,X,5,"Additional Prefixes")=""
+25 SET ^TMP("A1VS-PARAM-CAP",$JOB,X,6,"Excepted Prefixes")=""
+26 SET ^TMP("A1VS-PARAM-CAP",$JOB,X,7,"File Numbers")=""
+27 SET ^TMP("A1VS-PARAM-CAP",$JOB,X,8,"File Ranges")=""
+28 SET ^TMP("A1VS-PARAM-CAP",$JOB,X,9,"Parent Package")=""
End DoDot:3
End DoDot:2
+29 IF XADD
IF $EXTRACT($GET(X),1,1)="?"
DO PKGLIST(.X,.LASTSPKG)
End DoDot:1
+30 ;
+31 QUIT
+32 ;
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("A1VS-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^A1VSLAPI(.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^A1VSLAPI(" Select from the listed packages. ['^' to exit]")
+13 ; Relist packages
DO LISTOUT^A1VSLAPI(.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 ; Package selection help
+1 WRITE !," Select a Package from list of packages. [Package Name is case sensitive.]"
+2 IF +$$YNCHK^A1VSLAPI("Do you want a list of packages")
Begin DoDot:1
+3 NEW SELARY,ITEMNUM,PKGLP
+4 SET ITEMNUM=0
+5 SET PKGLP=""
+6 FOR
SET PKGLP=$ORDER(^TMP("A1VS-PARAM-CAP",$JOB,PKGLP))
if PKGLP=""
QUIT
Begin DoDot:2
+7 SET ITEMNUM=ITEMNUM+1
+8 SET SELARY(ITEMNUM)=PKGLP
End DoDot:2
+9 ; Relist packages
DO LISTOUT^A1VSLAPI(.SELARY)
End DoDot:1
+10 QUIT
+11 ;
EDITPRM ; Edit parameters for a package
+1 ; -- Protocol: A1VS PKG MGR EDIT PACKAGE PARM ACTION
+2 ;
+3 ;Logic notes:
+4 ; Select package name
+5 ; Create EDIT version of "A1VS-PARAM-CAP" array ["A1VS-PARAM-EDIT"]
+6 ; Execute DIR to prompt data in selected package
+7 ; Update ^TMP("A1VS-PARAM-CAP") array from "A1VS-PARAM-EDIT" array
+8 ; Redisplay all 'Edited' packages to screen, set "Edit" param to allow Write Edited pkgs action
+9 ; [Need an action to write "edited" packages]
+10 ; [. Walk through ^TMP("A1VS-PARAM-CAP",$J,<package name>) nodes @ write to file named in "A1VPSPRM" variable]
+11 ;
+12 NEW PKGNME,EDITARY,CAPARY
+13 DO FULL^VALM1
+14 SET PKGNME=$$SELPKG(1)
+15 IF PKGNME'=0
Begin DoDot:1
+16 SET CAPARY="^TMP(""A1VS-PARAM-CAP"","_$JOB_","""_PKGNME_""")"
+17 SET CHNGMADE=$$EDPKGPRM(PKGNME)
+18 ;MERGE @CAPARY=@EDITARY DO
IF CHNGMADE
Begin DoDot:2
+19 SET @CAPARY=$$SETSTR^A1VSLPD1(CAPARY)
+20 DO HDR
DO INIT
End DoDot:2
End DoDot:1
+21 ;
+22 IF PKGNME=0
DO JUSTPAWS^A1VSLAPI(" Existing Package Not Selected.")
+23 ;
+24 SET VALMBCK="R"
+25 QUIT
+26 ;
DELPMPKG ; Delete parameters from a package
+1 ; -- Protocol: A1VS PKG MGR DEL PACKAGE PARM ACTION
+2 ;
+3 NEW PKGNME,CAPARY
+4 DO FULL^VALM1
+5 SET PKGNME=$$SELPKG(0)
+6 IF PKGNME'=0
Begin DoDot:1
+7 SET CAPARY="^TMP(""A1VS-PARAM-CAP"","_$JOB_","""_PKGNME_""")"
+8 WRITE !,"You have chosen to delete the "_PKGNME_" entry"
+9 WRITE !," from the "_A1VPSPRM_" Package Parameter file.",!
+10 WRITE !,"[If deleted, "_PKGNME_" will not be included"
+11 WRITE !," in the VistA Size Report!]",!
+12 SET CHNGMADE=+$$YNCHK^A1VSLAPI("Are you SURE you want to delete the parameters for this package")
+13 IF CHNGMADE
KILL @CAPARY
DO HDR
DO INIT
End DoDot:1
+14 ;
+15 IF PKGNME=0
DO JUSTPAWS^A1VSLAPI(" Existing Package Not Selected.")
+16 ;
+17 SET VALMBCK="R"
+18 QUIT
+19 ;
SAVPMPKG ; Save Package Parameters file
+1 ; -- Protocol: A1VS PKG MGR SAVE PACKAGE PARM ACTION
+2 ;
+3 DO FULL^VALM1
+4 IF +$GET(CHNGMADE)'>0
DO JUSTPAWS^A1VSLAPI("No Edits have been made. Nothing new to save!")
+5 IF +$GET(CHNGMADE)>0
Begin DoDot:1
+6 NEW POPERR,NOWDT,INITIAL,PKGNME,WNFILE,WOFILE,FILENME,DEFDIR
+7 SET POPERR=0
+8 SET NOWDT=$$FMTE^XLFDT($$NOW^XLFDT,"2M")
+9 SET NOWDT=$TRANSLATE(NOWDT,"/","-")
+10 SET NOWDT=$TRANSLATE(NOWDT,"@","_")
+11 SET NOWDT=$TRANSLATE(NOWDT,":","")
+12 SET INITIAL=$PIECE($GET(^VA(200,DUZ,0)),"^",2)
+13 IF INITIAL']""
SET INITIAL="<unk>"
+14 SET DEFDIR=$$GET^XPAR("SYS","A1VS PACKAGE MGR DEFAULT DIR",1,"I")
+15 ;
+16 SET (WNFILE,WOFILE)=0
+17 SET WNFILE=+$$YNCHK^A1VSLAPI("Do you want to create a new package parameters file")
+18 if 'WNFILE
SET WOFILE=+$$YNCHK^A1VSLAPI("Do you want to OVERWRITE the existing package parameters file")
+19 IF (WNFILE)!(WOFILE)
Begin DoDot:2
+20 NEW DELRSLT
+21 ;Output a New Parameter file
IF WNFILE
SET FILENME="XTMPSIZE"_"_"_INITIAL_NOWDT_".DAT"
+22 ;
+23 ; Initialize DELRSLT (delete Result) variable
SET DELRSLT=1
+24 ;FILENME remains the selected/displayed parameter file
IF WOFILE
Begin DoDot:3
+25 NEW DELFLE,OLDFNME
+26 SET FILENME=A1VPSPRM
+27 IF FILENME[";"
SET FILENME=$PIECE(FILENME,";")
+28 SET OLDFNME=$PIECE(FILENME,".")_".BAK"
+29 ;Delete current Parameter file
SET DELFLE(OLDFNME)=""
SET DELRSLT=$$DEL^%ZISH(DEFDIR,$NAME(DELFLE))
KILL DELFLE(OLDFNME)
+30 ;Save current file to "OLD" before overwriting
SET DELRSLT=$$MV^%ZISH(DEFDIR,A1VPSPRM,DEFDIR,OLDFNME)
+31 ;Delete current Parameter file
IF DELRSLT
SET DELFLE(A1VPSPRM)=""
SET DELRSLT=$$DEL^%ZISH(DEFDIR,$NAME(DELFLE))
+32 SET FILENME=A1VPSPRM
End DoDot:3
+33 ;
+34 ; If file name definitions and copies were completed successfully, create the Parameter file
+35 IF DELRSLT
Begin DoDot:3
+36 DO OPEN^%ZISH("XTMP",DEFDIR,FILENME,"A")
+37 if POP
SET POPERR=POP
+38 if POPERR
QUIT
+39 USE IO
+40 SET PKGNME=""
+41 FOR
SET PKGNME=$ORDER(^TMP("A1VS-PARAM-CAP",$JOB,PKGNME))
if PKGNME']""
QUIT
WRITE !,^TMP("A1VS-PARAM-CAP",$JOB,PKGNME)
+42 DO CLOSE^%ZISH("XTMP")
+43 SET A1VPSPRM=FILENME
+44 SET CHNGMADE=0
+45 DO HDR
DO INIT
End DoDot:3
End DoDot:2
End DoDot:1
+46 ;
+47 SET VALMBCK="R"
+48 QUIT
