- 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 Feb 19, 2025@00:08:41 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
