XTVSLPD1 ;ALBANY FO/GTS - VistA Package Sizing Manager - Caption display APIs; 12-JUL-2016
;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
;APIs
BADRNG(X) ;Checks user entered File Range (used by DIR call)
SET RESULT=0
IF ((X'?1.N."."0.6N1"-"1.N."."0.6N)!($P(X,"-",2)<$P(X,"-"))) SET RESULT=1
QUIT RESULT
;
SETSTR(CAPARY) ;Return a string of Package File Lineitem (Concatonate fields to 1 HDR line)
NEW LINEITM,LPCNT,FLD
SET LINEITM=""
SET LPCNT=0
FOR SET LPCNT=$O(@CAPARY@(LPCNT)) Q:LPCNT="" DO
. SET FLD=$O(@CAPARY@(LPCNT,""))
. SET LINEITM=LINEITM_@CAPARY@(LPCNT,FLD)_$S(LPCNT<9:"^",1:"")
QUIT LINEITM
;
EDPKGPRM(PKGNME) ; Edit Package Parameters
NEW DATANUM,EDITARY,DATANAME,GETOUT,UPDATLST
SET EDITARY="^TMP(""XTVS-PARAM-CAP"","_$J_","""_PKGNME_""")"
SET 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 PRIMPFX^XTVSLPD2(DIR("A"),$G(DIR("B")))
. ;
. ;*Lowest File# (3) & *Highest File# (4)
. IF ((DATANUM=3)!(DATANUM=4)) DO HILOFLE^XTVSLPD2(DIR("A"),$G(DIR("B")))
. ;
. ;Additional Prefixes (5) & Excepted Prefixes (6)
. IF ((DATANUM=5)!(DATANUM=6)) DO EXADPFX^XTVSLPD2(DIR("A"),$G(DIR("B")))
. ;
. ; File Numbers (7)
. IF (DATANUM=7) DO FLENUM^XTVSLPD2(DIR("A"),$G(DIR("B")))
. ;
. ; File Ranges (8)
. IF (DATANUM=8) DO FLERNG^XTVSLPD2(DIR("A"),$G(DIR("B")))
. ;
. ;Parent Package (9)
. IF (DATANUM=9) DO PRNTPKG^XTVSLPD2(DIR("A"),$G(DIR("B")))
. ;
. KILL DIR,X,Y
;
KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
QUIT
;
EDCHK(PKGNME) ; Check for edit
; Input PKGNME - Name of selected package
; Output XTEDIT - 0: Not Edited
; 1: Edited
NEW XTEDIT
SET XTEDIT=0
SET:'XTEDIT XTEDIT=(^TMP("XTVS-PARAM-BI",$J,PKGNME,2,"Primary Prefix")'=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,2,"Primary Prefix")))
SET:'XTEDIT XTEDIT=(^TMP("XTVS-PARAM-BI",$J,PKGNME,3,"*Lowest File#")'=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,3,"*Lowest File#")))
SET:'XTEDIT XTEDIT=(^TMP("XTVS-PARAM-BI",$J,PKGNME,4,"*Highest File#")'=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,4,"*Highest File#")))
IF 'XTEDIT DO ;If no edit yet, first check for a difference in BI and CAP nodes
. SET XTEDIT=(^TMP("XTVS-PARAM-BI",$J,PKGNME,5,"Additional Prefixes")'=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,5,"Additional Prefixes")))
. IF XTEDIT DO ;If a difference between BI and CAP nodes, check for data reorg
.. NEW BIDATA,EDDATA
.. SET BIDATA=$G(^TMP("XTVS-PARAM-BI",$J,PKGNME,5,"Additional Prefixes"))
.. SET EDDATA=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,5,"Additional Prefixes"))
.. SET XTEDIT=$$DATCHK(BIDATA,EDDATA)
IF 'XTEDIT DO
. SET XTEDIT=(^TMP("XTVS-PARAM-BI",$J,PKGNME,6,"Excepted Prefixes")'=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,6,"Excepted Prefixes")))
. IF XTEDIT DO
.. NEW BIDATA,EDDATA
.. SET BIDATA=$G(^TMP("XTVS-PARAM-BI",$J,PKGNME,6,"Excepted Prefixes"))
.. SET EDDATA=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,6,"Excepted Prefixes"))
.. SET XTEDIT=$$DATCHK(BIDATA,EDDATA)
IF 'XTEDIT DO
. SET XTEDIT=(^TMP("XTVS-PARAM-BI",$J,PKGNME,7,"File Numbers")'=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,7,"File Numbers")))
. IF XTEDIT DO
.. NEW BIDATA,EDDATA
.. SET BIDATA=$G(^TMP("XTVS-PARAM-BI",$J,PKGNME,7,"File Numbers"))
.. SET EDDATA=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,7,"File Numbers"))
.. SET XTEDIT=$$DATCHK(BIDATA,EDDATA)
IF 'XTEDIT DO
. SET XTEDIT=(^TMP("XTVS-PARAM-BI",$J,PKGNME,8,"File Ranges")'=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,8,"File Ranges")))
. IF XTEDIT DO
.. NEW BIDATA,EDDATA
.. SET BIDATA=$G(^TMP("XTVS-PARAM-BI",$J,PKGNME,8,"File Ranges"))
.. SET EDDATA=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,8,"File Ranges"))
.. SET XTEDIT=$$DATCHK(BIDATA,EDDATA)
SET:'XTEDIT XTEDIT=(^TMP("XTVS-PARAM-BI",$J,PKGNME,9,"Parent Package")'=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,9,"Parent Package")))
QUIT XTEDIT
;
DATCHK(BIDATA,EDDATA) ;Compare data for Add, Change, Delete OR find if all same data in different '|' pces
NEW XTEDIT,BIPCE,EDPCE,BICHK,EQDATFND
SET XTEDIT=($L(BIDATA,"|")'=$L(EDDATA,"|")) ;NOT same # '|' pces, then EDITED no need to continue
IF 'XTEDIT DO
.FOR BIPCE=1:1 QUIT:XTEDIT QUIT:$P(BIDATA,"|",BIPCE)="" DO ;Check each '|' pce of Before Image
.. SET BICHK=$P(BIDATA,"|",BIPCE)
.. SET EQDATFND=0
.. FOR EDPCE=1:1 QUIT:$P(EDDATA,"|",EDPCE)="" QUIT:EQDATFND SET EQDATFND=(BICHK=$P(EDDATA,"|",EDPCE))
.. SET XTEDIT='EQDATFND ;If BICHK not found on EDDATA, then EDITED
QUIT XTEDIT
;
BEFORIMG(PKGNME) ; Create "^TMP(""XTVS-PARAM-BI"","_$J_","""_PKGNME_""")" to record initial package definitions before edits
IF '$D(^TMP("XTVS-PARAM-BI",$J,PKGNME)) DO
. SET ^TMP("XTVS-PARAM-BI",$J,PKGNME,2,"Primary Prefix")=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,2,"Primary Prefix"))
. SET ^TMP("XTVS-PARAM-BI",$J,PKGNME,3,"*Lowest File#")=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,3,"*Lowest File#"))
. SET ^TMP("XTVS-PARAM-BI",$J,PKGNME,4,"*Highest File#")=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,4,"*Highest File#"))
. SET ^TMP("XTVS-PARAM-BI",$J,PKGNME,5,"Additional Prefixes")=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,5,"Additional Prefixes"))
. SET ^TMP("XTVS-PARAM-BI",$J,PKGNME,6,"Excepted Prefixes")=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,6,"Excepted Prefixes"))
. SET ^TMP("XTVS-PARAM-BI",$J,PKGNME,7,"File Numbers")=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,7,"File Numbers"))
. SET ^TMP("XTVS-PARAM-BI",$J,PKGNME,8,"File Ranges")=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,8,"File Ranges"))
. SET ^TMP("XTVS-PARAM-BI",$J,PKGNME,9,"Parent Package")=$G(^TMP("XTVS-PARAM-CAP",$J,PKGNME,9,"Parent Package"))
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLPD1 5910 printed Dec 13, 2024@02:42:13 Page 2
XTVSLPD1 ;ALBANY FO/GTS - VistA Package Sizing Manager - Caption display APIs; 12-JUL-2016
+1 ;;7.3;TOOLKIT;**143,152**;Apr 25, 1995;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;APIs
BADRNG(X) ;Checks user entered File Range (used by DIR call)
+1 SET RESULT=0
+2 IF ((X'?1.N."."0.6N1"-"1.N."."0.6N)!($PIECE(X,"-",2)<$PIECE(X,"-")))
SET RESULT=1
+3 QUIT RESULT
+4 ;
SETSTR(CAPARY) ;Return a string of Package File Lineitem (Concatonate fields to 1 HDR line)
+1 NEW LINEITM,LPCNT,FLD
+2 SET LINEITM=""
+3 SET LPCNT=0
+4 FOR
SET LPCNT=$ORDER(@CAPARY@(LPCNT))
if LPCNT=""
QUIT
Begin DoDot:1
+5 SET FLD=$ORDER(@CAPARY@(LPCNT,""))
+6 SET LINEITM=LINEITM_@CAPARY@(LPCNT,FLD)_$SELECT(LPCNT<9:"^",1:"")
End DoDot:1
+7 QUIT LINEITM
+8 ;
EDPKGPRM(PKGNME) ; Edit Package Parameters
+1 NEW DATANUM,EDITARY,DATANAME,GETOUT,UPDATLST
+2 SET EDITARY="^TMP(""XTVS-PARAM-CAP"","_$JOB_","""_PKGNME_""")"
+3 SET DATANUM=0
+4 FOR
SET DATANUM=$ORDER(@EDITARY@(DATANUM))
if +DATANUM=0
QUIT
if ($DATA(DTOUT)!($DATA(DUOUT)))
QUIT
Begin DoDot:1
+5 SET DATANAME=$ORDER(@EDITARY@(DATANUM,""))
+6 NEW DIR,X,Y
+7 ;Set DIR("A") default prompt
SET DIR("A")=DATANAME_": "
+8 ;Set Prompt for DIR read
IF @EDITARY@(DATANUM,DATANAME)]""
SET DIR("B")=@EDITARY@(DATANUM,DATANAME)
+9 ;
+10 ;Primary Prefix (2)
+11 IF (DATANUM=2)
DO PRIMPFX^XTVSLPD2(DIR("A"),$GET(DIR("B")))
+12 ;
+13 ;*Lowest File# (3) & *Highest File# (4)
+14 IF ((DATANUM=3)!(DATANUM=4))
DO HILOFLE^XTVSLPD2(DIR("A"),$GET(DIR("B")))
+15 ;
+16 ;Additional Prefixes (5) & Excepted Prefixes (6)
+17 IF ((DATANUM=5)!(DATANUM=6))
DO EXADPFX^XTVSLPD2(DIR("A"),$GET(DIR("B")))
+18 ;
+19 ; File Numbers (7)
+20 IF (DATANUM=7)
DO FLENUM^XTVSLPD2(DIR("A"),$GET(DIR("B")))
+21 ;
+22 ; File Ranges (8)
+23 IF (DATANUM=8)
DO FLERNG^XTVSLPD2(DIR("A"),$GET(DIR("B")))
+24 ;
+25 ;Parent Package (9)
+26 IF (DATANUM=9)
DO PRNTPKG^XTVSLPD2(DIR("A"),$GET(DIR("B")))
+27 ;
+28 KILL DIR,X,Y
End DoDot:1
+29 ;
+30 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+31 QUIT
+32 ;
EDCHK(PKGNME) ; Check for edit
+1 ; Input PKGNME - Name of selected package
+2 ; Output XTEDIT - 0: Not Edited
+3 ; 1: Edited
+4 NEW XTEDIT
+5 SET XTEDIT=0
+6 if 'XTEDIT
SET XTEDIT=(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,2,"Primary Prefix")'=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,2,"Primary Prefix")))
+7 if 'XTEDIT
SET XTEDIT=(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,3,"*Lowest File#")'=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,3,"*Lowest File#")))
+8 if 'XTEDIT
SET XTEDIT=(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,4,"*Highest File#")'=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,4,"*Highest File#")))
+9 ;If no edit yet, first check for a difference in BI and CAP nodes
IF 'XTEDIT
Begin DoDot:1
+10 SET XTEDIT=(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,5,"Additional Prefixes")'=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,5,"Additional Prefixes")))
+11 ;If a difference between BI and CAP nodes, check for data reorg
IF XTEDIT
Begin DoDot:2
+12 NEW BIDATA,EDDATA
+13 SET BIDATA=$GET(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,5,"Additional Prefixes"))
+14 SET EDDATA=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,5,"Additional Prefixes"))
+15 SET XTEDIT=$$DATCHK(BIDATA,EDDATA)
End DoDot:2
End DoDot:1
+16 IF 'XTEDIT
Begin DoDot:1
+17 SET XTEDIT=(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,6,"Excepted Prefixes")'=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,6,"Excepted Prefixes")))
+18 IF XTEDIT
Begin DoDot:2
+19 NEW BIDATA,EDDATA
+20 SET BIDATA=$GET(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,6,"Excepted Prefixes"))
+21 SET EDDATA=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,6,"Excepted Prefixes"))
+22 SET XTEDIT=$$DATCHK(BIDATA,EDDATA)
End DoDot:2
End DoDot:1
+23 IF 'XTEDIT
Begin DoDot:1
+24 SET XTEDIT=(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,7,"File Numbers")'=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,7,"File Numbers")))
+25 IF XTEDIT
Begin DoDot:2
+26 NEW BIDATA,EDDATA
+27 SET BIDATA=$GET(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,7,"File Numbers"))
+28 SET EDDATA=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,7,"File Numbers"))
+29 SET XTEDIT=$$DATCHK(BIDATA,EDDATA)
End DoDot:2
End DoDot:1
+30 IF 'XTEDIT
Begin DoDot:1
+31 SET XTEDIT=(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,8,"File Ranges")'=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,8,"File Ranges")))
+32 IF XTEDIT
Begin DoDot:2
+33 NEW BIDATA,EDDATA
+34 SET BIDATA=$GET(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,8,"File Ranges"))
+35 SET EDDATA=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,8,"File Ranges"))
+36 SET XTEDIT=$$DATCHK(BIDATA,EDDATA)
End DoDot:2
End DoDot:1
+37 if 'XTEDIT
SET XTEDIT=(^TMP("XTVS-PARAM-BI",$JOB,PKGNME,9,"Parent Package")'=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,9,"Parent Package")))
+38 QUIT XTEDIT
+39 ;
DATCHK(BIDATA,EDDATA) ;Compare data for Add, Change, Delete OR find if all same data in different '|' pces
+1 NEW XTEDIT,BIPCE,EDPCE,BICHK,EQDATFND
+2 ;NOT same # '|' pces, then EDITED no need to continue
SET XTEDIT=($LENGTH(BIDATA,"|")'=$LENGTH(EDDATA,"|"))
+3 IF 'XTEDIT
Begin DoDot:1
+4 ;Check each '|' pce of Before Image
FOR BIPCE=1:1
if XTEDIT
QUIT
if $PIECE(BIDATA,"|",BIPCE)=""
QUIT
Begin DoDot:2
+5 SET BICHK=$PIECE(BIDATA,"|",BIPCE)
+6 SET EQDATFND=0
+7 FOR EDPCE=1:1
if $PIECE(EDDATA,"|",EDPCE)=""
QUIT
if EQDATFND
QUIT
SET EQDATFND=(BICHK=$PIECE(EDDATA,"|",EDPCE))
+8 ;If BICHK not found on EDDATA, then EDITED
SET XTEDIT='EQDATFND
End DoDot:2
End DoDot:1
+9 QUIT XTEDIT
+10 ;
BEFORIMG(PKGNME) ; Create "^TMP(""XTVS-PARAM-BI"","_$J_","""_PKGNME_""")" to record initial package definitions before edits
+1 IF '$DATA(^TMP("XTVS-PARAM-BI",$JOB,PKGNME))
Begin DoDot:1
+2 SET ^TMP("XTVS-PARAM-BI",$JOB,PKGNME,2,"Primary Prefix")=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,2,"Primary Prefix"))
+3 SET ^TMP("XTVS-PARAM-BI",$JOB,PKGNME,3,"*Lowest File#")=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,3,"*Lowest File#"))
+4 SET ^TMP("XTVS-PARAM-BI",$JOB,PKGNME,4,"*Highest File#")=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,4,"*Highest File#"))
+5 SET ^TMP("XTVS-PARAM-BI",$JOB,PKGNME,5,"Additional Prefixes")=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,5,"Additional Prefixes"))
+6 SET ^TMP("XTVS-PARAM-BI",$JOB,PKGNME,6,"Excepted Prefixes")=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,6,"Excepted Prefixes"))
+7 SET ^TMP("XTVS-PARAM-BI",$JOB,PKGNME,7,"File Numbers")=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,7,"File Numbers"))
+8 SET ^TMP("XTVS-PARAM-BI",$JOB,PKGNME,8,"File Ranges")=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,8,"File Ranges"))
+9 SET ^TMP("XTVS-PARAM-BI",$JOB,PKGNME,9,"Parent Package")=$GET(^TMP("XTVS-PARAM-CAP",$JOB,PKGNME,9,"Parent Package"))
End DoDot:1
+10 QUIT
