Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XTVSLPDC

XTVSLPDC.m

Go to the documentation of this file.
  1. XTVSLPDC ;ALBANY FO/GTS - VistA Package Sizing Manager - Caption display; 12-JUL-2016
  1. ;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. EN ; -- main entry point for XTVS PKG MGR PARAM CAPTN DISP
  1. NEW CHNGMADE
  1. SET CHNGMADE=0
  1. KILL ^TMP("XTVS-PARAM-BI",$J)
  1. DO EN^VALM("XTVS PKG MGR PARAM CAPTN DISP")
  1. QUIT
  1. ;
  1. HDR ; -- header code
  1. NEW DEFDIR,SPCPAD,DIRHEAD
  1. SET SPCPAD=""
  1. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. SET VALMHDR(1)=" VistA Package Size Analysis Manager - Captioned List"
  1. SET VALMHDR(2)=" Version: "_$$VERNUM^XTVSLM()_" Build: "_$$BLDNUM^XTVSLM()
  1. SET DIRHEAD="Default Directory: "_DEFDIR
  1. SET $P(SPCPAD," ",(80-$L(DIRHEAD))/2)=""
  1. SET VALMHDR(3)=SPCPAD_DIRHEAD
  1. SET SPCPAD=""
  1. SET DIRHEAD="Parameter file: "_XTVPSPRM_$S(+$G(CHNGMADE)>0:" {EDITED}",1:"")
  1. SET $P(SPCPAD," ",(80-$L(DIRHEAD))/2)=""
  1. SET VALMHDR(4)=SPCPAD_DIRHEAD
  1. DO MSG
  1. QUIT
  1. ;
  1. INIT ; -- init variables and list array
  1. NEW DATAITEM,PRMLNLP,PKG,CAPDAT,LPNM,LNENUM,DEFDIR,FILENAME,LCKCHK
  1. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
  1. IF $P(LCKCHK,"^")=1 DO
  1. . DO KILL
  1. . SET PKG=""
  1. . SET VALMCNT=0
  1. . FOR SET PKG=$O(^TMP("XTVS-PARAM-CAP",$J,PKG)) Q:PKG="" DO
  1. .. SET LNENUM=0
  1. .. SET CAPDAT=""
  1. .. DO ADD^XTVSLAPI(.VALMCNT," ")
  1. .. DO ADD^XTVSLAPI(.VALMCNT," ")
  1. .. FOR SET LNENUM=$O(^TMP("XTVS-PARAM-CAP",$J,PKG,LNENUM)) Q:+LNENUM'>0 DO
  1. ... FOR SET CAPDAT=$O(^TMP("XTVS-PARAM-CAP",$J,PKG,LNENUM,CAPDAT)) Q:CAPDAT="" DO
  1. .... SET DATAITEM=^TMP("XTVS-PARAM-CAP",$J,PKG,LNENUM,CAPDAT)
  1. .... DO SPLITADD^XTVSLAPI(.VALMCNT,CAPDAT_": "_DATAITEM)
  1. ;
  1. IF ($P(LCKCHK,"^")'=1) SET VALMQUIT="" DO EXIT^XTVSLPDC
  1. QUIT
  1. ;
  1. HELP ; -- help code
  1. IF $D(X),X'["??" DO
  1. . SET X="?"
  1. . DO DISP^XQORM1 W !
  1. IF $D(X),X["??" DO
  1. . DO CLEAR^VALM1
  1. . DO FULL^VALM1
  1. . WRITE !,"Captioned List action help..."
  1. . WRITE !,"List specific actions:",!
  1. . DO DISP^XQORM1 W !!
  1. . SET XTQVAR=Y
  1. . IF XTQVAR DO
  1. .. SET XTQVAR=0
  1. .. FOR TXTCT=1:1 SET XTX=$P($T(LPDCTXT+TXTCT^XTVSHLP1),";",3,99) QUIT:XTX="$END" QUIT:XTQVAR DO
  1. ... IF XTX="$PAUSE" DO PAUSE^VALM1 D:Y CLEAR^VALM1 IF 'Y SET XTQVAR=1 QUIT
  1. ... W !,$S(XTX["$PAUSE":"",1:XTX)
  1. . W !
  1. DO HDR,INIT
  1. S VALMBCK="R"
  1. K XTX,Y,TXTCT,XTQVAR
  1. QUIT
  1. ;
  1. EXIT ; -- exit code
  1. NEW SVEDT
  1. SET LCKCHK=$$CHKPID^XTVSLAPI($$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I"),XTVPSPRM)
  1. IF $P(LCKCHK,"^")=1 DO
  1. . IF +$G(CHNGMADE)>0 DO
  1. .. DO FULL^VALM1
  1. .. WRITE !,"You have unsaved Package edits in this Parameter file!"
  1. .. SET SVEDT=+$$YNCHK^XTVSLAPI("Do you want to save the Parameter edits before exiting","YES")
  1. .. IF SVEDT DO PKGSAVE
  1. .. IF $G(CHNGMADE)>0 DO JUSTPAWS^XTVSLAPI(" Package edits NOT saved!")
  1. .. IF $G(CHNGMADE)'>0 DO JUSTPAWS^XTVSLAPI(" Package edits saved!")
  1. ;
  1. IF ($P(LCKCHK,"^")'=1) DO
  1. . DO FULL^VALM1
  1. . W !!," <* LOCK ERROR. LOCK required to proceed. Check LOCK file Integrity. *>"
  1. . DO JUSTPAWS^XTVSLAPI($P(LCKCHK,"^",2))
  1. ;
  1. KILL ^TMP("XTVS-PARAM-BI",$J),LASTSPKG
  1. DO KILL
  1. Q
  1. ;
  1. MSG(TEXT) ; -- set default message
  1. IF $G(TEXT)]"" SET VALMSG=TEXT
  1. IF $G(TEXT)']"" SET VALMSG="Enter ?? for more actions and Help"
  1. QUIT
  1. ;
  1. KILL ; - Cleanup local and global display arrays
  1. DO CLEAN^VALM10 ;Kill data and video control arrays
  1. DO KILL^VALM10() ;Kill Video attributes
  1. KILL ^TMP("XTVS PKG MGR PARAM CAP",$J)
  1. QUIT
  1. ;
  1. SELPKG(ADDITM,DELIND) ; Select Package to Edit/Delete from ^TMP("XTVS PKG MGR PARAM CAP",$J)
  1. ; INPUT:
  1. ; ADDITM : 0 - Do not allow add new package [Default]
  1. ; : 1 - Allow add new package
  1. ; DELIND : 0 - Called to select a package for add/edit [Default]
  1. ; 1 - Called to select a package to delete
  1. ;
  1. ; Set: ITEMNUM - Number of items in SELARY
  1. ; SELARY - Array of Package Parameter files
  1. ; PARAMSTR - Array of string parameters as follows:
  1. ; PARAMSTR("ADDITM") - 0: Adding item to SELARY NOT Allowed; 1: Adding unique item to SELARY Allowed 1^1: Add duplicates allowed
  1. ; PARAMSTR("MAXLNG") - Maximum length of entered string [default 30, or 10 more than MINLNG when MINLNG>MAXLNG]
  1. ; PARAMSTR("MINLNG") - Minumum length of entered string [default 10] - DEV NOTE: MINLNG must be > or = #Chars in PATRN begin & end strings
  1. ; PARAMSTR("PATRN") - Pattern match definition for text [default .ANP)
  1. ; PARAMSTR("XTUPCASE") - 0: case matters, 1: All item text translated to upper case [default]
  1. ;
  1. ;
  1. ; RETURN - Name of the selected Package
  1. ;
  1. NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,MINLG,MAXLG,PARAMSTR,SELARY,ITEMNUM,PKGNME
  1. SET PARAMSTR("ADDITM")=+$G(ADDITM) ;Default - 0 No adding items
  1. SET PARAMSTR("XTUPCASE")=0 ; Case matters
  1. SET PARAMSTR("PATRN")=".ANP"
  1. SET PARAMSTR("MINLNG")=4
  1. SET PARAMSTR("MAXLNG")=50
  1. SET DELIND=+$G(DELIND) ; Default 0 (add/edit)
  1. SET PARAMSTR("DELIND")=DELIND
  1. SET SELARY=""
  1. ;
  1. SET ITEMNUM=$$SETSELAY(.SELARY)
  1. SET PARAMSTR("ITEMNUM")=ITEMNUM
  1. ;
  1. IF +ITEMNUM=0 DO JUSTPAWS^XTVSLAPI(" No packages to select. Corrupted Package parameter file!") QUIT ;Nothing to select
  1. ;
  1. SET DIR("A")="Select Package: "
  1. SET DIR(0)="NAO^1:"_(ITEMNUM+1)_"^K:(X'?.N) X I $D(X),(X>ITEMNUM) K X"
  1. SET DIR("PRE")="D PRECHK^XTVSLPDC(.X,.LASTSPKG,.SELARY,.ITEMNUM,.PARAMSTR)"
  1. IF 'ADDITM,('DELIND) SET DIR("?",2)=" New items cannot be added."
  1. IF ADDITM,('$P(ADDITM,"^",2)) SET DIR("?",2)=" New items can be added but duplicates are not allowed."
  1. SET DIR("?",1)=" Enter the name or number (1-"_ITEMNUM_") of the Package."
  1. SET DIR("?")=" [Enter '??' for a numbered list of items OR '^' to exit]"
  1. SET DIR("??")="^DO LISTOUT^XTVSLAPI(.SELARY)"
  1. DO ^DIR
  1. ;
  1. SET PKGNME=$S(+$G(X)>0:SELARY(X),1:0) ; Return 0 if package not selected
  1. IF PKGNME'=0 SET LASTSPKG=PKGNME W " ",PKGNME
  1. ;
  1. QUIT PKGNME
  1. ;
  1. PRECHK(X,LASTSPKG,SELARY,ITEMNUM,PARAMSTR) ; SELPKG X value DIR("PRE") pre-check
  1. NEW XTVSSAVX,DELIND
  1. SET DELIND=+$G(PARAMSTR("DELIND"))
  1. IF (X=" "),($G(LASTSPKG)]"") SET (XTVSSAVX,X)=LASTSPKG W " ",LASTSPKG
  1. IF (X]""),('$D(DTOUT)),($E(X,1)'="^") DO
  1. . IF (X'?.N),($E(X,1)'["?") DO SELLIST^XTVSLPR2(.SELARY,.ITEMNUM,.X,.PARAMSTR)
  1. IF DELIND,($G(XTVSSAVX)]""),('$D(X)!($D(X)&$G(X)']"")) D SPCPKGCK(XTVSSAVX,ITEMNUM,.SELARY)
  1. QUIT
  1. ;
  1. EDITPRM ; Edit parameters for a package
  1. ; -- Protocol: XTVS PKG MGR EDIT PACKAGE PARM ACTION
  1. ;
  1. ;Logic notes:
  1. ; Select package name
  1. ; Edit package data in ^TMP("XTVS-PARAM-CAP") array
  1. ; Redisplay all 'Edited' packages to screen, set "Edit" [CHNGMADE] param to allow Write Edited pkgs action
  1. ;
  1. NEW PKGNME,EDITARY,CAPARY,EDPKG,DEFDIR,LCKCHK
  1. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
  1. IF $P(LCKCHK,"^")=1 DO
  1. . DO FULL^VALM1
  1. . SET PKGNME=$$SELPKG(1)
  1. . IF PKGNME'=0 DO
  1. ..;
  1. .. IF PKGNME["""" DO ;Assumes that " only in PKGNME via Add New Package (XT*7.3*152)
  1. ... SET PKGNME=$REPLACE(PKGNME,"""","''")
  1. ... SET LASTSPKG=PKGNME
  1. ... DO JUSTPAWS^XTVSLAPI("Quotation marks changed to apostrophes in "_PKGNME_" name.")
  1. ..;
  1. .. IF '$D(^TMP("XTVS-PARAM-CAP",$J,PKGNME)) DO SETADD(PKGNME)
  1. .. IF '$D(^TMP("XTVS-PARAM-BI",$J,PKGNME)) DO BEFORIMG^XTVSLPD1(PKGNME)
  1. .. SET CAPARY="^TMP(""XTVS-PARAM-CAP"","_$J_","""_PKGNME_""")"
  1. .. DO EDPKGPRM^XTVSLPD1(PKGNME)
  1. .. SET EDPKG=$$EDCHK^XTVSLPD1(PKGNME)
  1. .. IF EDPKG SET @CAPARY=$$SETSTR^XTVSLPD1(CAPARY) ;Update header
  1. .. IF 'EDPKG KILL ^TMP("XTVS-PARAM-BI",$J,PKGNME)
  1. .. SET CHNGMADE=$E($D(^TMP("XTVS-PARAM-BI",$J)),1,1)
  1. ..;
  1. .. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. .. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
  1. .. IF $P(LCKCHK,"^")=1 DO HDR,INIT
  1. .;
  1. . IF PKGNME=0 DO JUSTPAWS^XTVSLAPI(" Package Not Selected.") DO MSG
  1. ;
  1. IF $P(LCKCHK,"^")=1 SET VALMBCK="R"
  1. IF $P(LCKCHK,"^")'=1 SET VALMQUIT=""
  1. QUIT
  1. ;
  1. DELPMPKG ; Delete parameters from a package
  1. ; -- Protocol: XTVS PKG MGR DEL PACKAGE PARM ACTION
  1. ;
  1. NEW PKGNME,CAPARY,DELPKG,LCKCHK,DEFDIR
  1. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
  1. IF $P(LCKCHK,"^")=1 DO
  1. . DO FULL^VALM1
  1. . SET PKGNME=$$SELPKG(0,1)
  1. . IF PKGNME'=0 DO
  1. .. SET CAPARY="^TMP(""XTVS-PARAM-CAP"","_$J_","""_PKGNME_""")"
  1. .. WRITE !,"You have chosen to delete the "_PKGNME_" entry"
  1. .. WRITE !," from the "_XTVPSPRM_" Package Parameter file.",!
  1. .. WRITE !,"[If deleted, "_PKGNME_" will not be included"
  1. .. WRITE !," in any VistA Size Report derived from "_XTVPSPRM_"!]",!
  1. .. SET DELPKG=+$$YNCHK^XTVSLAPI("Are you SURE you want to delete the parameters for this package")
  1. .. IF 'DELPKG DO MSG
  1. .. IF DELPKG DO
  1. ... IF '$D(^TMP("XTVS-PARAM-BI",$J,PKGNME)) DO BEFORIMG^XTVSLPD1(PKGNME) ; Create BI when delete an existing, unedited package.
  1. ... KILL @CAPARY
  1. ... 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)
  1. ... SET CHNGMADE=$E($D(^TMP("XTVS-PARAM-BI",$J)),1,1)
  1. ... DO:$P($$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM),"^")=1 HDR,INIT
  1. .;
  1. . IF PKGNME=0 DO JUSTPAWS^XTVSLAPI(" Package Not Selected.") DO MSG
  1. .;
  1. . SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. . SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
  1. ;
  1. IF $P(LCKCHK,"^")=1 SET VALMBCK="R"
  1. IF $P(LCKCHK,"^")'=1 SET VALMBCK="Q" SET VALMQUIT=""
  1. QUIT
  1. ;
  1. SAVPMPKG ; Save Package Parameters file
  1. ; -- Protocol: XTVS PKG MGR SAVE PACKAGE PARM ACTION
  1. ;
  1. NEW LCKCHK,DEFDIR
  1. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. SET LCKCHK=$$CHKPID^XTVSLAPI(DEFDIR,XTVPSPRM)
  1. IF $P(LCKCHK,"^")=1 DO
  1. . DO FULL^VALM1
  1. . IF +$G(CHNGMADE)'>0 DO JUSTPAWS^XTVSLAPI("File Content not edited. No modifications to save!") DO MSG
  1. . IF +$G(CHNGMADE)>0 DO
  1. .. DO PKGSAVE
  1. .. IF $G(CHNGMADE)'>0 DO HDR,INIT
  1. .. IF $G(CHNGMADE)>0 DO MSG
  1. . SET VALMBCK="R"
  1. ;
  1. IF $P(LCKCHK,"^")'=1 SET VALMQUIT=""
  1. QUIT
  1. ;
  1. PKGSAVE ;Save Package Changes
  1. NEW NOWDT,INITIAL,PKGNME,WNFILE,WOFILE,FILENME,DEFDIR
  1. SET NOWDT=$$FMTE^XLFDT($$NOW^XLFDT,"2M")
  1. SET NOWDT=$TR(NOWDT,"/","-")
  1. SET NOWDT=$TR(NOWDT,"@","_")
  1. SET NOWDT=$TR(NOWDT,":","")
  1. SET INITIAL=$P($G(^VA(200,DUZ,0)),"^",2)
  1. IF INITIAL']"" SET INITIAL="<unk>"
  1. SET DEFDIR=$$GET^XPAR("SYS","XTVS PACKAGE MGR DEFAULT DIR",1,"I")
  1. ;
  1. SET (WNFILE,WOFILE)=0
  1. SET WNFILE=+$$YNCHK^XTVSLAPI("Do you want to create a new package parameters file")
  1. SET:'WNFILE WOFILE=+$$YNCHK^XTVSLAPI("Do you want to OVERWRITE the existing package parameters file")
  1. IF (WNFILE)!(WOFILE) DO
  1. . NEW DELRSLT
  1. . IF WNFILE SET FILENME="XTMPSIZE"_"_"_INITIAL_NOWDT_".DAT" ;Output a New Parameter file
  1. . ;
  1. . SET DELRSLT=1 ; Initialize DELRSLT (delete Result) variable
  1. . IF WOFILE DO ;Write Old File: FILENME remains the selected/displayed parameter file
  1. .. NEW DELFLE,OLDFNME,CHKLKER
  1. .. SET FILENME=XTVPSPRM
  1. .. IF FILENME[";" SET FILENME=$P(FILENME,";")
  1. .. SET OLDFNME=$P(FILENME,".")_".BAK"
  1. .. SET DELFLE(OLDFNME)="" SET DELRSLT=$$DEL^%ZISH(DEFDIR,$NA(DELFLE)) K DELFLE(OLDFNME) ;Delete current Parameter file
  1. .. SET DELRSLT=$$MV^%ZISH(DEFDIR,XTVPSPRM,DEFDIR,OLDFNME) ;Save current file to "BAK" before overwriting
  1. .. IF DELRSLT SET DELFLE(XTVPSPRM)="" SET DELRSLT=$$DEL^%ZISH(DEFDIR,$NA(DELFLE)) ;Delete current Parameter file
  1. .. SET FILENME=XTVPSPRM
  1. .. DO CRTFLE(DEFDIR,FILENME,WNFILE)
  1. . ;
  1. . ; If file name definitions and copies were completed successfully, create the Parameter file
  1. . IF DELRSLT DO
  1. .. IF WNFILE DO ;Write New File
  1. ... SET UNLKRSLT=$$UNLCKPFL^XTVSLAPI(XTVPSPRM)
  1. ... IF ($P(UNLKRSLT,"^")'=1) W !!," <* UNLOCK ERROR. Check LOCK file Integrity. *>"
  1. ... DO JUSTPAWS^XTVSLAPI($P(UNLKRSLT,"^",2))
  1. ... IF ($P(UNLKRSLT,"^")=1) DO CRTFLE(DEFDIR,FILENME,WNFILE)
  1. ;
  1. QUIT
  1. ;
  1. CRTFLE(DEFDIR,FILENME,WNFILE) ; Update old file/Write New file
  1. NEW POPERR,CHKLKER
  1. SET POPERR=0
  1. DO OPEN^%ZISH("XTMP",DEFDIR,FILENME,"A")
  1. SET:POP POPERR=POP
  1. IF 'POPERR DO
  1. . U IO
  1. . SET PKGNME=""
  1. . FOR SET PKGNME=$O(^TMP("XTVS-PARAM-CAP",$J,PKGNME)) QUIT:PKGNME']"" WRITE !,^TMP("XTVS-PARAM-CAP",$J,PKGNME)
  1. . D CLOSE^%ZISH("XTMP")
  1. . SET XTVPSPRM=FILENME
  1. . SET CHNGMADE=0
  1. . KILL ^TMP("XTVS-PARAM-BI",$J)
  1. . IF WNFILE DO
  1. .. SET CHKLKER=$$REQLOCK^XTVSLAPI(XTVPSPRM)
  1. .. DO JUSTPAWS^XTVSLAPI($P(CHKLKER,"^",2))
  1. QUIT
  1. ;
  1. SETADD(X) ; Add a new package to ^TMP("XTVS-PARAM-CAP")
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X)=X ;Create new entry in TMP global
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X,1,"Package Name")=X
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X,2,"Primary Prefix")=""
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X,3,"*Lowest File#")=""
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X,4,"*Highest File#")=""
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X,5,"Additional Prefixes")=""
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X,6,"Excepted Prefixes")=""
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X,7,"File Numbers")=""
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X,8,"File Ranges")=""
  1. SET ^TMP("XTVS-PARAM-CAP",$J,X,9,"Parent Package")=""
  1. QUIT
  1. ;
  1. SETSELAY(SELARY) ; Move Package names to SELARY from ^TMP("XTVS-PARAM-CAP") array
  1. NEW ITEMNUM,FILENME
  1. SET FILENME=""
  1. SET ITEMNUM=0
  1. FOR SET FILENME=$O(^TMP("XTVS-PARAM-CAP",$J,FILENME)) Q:FILENME="" DO
  1. . SET ITEMNUM=ITEMNUM+1 SET SELARY(ITEMNUM)=FILENME ;Parameter list
  1. QUIT ITEMNUM
  1. ;
  1. SPCPKGCK(XTVSSAVX,ITEMNUM,SELARY) ; Check for existence of the <SPACE> select package in SELARY
  1. NEW SELARYCT
  1. FOR SELARYCT=1:1:ITEMNUM QUIT:(SELARY(SELARYCT)=XTVSSAVX)
  1. IF (+SELARYCT+1)>(+ITEMNUM) W !!,"?? ",XTVSSAVX_" VistA package is undefined."
  1. QUIT