XTVSLPD2 ;Albany FO/GTS - VistA Package Sizing Manager - Caption display APIs; 14-DEC-2018
;;7.3;TOOLKIT;**143**;Apr 25, 1995;Build 116
;
;APIs 2
PRIMPFX(XTA,XTB,XTJUMPIN) ; Enter/Edit Primary Prefix
IF $G(XTJUMPIN) NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
NEW ADDPKG
;Package Added Indicator = 1 when Primary Primary Prefix XTVS-PARAM-CAP ^TMP global node is Null
SET ADDPKG=((^TMP("XTVS-PARAM-CAP",$J,PKGNME,DATANUM,"Primary Prefix")=""))
SET DIR("A")=XTA
SET:XTB]"" DIR("B")=XTB
SET DIR("?",1)="Enter Package Prefix from 2 to 4 characters."
SET DIR("?",2)=" (1 upper case letter followed by 1 - 3 upper case letters or numbers.)"
SET DIR("?",3)=" "
SET DIR("?",4)="Prefixes are used to identify Routines, Options, Protocols, etc. for the"
SET DIR("?")=" VistA Package Size report."
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(DIRUT,EDITARY,DATANUM,DATANAME,X)
. IF '$D(DIRUT),(@EDITARY@(DATANUM,DATANAME)'=X) SET @EDITARY@(DATANUM,DATANAME)=Y
. KILL DIRUT
IF ($D(DTOUT)!$D(DUOUT)!$D(DIROUT))&((ADDPKG)&(X="^")) DO
. KILL ^TMP("XTVS-PARAM-CAP",$J,PKGNME)
. DO HDR^XTVSLPDC,INIT^XTVSLPDC
. SET DATANUM=999 ;Do not prompt other fields
IF $D(DUOUT),(X["^"),($L(X)>1) DO
. IF ADDPKG DO
.. DO JUSTPAWS^XTVSLAPI(" Data Entry '^' JUMP not allowed before Primary Prefix is defined.")
.. W !
.. SET DATANUM=1
.. KILL DUOUT
. IF 'ADDPKG DO JUMP(X,DATANUM) SET DATANUM=DATANUM-1
QUIT
;
HILOFLE(XTA,XTB,XTJUMPIN) ; Enter/Edit High or Low File Number
IF $G(XTJUMPIN) NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
SET DIR("A")=XTA
SET:XTB]"" DIR("B")=XTB
SET DIR("?",1)=" Enter File Number 0 - 999999999, decimals are allowed."
SET DIR("?",2)=" "
SET DIR("?",3)=" When File Ranges are undefined and *Lowest File# & *Highest File# are"
SET DIR("?",4)=" defined, *Lowest File# - *Highest File# range is used to identify files"
SET DIR("?")=" assigned to the package for the VistA Package Size report."
SET DIR(0)="NOA^0:999999999:6"
DO ^DIR
IF ('$D(DTOUT)&('$D(DUOUT))) DO
. IF ($D(DIRUT)) DO UPDTNODE(DIRUT,EDITARY,DATANUM,DATANAME,X)
. IF '$D(DIRUT),(@EDITARY@(DATANUM,DATANAME)'=X) SET @EDITARY@(DATANUM,DATANAME)=Y
. KILL DIRUT
IF $D(DUOUT),(X["^") DO JUMP(X,DATANUM) SET DATANUM=DATANUM-1
QUIT
;
EXADPFX(XTA,XTB,XTJUMPIN) ; Enter/Edit Excepted or Additional Prefixes
NEW LISTDATA
IF $G(XTJUMPIN) NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
SET DIR("A")=XTA
SET:XTB]"" DIR("B")=XTB
SET GETOUT=0
FOR QUIT:GETOUT DO ;Edit Prefix List Loop
. SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
. DO SPLITOUT(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("?",1)="Enter a new Prefix or one from list. [Note: Entry is case sensitive.]"
. SET DIR("?",2)="Order of Prefixes listed is not significant."
. SET DIR("?",3)=" "
. SET DIR("?",4)="Additional and Excepted Prefixes are used to identify Routines, Options,"
. SET DIR("?",5)=" Protocols, etc. for the VistA Package Size reporting tool. Additional"
. SET DIR("?",6)=" Prefixes include components [that begin with the prefix] in the tally"
. SET DIR("?",7)=" totals for the component. Excepted Prefixes are refinements to the"
. SET DIR("?",8)=" Primary and Additional Prefixes to exclude subsets of component names"
. SET DIR("?")=" [that begin with the Excepted Prefixes] from the tally totals."
. 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(Y,.LISTDATA,.UPDATLST)
. IF GETOUT,$D(DUOUT),(X["^") DO JUMP(X,DATANUM) SET DATANUM=DATANUM-1
. IF UPDATLST SET @EDITARY@(DATANUM,DATANAME)=LISTDATA
QUIT
;
EDITPRFX(DATELEMT,LISTDATA,UPDATLST) ; Update Prefix list
NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,EDTELEMT,PCE
SET PCE=0
IF (LISTDATA["|"_DATELEMT_"|")!($P(LISTDATA,"|")=DATELEMT) SET PCE=$$PCEPOS(LISTDATA,DATELEMT)
SET DIR("A")=" Prefix: "
SET DIR("B")=DATELEMT
SET DIR("?")=" Enter/Edit a Prefix."
SET DIR(0)="FAO^2:6^K:(X'?1U1.5NU) X"
DO ^DIR
IF '$D(DTOUT)&'$D(DUOUT)&'$D(DIROUT) DO LSTEDT(X,PCE,DATELEMT,.LISTDATA,.UPDATLST)
QUIT
;
LSTEDT(EDTELEMT,PCE,DATELEMT,LISTDATA,UPDATLST) ;Edit List dialog
IF (PCE>0),(EDTELEMT'="@") SET $P(LISTDATA,"|",PCE)=EDTELEMT SET UPDATLST=1 ;EDIT ENTRY
IF (PCE>0),(EDTELEMT="@") DO
. IF +$$YNCHK^XTVSLAPI("DELETE ENTRY") SET LISTDATA=$P(LISTDATA,DATELEMT_"|",1)_$P(LISTDATA,DATELEMT_"|",2) SET UPDATLST=1
IF PCE'>0 DO
. IF EDTELEMT="@" W !,"?? ...Element not in list, cannot delete!" SET EDTELEMT=DATELEMT
. IF +$$YNCHK^XTVSLAPI("ADD ENTRY") SET LISTDATA=LISTDATA_EDTELEMT_"|" SET UPDATLST=1
QUIT
;
FLENUM(XTA,XTB,XTJUMPIN) ; Enter/Edit File number
NEW LISTDATA
IF $G(XTJUMPIN) NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
SET DIR("A")=XTA
SET:XTB]"" DIR("B")=XTB
SET GETOUT=0
FOR QUIT:GETOUT DO ;Edit Prefix List Loop
. SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
. DO SPLITOUT(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 the list."
. SET DIR("?",2)="New file numbers only between 1.9999 and 99999999.999999"
. SET DIR("?",3)="Order of File Numbers listed is not significant."
. SET DIR("?",4)=" "
. SET DIR("?",5)="When File Ranges and *Lowest File# & *Highest File# are undefined and"
. SET DIR("?",6)=" File Numbers exist, File Numbers are used to identify files assigned"
. SET DIR("?")=" to the package for the VistA Package Size report."
. 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(Y,.LISTDATA,.UPDATLST)
. IF GETOUT,$D(DUOUT),(X["^") DO JUMP(X,DATANUM) SET DATANUM=DATANUM-1
. IF UPDATLST SET @EDITARY@(DATANUM,DATANAME)=LISTDATA
QUIT
;
EDITFNUM(DATELEMT,LISTDATA,UPDATLST) ; Update File list
NEW DIR,DIRUT,DTOUT,DUOUT,EDTELEMT,PCE
SET PCE=0
IF (LISTDATA["|"_DATELEMT_"|")!($P(LISTDATA,"|")=DATELEMT) SET PCE=$$PCEPOS(LISTDATA,DATELEMT)
SET DIR("A")=" File Number: "
SET DIR("B")=DATELEMT
SET DIR("?")=" Enter/Edit a File Number."
SET DIR(0)="NAO^1.9999:99999999.999999:6"
DO ^DIR
IF '$D(DTOUT)&'$D(DUOUT)&'$D(DIROUT) DO LSTEDT(X,PCE,DATELEMT,.LISTDATA,.UPDATLST)
QUIT
;
FLERNG(XTA,XTB,XTJUMPIN) ; Enter/Edit File Range
NEW LISTDATA
IF $G(XTJUMPIN) NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
SET DIR("A")=XTA
SET:XTB]"" DIR("B")=XTB
SET GETOUT=0
FOR QUIT:GETOUT DO ;Edit Prefix List Loop
. SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
. DO SPLITOUT(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("?",2)="New file number ranges only between 1.9999 and 99999999.999999"
. SET DIR("?",3)="Order of File Ranges listed is not significant."
. SET DIR("?",4)="Example of a file range would be 500-501.9 with no spaces."
. SET DIR("?",5)=" "
. SET DIR("?",6)="If File Ranges are defined, they are used to identify files assigned to"
. SET DIR("?",7)=" the package whether or not *Lowest File# & *Highest File# or File"
. SET DIR("?")=" Numbers are defined."
. SET DIR(0)="FAO^3:31^K:$$BADRNG^XTVSLPD1(X) X"
. DO ^DIR
. IF (Y=-1)!(Y="")!(Y="@")!($D(DTOUT))!($D(DUOUT)) SET GETOUT=1
. SET UPDATLST=0
. IF 'GETOUT DO EDITFRNG(Y,.LISTDATA,.UPDATLST)
. IF GETOUT,$D(DUOUT),(X["^") DO JUMP(X,DATANUM) SET DATANUM=DATANUM-1
. IF UPDATLST SET @EDITARY@(DATANUM,DATANAME)=LISTDATA
QUIT
;
EDITFRNG(DATELEMT,LISTDATA,UPDATLST) ; Update File Range
NEW DIR,DIRUT,DTOUT,DUOUT,EDTELEMT,PCE
SET PCE=0
IF (LISTDATA["|"_DATELEMT_"|")!($P(LISTDATA,"|")=DATELEMT) SET PCE=$$PCEPOS(LISTDATA,DATELEMT)
SET DIR("A")=" File Number Range: "
SET DIR("B")=DATELEMT
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^XTVSLPD1(X) X"
DO ^DIR
IF '$D(DTOUT)&'$D(DUOUT)&'$D(DIROUT) DO LSTEDT(X,PCE,DATELEMT,.LISTDATA,.UPDATLST)
QUIT
;
PRNTPKG(XTA,XTB,XTJUMPIN) ; Enter/edit parent Package
IF $G(XTJUMPIN) NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
SET DIR("A")=XTA
SET:XTB]"" DIR("B")=XTB
SET DIR("A",1)=" "
SET DIR("PRE")="DO:(X'=""@""&(X'[""^"")) CHKX^XTVSLPDC(0)" ;Check X for existing package
SET DIR("?")="^DO PKGHLP^XTVSLPDC(1)"
SET DIR(0)="FAOr^4:40^K:('(X'?1P.E)) X"
DO ^DIR
IF ('$D(DTOUT)&('$D(DUOUT))) DO
. IF ($D(DIRUT)) DO UPDTNODE(DIRUT,EDITARY,DATANUM,DATANAME,X)
. IF '$D(DIRUT),(@EDITARY@(DATANUM,DATANAME)'=X) SET @EDITARY@(DATANUM,DATANAME)=Y
IF $D(DUOUT),(X["^") DO JUMP(X,DATANUM) SET DATANUM=DATANUM-1
QUIT
;
JUMP(XVAL,XTOLDNUM) ; Jump to a data element during edit
NEW DTELMT,CT,SUBRTN,XTDONE,DATANAME,DIR,DATANUM,XTFOUND
SET (XTFOUND,XTDONE)=0
IF (XVAL?1"^"0.1"*"1.A0.1" "1.A0.1"#"),(XVAL'="^") DO
. SET XVAL=$$UP^XLFSTR($P(XVAL,"^",2))
. IF (XTOLDNUM'=7),(XTOLDNUM'=8),($$CKMATCH(XVAL,"FILE ")) S DTELMT=$$FLESEL() DO:DTELMT]"" JUMPEXC SET XTDONE=1
. FOR CT=2:1 SET DTELMT=$TEXT(DATANAME+CT) QUIT:$P(DTELMT," ;;",2)="QUIT" QUIT:XTDONE DO
.. IF ($P($P(DTELMT," ;;",2),"^")[XVAL),($$CKMATCH(XVAL,$P($P(DTELMT," ;;",2),"^"))),($P($P(DTELMT," ;;",2),"^",2)'=XTOLDNUM) DO
... DO JUMPEXC
... SET XTDONE=1
. IF 'XTFOUND W " ??" KILL DUOUT,X
. IF XTFOUND W !," Return to "_$P($P($TEXT(DATANAME+XTOLDNUM)," ;;",2),"^",1)_"..."
QUIT
;
JUMPEXC ;Jump to selected field [from JUMP api]
SET XTFOUND=1
SET DATANUM=$P($P(DTELMT," ;;",2),"^",2)
SET DATANAME=$O(@EDITARY@(DATANUM,""))
SET DIR("A")=DATANAME_": " ;Set DIR("A") prompt
SET DIR("B")=$G(@EDITARY@(DATANUM,DATANAME)) ;Set Prompt for DIR read
DO @$P($P(DTELMT," ;;",2),"^",3)
KILL DUOUT
QUIT
;
CKMATCH(XTIN,XTDATNM) ; Check for sub-string match to data element name
NEW RESULT
SET RESULT=(XTIN=$E(XTDATNM,1,$L(XTIN)))
QUIT RESULT
;
FLESEL() ; Select FILE data element for JUMP
NEW RESULT,DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
SET RESULT=""
SET DIR("A")=" Data Element Number: "
SET DIR("?")=" Enter number 1 or 2."
SET DIR("A",1)=" "
SET DIR("A",2)=" Select Data Element:"
SET DIR("A",3)=" 1) File Numbers"
SET DIR("A",4)=" 2) File Ranges"
;SET DIR("A",5)=" "
SET DIR(0)="NA^1:2"
DO ^DIR
IF '$D(DIRUT) SET RESULT=$TEXT(DATANAME+(6+Y))
QUIT RESULT
;
UPDTNODE(UPDIRUT,EDITARY,DATANUM,DATANAME,UPDX) ;Update ^TMP("XTVS-PARAM-CAP") array node with edits
IF ('$D(UPDIRUT)) SET @EDITARY@(DATANUM,DATANAME)=UPDX
IF $D(UPDIRUT) DO
. IF (UPDX="@"),(@EDITARY@(DATANUM,DATANAME)'="") DO
.. IF +$$YNCHK^XTVSLAPI("DELETE ENTRY") SET @EDITARY@(DATANUM,DATANAME)=""
. IF (UPDX'="@"),(@EDITARY@(DATANUM,DATANAME)'=UPDX) SET @EDITARY@(DATANUM,DATANAME)=UPDX
QUIT
;
SPLITOUT(DATANAME,LISTDATA) ; -- Split list data to separate lines as needed and output
; DATANAME - Data element name
; LISTDATA - Data element list
;
NEW LINE,PCENUM,LISTPCE,NXSTPCE
WRITE !!!,DATANAME_":"
IF LISTDATA']"" W !,"{no data list}"
IF LISTDATA]"" DO
. IF $L(LISTDATA)'>79 W !,LISTDATA
. IF $L(LISTDATA)>79 DO
.. SET LINE=""
.. SET NXSTPCE=1
.. FOR PCENUM=1:1 SET LISTPCE=$P(LISTDATA,"|",PCENUM) Q:LISTPCE="" DO
... IF $L($P(LISTDATA,"|",NXSTPCE,PCENUM))>79 W !,$P(LISTDATA,"|",NXSTPCE,PCENUM-1) SET NXSTPCE=PCENUM
.. W !,$P(LISTDATA,"|",NXSTPCE,999)
WRITE !
QUIT
;
PCEPOS(LISTDATA,DATELEMT) ; Return the piece position number of DATELEMT in LISTDATA
NEW PCE,DELIMPOS,ITEM
FOR PCE=1:1 SET ITEM=$P(LISTDATA,"|",PCE) Q:ITEM=DATELEMT IF ITEM="" SET PCE=0 QUIT
QUIT PCE
;
DATANAME ; Package Parameter data element names
;;PACKAGE NAME^1^PKGNME(DIR("A"),DIR("B"),1);;<place holder if Package name becomes editable>
;;PRIMARY PREFIX^2^PRIMPFX(DIR("A"),DIR("B"),1)
;;*LOWEST FILE#^3^HILOFLE(DIR("A"),DIR("B"),1)
;;*HIGHEST FILE#^4^HILOFLE(DIR("A"),DIR("B"),1)
;;ADDITIONAL PREFIXES^5^EXADPFX(DIR("A"),DIR("B"),1)
;;EXCEPTED PREFIXES^6^EXADPFX(DIR("A"),DIR("B"),1)
;;FILE NUMBERS^7^FLENUM(DIR("A"),DIR("B"),1)
;;FILE RANGES^8^FLERNG(DIR("A"),DIR("B"),1)
;;PARENT PACKAGE^9^PRNTPKG(DIR("A"),DIR("B"),1)
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLPD2 12704 printed Nov 22, 2024@17:52:09 Page 2
XTVSLPD2 ;Albany FO/GTS - VistA Package Sizing Manager - Caption display APIs; 14-DEC-2018
+1 ;;7.3;TOOLKIT;**143**;Apr 25, 1995;Build 116
+2 ;
+3 ;APIs 2
PRIMPFX(XTA,XTB,XTJUMPIN) ; Enter/Edit Primary Prefix
+1 IF $GET(XTJUMPIN)
NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
+2 NEW ADDPKG
+3 ;Package Added Indicator = 1 when Primary Primary Prefix XTVS-PARAM-CAP ^TMP global node is Null
+4 SET ADDPKG=((^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,DATANUM,"Primary Prefix")=""))
+5 SET DIR("A")=XTA
+6 if XTB]""
SET DIR("B")=XTB
+7 SET DIR("?",1)="Enter Package Prefix from 2 to 4 characters."
+8 SET DIR("?",2)=" (1 upper case letter followed by 1 - 3 upper case letters or numbers.)"
+9 SET DIR("?",3)=" "
+10 SET DIR("?",4)="Prefixes are used to identify Routines, Options, Protocols, etc. for the"
+11 SET DIR("?")=" VistA Package Size report."
+12 SET DIR(0)="FA^2:4^K:$L(X)>4!(X'?1U1.3NU) X"
+13 DO ^DIR
+14 IF ('$DATA(DTOUT)&('$DATA(DUOUT)))
Begin DoDot:1
+15 IF ($DATA(DIRUT))
DO UPDTNODE(DIRUT,EDITARY,DATANUM,DATANAME,X)
+16 IF '$DATA(DIRUT)
IF (@EDITARY@(DATANUM,DATANAME)'=X)
SET @EDITARY@(DATANUM,DATANAME)=Y
+17 KILL DIRUT
End DoDot:1
+18 IF ($DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT))&((ADDPKG)&(X="^"))
Begin DoDot:1
+19 KILL ^TMP("XTVS-PARAM-CAP",$JOB,PKGNME)
+20 DO HDR^XTVSLPDC
DO INIT^XTVSLPDC
+21 ;Do not prompt other fields
SET DATANUM=999
End DoDot:1
+22 IF $DATA(DUOUT)
IF (X["^")
IF ($LENGTH(X)>1)
Begin DoDot:1
+23 IF ADDPKG
Begin DoDot:2
+24 DO JUSTPAWS^XTVSLAPI(" Data Entry '^' JUMP not allowed before Primary Prefix is defined.")
+25 WRITE !
+26 SET DATANUM=1
+27 KILL DUOUT
End DoDot:2
+28 IF 'ADDPKG
DO JUMP(X,DATANUM)
SET DATANUM=DATANUM-1
End DoDot:1
+29 QUIT
+30 ;
HILOFLE(XTA,XTB,XTJUMPIN) ; Enter/Edit High or Low File Number
+1 IF $GET(XTJUMPIN)
NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
+2 SET DIR("A")=XTA
+3 if XTB]""
SET DIR("B")=XTB
+4 SET DIR("?",1)=" Enter File Number 0 - 999999999, decimals are allowed."
+5 SET DIR("?",2)=" "
+6 SET DIR("?",3)=" When File Ranges are undefined and *Lowest File# & *Highest File# are"
+7 SET DIR("?",4)=" defined, *Lowest File# - *Highest File# range is used to identify files"
+8 SET DIR("?")=" assigned to the package for the VistA Package Size report."
+9 SET DIR(0)="NOA^0:999999999:6"
+10 DO ^DIR
+11 IF ('$DATA(DTOUT)&('$DATA(DUOUT)))
Begin DoDot:1
+12 IF ($DATA(DIRUT))
DO UPDTNODE(DIRUT,EDITARY,DATANUM,DATANAME,X)
+13 IF '$DATA(DIRUT)
IF (@EDITARY@(DATANUM,DATANAME)'=X)
SET @EDITARY@(DATANUM,DATANAME)=Y
+14 KILL DIRUT
End DoDot:1
+15 IF $DATA(DUOUT)
IF (X["^")
DO JUMP(X,DATANUM)
SET DATANUM=DATANUM-1
+16 QUIT
+17 ;
EXADPFX(XTA,XTB,XTJUMPIN) ; Enter/Edit Excepted or Additional Prefixes
+1 NEW LISTDATA
+2 IF $GET(XTJUMPIN)
NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
+3 SET DIR("A")=XTA
+4 if XTB]""
SET DIR("B")=XTB
+5 SET GETOUT=0
+6 ;Edit Prefix List Loop
FOR
if GETOUT
QUIT
Begin DoDot:1
+7 SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
+8 ;Display Listed data to screen for user
DO SPLITOUT(DATANAME,LISTDATA)
+9 SET PPRMT="Enter "_$SELECT(DATANUM=5:"Additional",1:"Excepted")_" Prefix: "
+10 ;RESET DIR("A") default prompt
SET DIR("A")=PPRMT
+11 ;No default, select from list
KILL DIR("B")
+12 SET DIR("?",1)="Enter a new Prefix or one from list. [Note: Entry is case sensitive.]"
+13 SET DIR("?",2)="Order of Prefixes listed is not significant."
+14 SET DIR("?",3)=" "
+15 SET DIR("?",4)="Additional and Excepted Prefixes are used to identify Routines, Options,"
+16 SET DIR("?",5)=" Protocols, etc. for the VistA Package Size reporting tool. Additional"
+17 SET DIR("?",6)=" Prefixes include components [that begin with the prefix] in the tally"
+18 SET DIR("?",7)=" totals for the component. Excepted Prefixes are refinements to the"
+19 SET DIR("?",8)=" Primary and Additional Prefixes to exclude subsets of component names"
+20 SET DIR("?")=" [that begin with the Excepted Prefixes] from the tally totals."
+21 SET DIR(0)="FAO^2:6^K:(X'?1U1.5NU) X"
+22 DO ^DIR
+23 IF (Y=-1)!(Y="")!(Y="@")!($DATA(DTOUT))!($DATA(DUOUT))
SET GETOUT=1
+24 SET UPDATLST=0
+25 IF 'GETOUT
DO EDITPRFX(Y,.LISTDATA,.UPDATLST)
+26 IF GETOUT
IF $DATA(DUOUT)
IF (X["^")
DO JUMP(X,DATANUM)
SET DATANUM=DATANUM-1
+27 IF UPDATLST
SET @EDITARY@(DATANUM,DATANAME)=LISTDATA
End DoDot:1
+28 QUIT
+29 ;
EDITPRFX(DATELEMT,LISTDATA,UPDATLST) ; Update Prefix list
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,EDTELEMT,PCE
+2 SET PCE=0
+3 IF (LISTDATA["|"_DATELEMT_"|")!($PIECE(LISTDATA,"|")=DATELEMT)
SET PCE=$$PCEPOS(LISTDATA,DATELEMT)
+4 SET DIR("A")=" Prefix: "
+5 SET DIR("B")=DATELEMT
+6 SET DIR("?")=" Enter/Edit a Prefix."
+7 SET DIR(0)="FAO^2:6^K:(X'?1U1.5NU) X"
+8 DO ^DIR
+9 IF '$DATA(DTOUT)&'$DATA(DUOUT)&'$DATA(DIROUT)
DO LSTEDT(X,PCE,DATELEMT,.LISTDATA,.UPDATLST)
+10 QUIT
+11 ;
LSTEDT(EDTELEMT,PCE,DATELEMT,LISTDATA,UPDATLST) ;Edit List dialog
+1 ;EDIT ENTRY
IF (PCE>0)
IF (EDTELEMT'="@")
SET $PIECE(LISTDATA,"|",PCE)=EDTELEMT
SET UPDATLST=1
+2 IF (PCE>0)
IF (EDTELEMT="@")
Begin DoDot:1
+3 IF +$$YNCHK^XTVSLAPI("DELETE ENTRY")
SET LISTDATA=$PIECE(LISTDATA,DATELEMT_"|",1)_$PIECE(LISTDATA,DATELEMT_"|",2)
SET UPDATLST=1
End DoDot:1
+4 IF PCE'>0
Begin DoDot:1
+5 IF EDTELEMT="@"
WRITE !,"?? ...Element not in list, cannot delete!"
SET EDTELEMT=DATELEMT
+6 IF +$$YNCHK^XTVSLAPI("ADD ENTRY")
SET LISTDATA=LISTDATA_EDTELEMT_"|"
SET UPDATLST=1
End DoDot:1
+7 QUIT
+8 ;
FLENUM(XTA,XTB,XTJUMPIN) ; Enter/Edit File number
+1 NEW LISTDATA
+2 IF $GET(XTJUMPIN)
NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
+3 SET DIR("A")=XTA
+4 if XTB]""
SET DIR("B")=XTB
+5 SET GETOUT=0
+6 ;Edit Prefix List Loop
FOR
if GETOUT
QUIT
Begin DoDot:1
+7 SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
+8 ;Display Listed data to screen for user
DO SPLITOUT(DATANAME,LISTDATA)
+9 ;RESET DIR("A") default prompt
SET DIR("A")="Enter File Number: "
+10 ;No default, select from list
KILL DIR("B")
+11 SET DIR("?",1)="Enter a new File Number or one from the list."
+12 SET DIR("?",2)="New file numbers only between 1.9999 and 99999999.999999"
+13 SET DIR("?",3)="Order of File Numbers listed is not significant."
+14 SET DIR("?",4)=" "
+15 SET DIR("?",5)="When File Ranges and *Lowest File# & *Highest File# are undefined and"
+16 SET DIR("?",6)=" File Numbers exist, File Numbers are used to identify files assigned"
+17 SET DIR("?")=" to the package for the VistA Package Size report."
+18 SET DIR(0)="NAO^1.9999:99999999.999999:6"
+19 DO ^DIR
+20 IF (Y=-1)!(Y="")!(Y="@")!($DATA(DTOUT))!($DATA(DUOUT))
SET GETOUT=1
+21 SET UPDATLST=0
+22 IF 'GETOUT
DO EDITFNUM(Y,.LISTDATA,.UPDATLST)
+23 IF GETOUT
IF $DATA(DUOUT)
IF (X["^")
DO JUMP(X,DATANUM)
SET DATANUM=DATANUM-1
+24 IF UPDATLST
SET @EDITARY@(DATANUM,DATANAME)=LISTDATA
End DoDot:1
+25 QUIT
+26 ;
EDITFNUM(DATELEMT,LISTDATA,UPDATLST) ; Update File list
+1 NEW DIR,DIRUT,DTOUT,DUOUT,EDTELEMT,PCE
+2 SET PCE=0
+3 IF (LISTDATA["|"_DATELEMT_"|")!($PIECE(LISTDATA,"|")=DATELEMT)
SET PCE=$$PCEPOS(LISTDATA,DATELEMT)
+4 SET DIR("A")=" File Number: "
+5 SET DIR("B")=DATELEMT
+6 SET DIR("?")=" Enter/Edit a File Number."
+7 SET DIR(0)="NAO^1.9999:99999999.999999:6"
+8 DO ^DIR
+9 IF '$DATA(DTOUT)&'$DATA(DUOUT)&'$DATA(DIROUT)
DO LSTEDT(X,PCE,DATELEMT,.LISTDATA,.UPDATLST)
+10 QUIT
+11 ;
FLERNG(XTA,XTB,XTJUMPIN) ; Enter/Edit File Range
+1 NEW LISTDATA
+2 IF $GET(XTJUMPIN)
NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
+3 SET DIR("A")=XTA
+4 if XTB]""
SET DIR("B")=XTB
+5 SET GETOUT=0
+6 ;Edit Prefix List Loop
FOR
if GETOUT
QUIT
Begin DoDot:1
+7 SET LISTDATA=@EDITARY@(DATANUM,DATANAME)
+8 ;Display Listed data to screen for user
DO SPLITOUT(DATANAME,LISTDATA)
+9 ;RESET DIR("A") default prompt
SET DIR("A")="Enter File Number Range: "
+10 ;No default, select from list
KILL DIR("B")
+11 SET DIR("?",1)="Enter a new File Number Range or one from the list."
+12 SET DIR("?",2)="New file number ranges only between 1.9999 and 99999999.999999"
+13 SET DIR("?",3)="Order of File Ranges listed is not significant."
+14 SET DIR("?",4)="Example of a file range would be 500-501.9 with no spaces."
+15 SET DIR("?",5)=" "
+16 SET DIR("?",6)="If File Ranges are defined, they are used to identify files assigned to"
+17 SET DIR("?",7)=" the package whether or not *Lowest File# & *Highest File# or File"
+18 SET DIR("?")=" Numbers are defined."
+19 SET DIR(0)="FAO^3:31^K:$$BADRNG^XTVSLPD1(X) X"
+20 DO ^DIR
+21 IF (Y=-1)!(Y="")!(Y="@")!($DATA(DTOUT))!($DATA(DUOUT))
SET GETOUT=1
+22 SET UPDATLST=0
+23 IF 'GETOUT
DO EDITFRNG(Y,.LISTDATA,.UPDATLST)
+24 IF GETOUT
IF $DATA(DUOUT)
IF (X["^")
DO JUMP(X,DATANUM)
SET DATANUM=DATANUM-1
+25 IF UPDATLST
SET @EDITARY@(DATANUM,DATANAME)=LISTDATA
End DoDot:1
+26 QUIT
+27 ;
EDITFRNG(DATELEMT,LISTDATA,UPDATLST) ; Update File Range
+1 NEW DIR,DIRUT,DTOUT,DUOUT,EDTELEMT,PCE
+2 SET PCE=0
+3 IF (LISTDATA["|"_DATELEMT_"|")!($PIECE(LISTDATA,"|")=DATELEMT)
SET PCE=$$PCEPOS(LISTDATA,DATELEMT)
+4 SET DIR("A")=" File Number Range: "
+5 SET DIR("B")=DATELEMT
+6 SET DIR("?",1)=" Enter a new File Number Range or one from the list."
+7 SET DIR("?")="New file number ranges only between 1.9999 and 99999999.999999"
+8 SET DIR(0)="FAO^3:31^K:$$BADRNG^XTVSLPD1(X) X"
+9 DO ^DIR
+10 IF '$DATA(DTOUT)&'$DATA(DUOUT)&'$DATA(DIROUT)
DO LSTEDT(X,PCE,DATELEMT,.LISTDATA,.UPDATLST)
+11 QUIT
+12 ;
PRNTPKG(XTA,XTB,XTJUMPIN) ; Enter/edit parent Package
+1 IF $GET(XTJUMPIN)
NEW DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
+2 SET DIR("A")=XTA
+3 if XTB]""
SET DIR("B")=XTB
+4 SET DIR("A",1)=" "
+5 ;Check X for existing package
SET DIR("PRE")="DO:(X'=""@""&(X'[""^"")) CHKX^XTVSLPDC(0)"
+6 SET DIR("?")="^DO PKGHLP^XTVSLPDC(1)"
+7 SET DIR(0)="FAOr^4:40^K:('(X'?1P.E)) X"
+8 DO ^DIR
+9 IF ('$DATA(DTOUT)&('$DATA(DUOUT)))
Begin DoDot:1
+10 IF ($DATA(DIRUT))
DO UPDTNODE(DIRUT,EDITARY,DATANUM,DATANAME,X)
+11 IF '$DATA(DIRUT)
IF (@EDITARY@(DATANUM,DATANAME)'=X)
SET @EDITARY@(DATANUM,DATANAME)=Y
End DoDot:1
+12 IF $DATA(DUOUT)
IF (X["^")
DO JUMP(X,DATANUM)
SET DATANUM=DATANUM-1
+13 QUIT
+14 ;
JUMP(XVAL,XTOLDNUM) ; Jump to a data element during edit
+1 NEW DTELMT,CT,SUBRTN,XTDONE,DATANAME,DIR,DATANUM,XTFOUND
+2 SET (XTFOUND,XTDONE)=0
+3 IF (XVAL?1"^"0.1"*"1.A0.1" "1.A0.1"#")
IF (XVAL'="^")
Begin DoDot:1
+4 SET XVAL=$$UP^XLFSTR($PIECE(XVAL,"^",2))
+5 IF (XTOLDNUM'=7)
IF (XTOLDNUM'=8)
IF ($$CKMATCH(XVAL,"FILE "))
SET DTELMT=$$FLESEL()
if DTELMT]""
DO JUMPEXC
SET XTDONE=1
+6 FOR CT=2:1
SET DTELMT=$TEXT(DATANAME+CT)
if $PIECE(DTELMT," ;;",2)="QUIT"
QUIT
if XTDONE
QUIT
Begin DoDot:2
+7 IF ($PIECE($PIECE(DTELMT," ;;",2),"^")[XVAL)
IF ($$CKMATCH(XVAL,$PIECE($PIECE(DTELMT," ;;",2),"^")))
IF ($PIECE($PIECE(DTELMT," ;;",2),"^",2)'=XTOLDNUM)
Begin DoDot:3
+8 DO JUMPEXC
+9 SET XTDONE=1
End DoDot:3
End DoDot:2
+10 IF 'XTFOUND
WRITE " ??"
KILL DUOUT,X
+11 IF XTFOUND
WRITE !," Return to "_$PIECE($PIECE($TEXT(DATANAME+XTOLDNUM)," ;;",2),"^",1)_"..."
End DoDot:1
+12 QUIT
+13 ;
JUMPEXC ;Jump to selected field [from JUMP api]
+1 SET XTFOUND=1
+2 SET DATANUM=$PIECE($PIECE(DTELMT," ;;",2),"^",2)
+3 SET DATANAME=$ORDER(@EDITARY@(DATANUM,""))
+4 ;Set DIR("A") prompt
SET DIR("A")=DATANAME_": "
+5 ;Set Prompt for DIR read
SET DIR("B")=$GET(@EDITARY@(DATANUM,DATANAME))
+6 DO @$PIECE($PIECE(DTELMT," ;;",2),"^",3)
+7 KILL DUOUT
+8 QUIT
+9 ;
CKMATCH(XTIN,XTDATNM) ; Check for sub-string match to data element name
+1 NEW RESULT
+2 SET RESULT=(XTIN=$EXTRACT(XTDATNM,1,$LENGTH(XTIN)))
+3 QUIT RESULT
+4 ;
FLESEL() ; Select FILE data element for JUMP
+1 NEW RESULT,DIR,X,Y,DUOUT,DIROUT,DTOUT,DIRUT
+2 SET RESULT=""
+3 SET DIR("A")=" Data Element Number: "
+4 SET DIR("?")=" Enter number 1 or 2."
+5 SET DIR("A",1)=" "
+6 SET DIR("A",2)=" Select Data Element:"
+7 SET DIR("A",3)=" 1) File Numbers"
+8 SET DIR("A",4)=" 2) File Ranges"
+9 ;SET DIR("A",5)=" "
+10 SET DIR(0)="NA^1:2"
+11 DO ^DIR
+12 IF '$DATA(DIRUT)
SET RESULT=$TEXT(DATANAME+(6+Y))
+13 QUIT RESULT
+14 ;
UPDTNODE(UPDIRUT,EDITARY,DATANUM,DATANAME,UPDX) ;Update ^TMP("XTVS-PARAM-CAP") array node with edits
+1 IF ('$DATA(UPDIRUT))
SET @EDITARY@(DATANUM,DATANAME)=UPDX
+2 IF $DATA(UPDIRUT)
Begin DoDot:1
+3 IF (UPDX="@")
IF (@EDITARY@(DATANUM,DATANAME)'="")
Begin DoDot:2
+4 IF +$$YNCHK^XTVSLAPI("DELETE ENTRY")
SET @EDITARY@(DATANUM,DATANAME)=""
End DoDot:2
+5 IF (UPDX'="@")
IF (@EDITARY@(DATANUM,DATANAME)'=UPDX)
SET @EDITARY@(DATANUM,DATANAME)=UPDX
End DoDot:1
+6 QUIT
+7 ;
SPLITOUT(DATANAME,LISTDATA) ; -- Split list data to separate lines as needed and output
+1 ; DATANAME - Data element name
+2 ; LISTDATA - Data element list
+3 ;
+4 NEW LINE,PCENUM,LISTPCE,NXSTPCE
+5 WRITE !!!,DATANAME_":"
+6 IF LISTDATA']""
WRITE !,"{no data list}"
+7 IF LISTDATA]""
Begin DoDot:1
+8 IF $LENGTH(LISTDATA)'>79
WRITE !,LISTDATA
+9 IF $LENGTH(LISTDATA)>79
Begin DoDot:2
+10 SET LINE=""
+11 SET NXSTPCE=1
+12 FOR PCENUM=1:1
SET LISTPCE=$PIECE(LISTDATA,"|",PCENUM)
if LISTPCE=""
QUIT
Begin DoDot:3
+13 IF $LENGTH($PIECE(LISTDATA,"|",NXSTPCE,PCENUM))>79
WRITE !,$PIECE(LISTDATA,"|",NXSTPCE,PCENUM-1)
SET NXSTPCE=PCENUM
End DoDot:3
+14 WRITE !,$PIECE(LISTDATA,"|",NXSTPCE,999)
End DoDot:2
End DoDot:1
+15 WRITE !
+16 QUIT
+17 ;
PCEPOS(LISTDATA,DATELEMT) ; Return the piece position number of DATELEMT in LISTDATA
+1 NEW PCE,DELIMPOS,ITEM
+2 FOR PCE=1:1
SET ITEM=$PIECE(LISTDATA,"|",PCE)
if ITEM=DATELEMT
QUIT
IF ITEM=""
SET PCE=0
QUIT
+3 QUIT PCE
+4 ;
DATANAME ; Package Parameter data element names
+1 ;;PACKAGE NAME^1^PKGNME(DIR("A"),DIR("B"),1);;<place holder if Package name becomes editable>
+2 ;;PRIMARY PREFIX^2^PRIMPFX(DIR("A"),DIR("B"),1)
+3 ;;*LOWEST FILE#^3^HILOFLE(DIR("A"),DIR("B"),1)
+4 ;;*HIGHEST FILE#^4^HILOFLE(DIR("A"),DIR("B"),1)
+5 ;;ADDITIONAL PREFIXES^5^EXADPFX(DIR("A"),DIR("B"),1)
+6 ;;EXCEPTED PREFIXES^6^EXADPFX(DIR("A"),DIR("B"),1)
+7 ;;FILE NUMBERS^7^FLENUM(DIR("A"),DIR("B"),1)
+8 ;;FILE RANGES^8^FLERNG(DIR("A"),DIR("B"),1)
+9 ;;PARENT PACKAGE^9^PRNTPKG(DIR("A"),DIR("B"),1)
+10 ;;QUIT
