XTVSLNA1 ;BHAM/MAM/GTS - VistA Package Sizing Manager; 1-JUL-2016
;;7.3;TOOLKIT;**143**;Apr 25, 1995;Build 116
;
PKGEXT() ;Entry point - Package File extract (ACTION Protocol: XTVS PKG EXTRACT CREATE ACTION)
;
; STOPKILL: 0^0 $JOB sub-array for ^XTMP("XTSIZE") did not exist and was created
; 0^1 $JOB sub-array for ^XTMP("XTSIZE") existed and was recreated
; 1^1 $JOB sub-array for ^XTMP("XTSIZE") existed and was NOT recreated
;
NEW STOPKILL,XTVSUNME,VPNAME,VPIEN
SET XTVSUNME=$$NAME^XUSER(DUZ)
SET STOPKILL="0^0"
IF ($D(^XTMP("XTSIZE",$JOB))) DO QUIT:STOPKILL "1^1" ;;If STOPKILL, do NOT delete existing ^XTMP("XTSIZE",$J) global
. NEW X,Y,DIR
. SET DIR("A",1)=""
. SET DIR("A",2)="^XTMP(""XTSIZE"","_$JOB_") already exists!"
. SET DIR("A")="Do you want to delete ^XTMP(""XTSIZE"","_$JOB_") and recreate it"
. SET DIR("B")="NO"
. SET DIR(0)="Y::"
. SET STOPKILL="0^1"
. DO ^DIR
. IF ($D(DTOUT))!($D(DUOUT))!(($G(Y)=0)) DO
.. DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_$JOB_") NOT DELETED!")
.. SET STOPKILL="1^1"
;
K ^XTMP("XTSIZE",$J)
;NOTE: First pce of 0 node sets ^XTMP purge date 90 days from 'Today'
S ^XTMP("XTSIZE",$J,0)=$$FMADD^XLFDT($P($$NOW^XLFDT,"."),90)_"^"_$P($$NOW^XLFDT,".")_"^"_$$NOW^XLFDT_"-Kernel ToolKit Package File Extract by "_$S($G(XTVSUNME)]"":XTVSUNME,1:"{unknown user}")_"^"_^%ZOSF("PROD")
;
S VPIEN=0 F S VPIEN=$O(^DIC(9.4,VPIEN)) Q:'VPIEN S VPNAME=$P($G(^DIC(9.4,VPIEN,0)),"^") IF VPNAME]"" DO
. IF $P($G(^DIC(9.4,VPIEN,15002)),"^",3)'="X" DO
.. IF VPNAME["""" DO
... SET VPNAME=$REPLACE(VPNAME,"""","''")
... DO NOTCE^XTVSLAPI("Double Quotes changed to 2 single quotes in the "_VPNAME_" Package name.",$$NETNAME^XMXUTIL(DUZ),VPNAME)
.. DO SETXTMP^XTVSLNA1 ;Extract Packages
;
QUIT STOPKILL
;
SETXTMP ; set ^XTMP global with PACKAGE data
;
; Piece 1 = Namespace
; Piece 2 = Lower File Number Range
; Piece 3 = Highest File Number Range
; Piece 4 = Other Namepaces separated by "|"
; Piece 5 = Excepted Namepaces separated by "|"
; Piece 6 = Package File Ranges separated by "|"
; Piece 7 = Package Parent name
;
NEW VPPARPKG,PARNTNME,VPN,VPLOW,VPHIGH,VPOTHER,VPNAT,VPRNGE,VPEXCPT
NEW VP11,VPNUM,VPHNUM,VPIEN2,VPLNUM,VPFNUM
;Get Package CLASS and PARENT PACKAGE
S VPNAT=$G(^DIC(9.4,VPIEN,7)),VPNAT=$P(VPNAT,"^",3),VPPARPKG=$P($GET(^DIC(9.4,VPIEN,15002)),"^",2),PARNTNME=""
IF VPNAT'="I",VPNAT'="Ia",VPNAT='"Ib",VPNAT'="Ic" QUIT ;Only extract Class I, Ia, Ib and Ic packages
S VPN=$P($G(^DIC(9.4,VPIEN,0)),"^",2) IF VPN']"" QUIT ; PREFIX, Required, Do not extract if missing PREFIX
S (VPEXCPT,VPOTHER,VPRNGE)=""
S VP11=$G(^DIC(9.4,VPIEN,11)),VPLOW=$P(VP11,"^"),VPHIGH=$P(VP11,"^",2) ;*LOWEST/*HIGHEST FILE NUMBERS
;Get ADDITIONAL PREFIXES
IF $D(^DIC(9.4,VPIEN,14)) DO
. SET VPIEN2=0 F S VPIEN2=$O(^DIC(9.4,VPIEN,14,VPIEN2)) Q:'VPIEN2 S VPOTHER=VPOTHER_$G(^DIC(9.4,VPIEN,14,VPIEN2,0))_"|"
;Get EXCLUDED NAMESPACE
IF $D(^DIC(9.4,VPIEN,"EX")) DO
. SET VPIEN2=0 F S VPIEN2=$O(^DIC(9.4,VPIEN,"EX",VPIEN2)) Q:'VPIEN2 S VPEXCPT=VPEXCPT_$G(^DIC(9.4,VPIEN,"EX",VPIEN2,0))_"|"
;
;Get File Number Ranges from multiple field 15001.1
IF +$$FLDNUM^DILFD(9.4,"LOW-HIGH RANGE")=15001.1,$D(^DIC(9.4,VPIEN,15001)) DO
.S VPRNGE=""
.S VPIEN2=0
.F S VPIEN2=$O(^DIC(9.4,VPIEN,15001.1,VPIEN2)) Q:'VPIEN2 DO
..S VPLNUM=$P($G(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^")
..S VPHNUM=$P($G(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^",2)
..S VPRNGE=VPRNGE_VPLNUM_"-"_VPHNUM_"|"
;
;Get File Numbers from multiple field 15001
IF +$$FLDNUM^DILFD(9.4,"FILE NUMBER")=15001,$D(^DIC(9.4,VPIEN,15001)) DO
.S VPIEN2=0
.FOR S VPIEN2=$O(^DIC(9.4,VPIEN,15001,VPIEN2)) Q:'VPIEN2 DO
..S (VPFNUM,VPLNUM,VPHNUM)=""
..S VPFNUM=$G(^DIC(9.4,VPIEN,15001,VPIEN2,0))
..S:+VPFNUM>0 ^XTMP("XTSIZE",$J,VPNAME,VPFNUM)=""
;
;Get PARENT PACKAGE field (#15003) Parent name
IF VPPARPKG]"" DO
.SET PARNTNME=$P($G(^DIC(9.4,VPPARPKG,0)),"^")
;
S ^XTMP("XTSIZE",$J,VPNAME)=VPN_"^"_VPLOW_"^"_VPHIGH_"^"_VPOTHER_"^"_VPEXCPT_"^"_VPRNGE_"^"_PARNTNME
QUIT
;
XTMPORD(XDOLRJ,RPT,XTSZARY) ; Read ^XTMP("XTSIZE) array and create ^TMP globals for listing/reporting
; INPUT:
; XDOLRJ - $JOB for selected Package File Extract
; RPT - Information to include on correction report
; 0: No report
; 3: Report both no files and added ranges [Default]
; XTSZARY - Create ^TMP("XTSIZE") global for XTVSSVR
; 0: Do not create global [Default]
; 1: Create global
;
;Parameter List data map to Package file (#9.4):
; pce 1 : Package Name [Source: NAME (#.01)]
; pce 2 : Primary Prefix [Source: PREFIX (#1)]
; pce 3 : *Lowest File # [Source: *LOWEST FILE NUMBER (#10.6)]
; pce 4 : *Highest File # [Source: *HIGHEST FILE NUMBER (#11)]
; pce 5 : Pipe character (|) delimited list of Additional Prefixes [Source: ADDITIONAL PREFIXES multiple (#14)]
; pce 6 : Pipe character (|) delimited list of Excepted Prefixes [Source: EXCLUDED NAME SPACE multiple (#919)]
; pce 7 : Pipe character (|) delimited list of File entries [Source: FILE NUMBER multiple (#15001)]
; pce 8 : Pipe character (|) delimited list of File Range entries [Primary Source: LOW-HIGH RANGE multiple (#15001.1)]
; pce 9 : Parent Package [1st Source: PARENT PACKAGE field (#15003)]
;
KILL ^TMP("XTVS-FILERPT")
IF '$GET(XTSZARY) SET XTSZARY=0 ;default
;
NEW LPCNT,FAMTREE,SUBSCPT,DATARY,XTSZNUM
;
DO FAMINDEX(XDOLRJ) ;Reorder ^XTMP("XTSIZE") into ^TMP("XTSIZE","IDX") to indicate family tree for a package
NEW PKGVAL,CHILDPKG,LINEITEM,FILENUM,FIRSTNUM
SET PKGVAL=0
FOR SET PKGVAL=$O(^XTMP("XTSIZE",XDOLRJ,PKGVAL)) Q:PKGVAL="authentication" QUIT:PKGVAL="" DO
. SET LINEITEM=""
. ;Check for Package Name = Prefix
. SET LINEITEM=$S("ZU |AUP |AUT |DRG |GMD |GMN |VDE |XIP "[PKGVAL:$P(PKGVAL," "),1:PKGVAL)_"^"_$P(^XTMP("XTSIZE",XDOLRJ,PKGVAL),"^",1,5)_"^^"_$P(^XTMP("XTSIZE",XDOLRJ,PKGVAL),"^",6,7) ;Also: AUT,AUP,DRG,GMD,GMN,VDE,XIP,VPFS
. SET FILENUM=0
. FOR SET FILENUM=$O(^XTMP("XTSIZE",XDOLRJ,PKGVAL,FILENUM)) QUIT:FILENUM="" Q:FILENUM'?.N DO
.. SET $P(LINEITEM,"^",7)=$P(LINEITEM,"^",7)_FILENUM_"|" ;ADD File List multiple to Pce 7
. SET FAMTREE=$$LINEAGE(PKGVAL,$J)
. KILL SUBS
. FOR LPCNT=1:1 SET SUBSCPT=$P(FAMTREE,"^",LPCNT) QUIT:SUBSCPT="" S SUBS(LPCNT)=SUBSCPT
. SET DATARY=$P($NAME(^TMP("XTSIZE",$J)),")")
. SET LPCNT=0
. FOR SET LPCNT=$O(SUBS(LPCNT)) QUIT:(LPCNT="") DO
.. SET SUBSCPT=SUBS(LPCNT)
.. SET DATARY=DATARY_","_""_SUBSCPT
. SET DATARY=DATARY_")"
. ;
. ;NOTE: RPT - 0: no report, 3: both no files and added ranges [future use 1: No Ranges in multiple, 2: Files added to Range]
. IF $GET(RPT)="" SET RPT=3 ;;To report file changes
. SET $P(LINEITEM,"^",8)=$$FLRNGCLN(LINEITEM,PKGVAL,RPT) ;CLEANUP File Range multiple in Pce 8
. SET @DATARY=LINEITEM ;Set ^TMP("XTSIZE",$J) to LINEITEM
. ;
. IF XTSZARY DO ;;Create for XTSSVR
.. SET XTSZNUM=$GET(XTSZNUM)+1
.. SET ^TMP("XTVS-FORUMPKG",$J,XTSZNUM)=LINEITEM
. ;
. ; If no FILE or RANGE Multiple Entries, report High/Low File number fields
. IF RPT DO
.. NEW LOW,HIGH,RPTRNG,LINERNG
.. SET LINERNG=$P(LINEITEM,"^",8)
.. IF $P(LINERNG,"|")="" DO ;Only check High/Low fields when Range multiple undefined
... SET LOW=$P(LINEITEM,"^",3)
... SET HIGH=$P(LINEITEM,"^",4)
... SET RPTRNG=LOW_"-"_HIGH
... SET:RPTRNG="-" RPTRNG="No File Ranges or High/Low Fields"
... IF RPTRNG["-" DO
.... SET:$P(RPTRNG,"-")="" $P(RPTRNG,"-",1)="<begin undefined>"
.... SET:$P(RPTRNG,"-",2)="" $P(RPTRNG,"-",2)="<end undefined>"
... DO RPTFLADD(PKGVAL,"HL",RPTRNG)
;
KILL SUBS,^TMP("XTSIZE","IDX",$JOB)
;
QUIT
;
FAMINDEX(XDOLRJ) ; Create a package family tree ^TMP global=pkg^parentpkg^grndparentpkg^etc.
NEW PARNTPKG
NEW FAMTREE,PKGVAL
SET PKGVAL=0
FOR SET PKGVAL=$O(^XTMP("XTSIZE",XDOLRJ,PKGVAL)) Q:PKGVAL="authentication" Q:PKGVAL="" DO
. SET FAMTREE=""
. IF '$D(^TMP("XTSIZE","IDX",$J,PKGVAL)) DO
.. SET FAMTREE=$$ANCESTRY(PKGVAL,XDOLRJ)
.. SET ^TMP("XTSIZE","IDX",$J,PKGVAL)=FAMTREE
QUIT
;
ANCESTRY(PKGVAL,XDOLRJ) ; Return list of package-parent-grandparent-etc. relationships
NEW FAMTREE,PARENT,LASTPRNT
SET PARENT=PKGVAL
SET FAMTREE=$S("ZU |AUP |AUT |DRG |GMD |GMN |VDE |XIP "[PKGVAL:$P(PKGVAL," "),1:PKGVAL) ;Cleanup Namespace returned from Forum Package file (Also: VPFS)
FOR QUIT:PARENT="" SET LASTPRNT=PARENT SET PARENT=$P($G(^XTMP("XTSIZE",XDOLRJ,PARENT)),"^",7) QUIT:PARENT=LASTPRNT QUIT:((FAMTREE["^")&(FAMTREE[PARENT)) DO
. IF PARENT'="" DO
.. SET FAMTREE=FAMTREE_"^"_PARENT
QUIT FAMTREE
;
LINEAGE(PKG,DOLRJ) ; Return a family tree subscript string
NEW CHKLVL,SUBLVL,SUBSCPT,FAMTREE,SUB
SET SUBSCPT=""
IF $D(^TMP("XTSIZE","IDX",DOLRJ,PKG)) DO
. SET SUBSCPT=^TMP("XTSIZE","IDX",DOLRJ,PKG)
. FOR SUBLVL=1:1 SET SUB(SUBLVL)=$P(SUBSCPT,"^",SUBLVL) IF SUB(SUBLVL)="" KILL SUB(SUBLVL) QUIT
. SET (SUBSCPT,SUBLVL)=""
. FOR SET SUBLVL=$O(SUB(SUBLVL),-1) Q:SUBLVL="" SET SUBSCPT=SUBSCPT_SUB(SUBLVL)_""""_"^"_""""
. SET SUBSCPT=""""_$P(SUBSCPT,"^",1,$O(SUB(SUBLVL),-1))
QUIT SUBSCPT
;
FLRNGCLN(LINEITEM,PKGVAL,RPT) ;Cleanup File Ranges received from Forum Package file
; INPUT : LINEITEM - Value of ^XTMP("XTSIZE") node
; PKGVAL - Package reporting from ^XTMP("XTSIZE") node
; RPT - >0 : Report Range additions
; 0 : Do not report Range additions
;
; File range of LineItem (pce 8) will be "cleaned up" as follows:
; Any "end of range" file number that does not have a decimal end will be changed to 9999/10000 (E.G. 7 becomes 7.9999)
; Any File number in the FILE number on LineItem (Pce 7) that is not in a range will be added as a range (7 becomes 7-7.9999)
;
NEW RANGE,BEGFLNM,ENDFLNM,ENDFNDC,FILERNG,RNGPCE,FILENUM,FILEPCE,FILENUM,PCENUM
NEW ADDRNGE,FNUMLNG,LPCNT,START,END,FNNEWRNG,FILELIST
;
;Check for existence of File List
IF $G(RPT)="" SET RPT=0
SET FILELIST=$P(LINEITEM,"^",7)
IF RPT,($P(FILELIST,"|",1)']"") DO RPTFLADD(PKGVAL,"NOLISTF","")
;
;Check End number of Ranges for an ending decimal place
SET RANGE=$P(LINEITEM,"^",8)
FOR RNGPCE=1:1 SET FLERNGE=$P(RANGE,"|",RNGPCE) Q:FLERNGE="" DO
. SET ENDFLNM=$P(FLERNGE,"-",2)
. SET ENDFNDC=$P(ENDFLNM,".",2)
. IF ENDFNDC="" DO
.. SET BEGFLNM=$P($P(RANGE,"|",RNGPCE),"-")
.. SET $P(ENDFLNM,".",2)="9999"
.. SET $P(FLERNG,"-",2)=ENDFLNM
.. SET $P(RANGE,"|",RNGPCE)=BEGFLNM_FLERNG
.. IF RPT DO RPTFLADD(PKGVAL,"RNGUPDT",BEGFLNM_FLERNG)
;
;Check file numbers in FILE list to see if included in RANGE list'
SET FILEPCE=$P(LINEITEM,"^",7)
FOR PCENUM=1:1 SET FILENUM=$P(FILEPCE,"|",PCENUM) Q:FILENUM="" DO
. SET FNNEWRNG=1
. FOR RNGPCE=1:1 SET FLERNGE=$P(RANGE,"|",RNGPCE) Q:FLERNGE="" DO
.. SET BEGFLNM=$P(FLERNGE,"-",1)
.. SET BEGFLNM=$$SETRNG(BEGFLNM,"LOWER")
.. SET ENDFLNM=$P(FLERNGE,"-",2)
.. SET ENDFLNM=$$SETRNG(ENDFLNM,"UPPER")
.. IF (+FILENUM>BEGFLNM),(+FILENUM<ENDFLNM) SET FNNEWRNG=0
. IF FNNEWRNG DO
.. SET FNUMLNG=$L($P(FILENUM,".",2))
.. SET (START,END)=FILENUM
.. IF FNUMLNG=0 SET END=END_"."
.. IF FNUMLNG<4 FOR LPCNT=1:1:4-FNUMLNG SET END=END_"9"
.. IF FNUMLNG>3 SET END=END_"9"
.. IF RPT DO RPTFLADD(PKGVAL,"FILE",START_"-"_END)
.. SET:RANGE'="" RANGE=RANGE_START_"-"_END_"|"
.. SET:RANGE="" RANGE=START_"-"_END_"|"
Q RANGE
;
SETRNG(FILENUM,PLACE) ; Either add to or subtract a fraction from the range number
; PLACE - UPPER: Add a fraction to number
; - LOWER: Subract a fraction from number
NEW RESULT,DECVAL,PLCS,DELTA,LPCNT
SET DECVAL=$P(FILENUM,".",2)
SET PLCS=$L(DECVAL)
SET DELTA="0."
FOR LPCNT=1:1:PLCS SET DELTA=DELTA_"0"
SET DELTA=DELTA_"1"
IF PLACE="LOWER" SET RESULT=FILENUM-DELTA
IF PLACE="UPPER" SET RESULT=FILENUM+DELTA
Q RESULT
;
RPTFLADD(PKGVAL,TYPE,RANGE) ; Write a node in ^TMP("XTVS-FILERPT") for each file added to ranges
; INPUT : PKGVAL - Package reporting from ^XTMP("XTSIZE") node
; TYPE - FILE : File Multiple
; - HL : High/Low range fields
; - RNGUPDT : Range Multiple
; - NOLISTF : File List Multiple not defined
;
; RANGE - File Range
;
; OUTPUT: Report Node added to ^TMP("XTVS-FILERPT") array
;
NEW RPTARYND,NODEVAL
SET RPTARYND=$O(^TMP("XTVS-FILERPT",$J,PKGVAL,""),-1)
IF RPTARYND="" SET ^TMP("XTVS-FILERPT",$J,PKGVAL,1)=PKGVAL_" Package entry file number notes:" SET RPTARYND=1
SET RPTARYND=RPTARYND+1
SET NODEVAL=""
IF TYPE="FILE" SET NODEVAL=" "_RANGE_" [File Multiple added to Range Multiple]"
IF (TYPE="HL") DO
. IF (RANGE'["No File Ranges or High/Low Fields") SET NODEVAL=" "_RANGE_" [Range Multiple undefined, High/Low Field range only]"
. IF (RANGE["No File Ranges or High/Low Fields") SET NODEVAL=" Ranges Undefined ["_RANGE_"]"
IF TYPE="RNGUPDT" SET NODEVAL=" "_RANGE_" [Decimal on Range End extended by nine(s)]"
IF TYPE="NOLISTF" SET NODEVAL=" No File List [No File Multiple Entries defined]"
;
SET:NODEVAL]"" ^TMP("XTVS-FILERPT",$J,PKGVAL,RPTARYND)=NODEVAL
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTVSLNA1 13236 printed Oct 16, 2024@18:42:47 Page 2
XTVSLNA1 ;BHAM/MAM/GTS - VistA Package Sizing Manager; 1-JUL-2016
+1 ;;7.3;TOOLKIT;**143**;Apr 25, 1995;Build 116
+2 ;
PKGEXT() ;Entry point - Package File extract (ACTION Protocol: XTVS PKG EXTRACT CREATE ACTION)
+1 ;
+2 ; STOPKILL: 0^0 $JOB sub-array for ^XTMP("XTSIZE") did not exist and was created
+3 ; 0^1 $JOB sub-array for ^XTMP("XTSIZE") existed and was recreated
+4 ; 1^1 $JOB sub-array for ^XTMP("XTSIZE") existed and was NOT recreated
+5 ;
+6 NEW STOPKILL,XTVSUNME,VPNAME,VPIEN
+7 SET XTVSUNME=$$NAME^XUSER(DUZ)
+8 SET STOPKILL="0^0"
+9 ;;If STOPKILL, do NOT delete existing ^XTMP("XTSIZE",$J) global
IF ($DATA(^XTMP("XTSIZE",$JOB)))
Begin DoDot:1
+10 NEW X,Y,DIR
+11 SET DIR("A",1)=""
+12 SET DIR("A",2)="^XTMP(""XTSIZE"","_$JOB_") already exists!"
+13 SET DIR("A")="Do you want to delete ^XTMP(""XTSIZE"","_$JOB_") and recreate it"
+14 SET DIR("B")="NO"
+15 SET DIR(0)="Y::"
+16 SET STOPKILL="0^1"
+17 DO ^DIR
+18 IF ($DATA(DTOUT))!($DATA(DUOUT))!(($GET(Y)=0))
Begin DoDot:2
+19 DO JUSTPAWS^XTVSLAPI("^XTMP(""XTSIZE"","_$JOB_") NOT DELETED!")
+20 SET STOPKILL="1^1"
End DoDot:2
End DoDot:1
if STOPKILL
QUIT "1^1"
+21 ;
+22 KILL ^XTMP("XTSIZE",$JOB)
+23 ;NOTE: First pce of 0 node sets ^XTMP purge date 90 days from 'Today'
+24 SET ^XTMP("XTSIZE",$JOB,0)=$$FMADD^XLFDT($PIECE($$NOW^XLFDT,"."),90)_"^"_$PIECE($$NOW^XLFDT,".")_"^"_$$NOW^XLFDT_"-Kernel ToolKit Package File Extract by "_$S($GET(XTVSUNME)]"":XTVSUNME,1:"{unknown user}")_"^"_^%ZOSF("PROD")
+25 ;
+26 SET VPIEN=0
FOR
SET VPIEN=$ORDER(^DIC(9.4,VPIEN))
if 'VPIEN
QUIT
SET VPNAME=$PIECE($GET(^DIC(9.4,VPIEN,0)),"^")
IF VPNAME]""
Begin DoDot:1
+27 IF $PIECE($GET(^DIC(9.4,VPIEN,15002)),"^",3)'="X"
Begin DoDot:2
+28 IF VPNAME[""""
Begin DoDot:3
+29
*** ERROR ***
SET VPNAME=$REPLACE(VPNAME,"""","''")
+30 DO NOTCE^XTVSLAPI("Double Quotes changed to 2 single quotes in the "_VPNAME_" Package name.",$$NETNAME^XMXUTIL(DUZ),VPNAME)
End DoDot:3
+31 ;Extract Packages
DO SETXTMP^XTVSLNA1
End DoDot:2
End DoDot:1
+32 ;
+33 QUIT STOPKILL
+34 ;
SETXTMP ; set ^XTMP global with PACKAGE data
+1 ;
+2 ; Piece 1 = Namespace
+3 ; Piece 2 = Lower File Number Range
+4 ; Piece 3 = Highest File Number Range
+5 ; Piece 4 = Other Namepaces separated by "|"
+6 ; Piece 5 = Excepted Namepaces separated by "|"
+7 ; Piece 6 = Package File Ranges separated by "|"
+8 ; Piece 7 = Package Parent name
+9 ;
+10 NEW VPPARPKG,PARNTNME,VPN,VPLOW,VPHIGH,VPOTHER,VPNAT,VPRNGE,VPEXCPT
+11 NEW VP11,VPNUM,VPHNUM,VPIEN2,VPLNUM,VPFNUM
+12 ;Get Package CLASS and PARENT PACKAGE
+13 SET VPNAT=$GET(^DIC(9.4,VPIEN,7))
SET VPNAT=$PIECE(VPNAT,"^",3)
SET VPPARPKG=$PIECE($GET(^DIC(9.4,VPIEN,15002)),"^",2)
SET PARNTNME=""
+14 ;Only extract Class I, Ia, Ib and Ic packages
IF VPNAT'="I"
IF VPNAT'="Ia"
IF VPNAT='"Ib"
IF VPNAT'="Ic"
QUIT
+15 ; PREFIX, Required, Do not extract if missing PREFIX
SET VPN=$PIECE($GET(^DIC(9.4,VPIEN,0)),"^",2)
IF VPN']""
QUIT
+16 SET (VPEXCPT,VPOTHER,VPRNGE)=""
+17 ;*LOWEST/*HIGHEST FILE NUMBERS
SET VP11=$GET(^DIC(9.4,VPIEN,11))
SET VPLOW=$PIECE(VP11,"^")
SET VPHIGH=$PIECE(VP11,"^",2)
+18 ;Get ADDITIONAL PREFIXES
+19 IF $DATA(^DIC(9.4,VPIEN,14))
Begin DoDot:1
+20 SET VPIEN2=0
FOR
SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,14,VPIEN2))
if 'VPIEN2
QUIT
SET VPOTHER=VPOTHER_$GET(^DIC(9.4,VPIEN,14,VPIEN2,0))_"|"
End DoDot:1
+21 ;Get EXCLUDED NAMESPACE
+22 IF $DATA(^DIC(9.4,VPIEN,"EX"))
Begin DoDot:1
+23 SET VPIEN2=0
FOR
SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,"EX",VPIEN2))
if 'VPIEN2
QUIT
SET VPEXCPT=VPEXCPT_$GET(^DIC(9.4,VPIEN,"EX",VPIEN2,0))_"|"
End DoDot:1
+24 ;
+25 ;Get File Number Ranges from multiple field 15001.1
+26 IF +$$FLDNUM^DILFD(9.4,"LOW-HIGH RANGE")=15001.1
IF $DATA(^DIC(9.4,VPIEN,15001))
Begin DoDot:1
+27 SET VPRNGE=""
+28 SET VPIEN2=0
+29 FOR
SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,15001.1,VPIEN2))
if 'VPIEN2
QUIT
Begin DoDot:2
+30 SET VPLNUM=$PIECE($GET(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^")
+31 SET VPHNUM=$PIECE($GET(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^",2)
+32 SET VPRNGE=VPRNGE_VPLNUM_"-"_VPHNUM_"|"
End DoDot:2
End DoDot:1
+33 ;
+34 ;Get File Numbers from multiple field 15001
+35 IF +$$FLDNUM^DILFD(9.4,"FILE NUMBER")=15001
IF $DATA(^DIC(9.4,VPIEN,15001))
Begin DoDot:1
+36 SET VPIEN2=0
+37 FOR
SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,15001,VPIEN2))
if 'VPIEN2
QUIT
Begin DoDot:2
+38 SET (VPFNUM,VPLNUM,VPHNUM)=""
+39 SET VPFNUM=$GET(^DIC(9.4,VPIEN,15001,VPIEN2,0))
+40 if +VPFNUM>0
SET ^XTMP("XTSIZE",$JOB,VPNAME,VPFNUM)=""
End DoDot:2
End DoDot:1
+41 ;
+42 ;Get PARENT PACKAGE field (#15003) Parent name
+43 IF VPPARPKG]""
Begin DoDot:1
+44 SET PARNTNME=$PIECE($GET(^DIC(9.4,VPPARPKG,0)),"^")
End DoDot:1
+45 ;
+46 SET ^XTMP("XTSIZE",$JOB,VPNAME)=VPN_"^"_VPLOW_"^"_VPHIGH_"^"_VPOTHER_"^"_VPEXCPT_"^"_VPRNGE_"^"_PARNTNME
+47 QUIT
+48 ;
XTMPORD(XDOLRJ,RPT,XTSZARY) ; Read ^XTMP("XTSIZE) array and create ^TMP globals for listing/reporting
+1 ; INPUT:
+2 ; XDOLRJ - $JOB for selected Package File Extract
+3 ; RPT - Information to include on correction report
+4 ; 0: No report
+5 ; 3: Report both no files and added ranges [Default]
+6 ; XTSZARY - Create ^TMP("XTSIZE") global for XTVSSVR
+7 ; 0: Do not create global [Default]
+8 ; 1: Create global
+9 ;
+10 ;Parameter List data map to Package file (#9.4):
+11 ; pce 1 : Package Name [Source: NAME (#.01)]
+12 ; pce 2 : Primary Prefix [Source: PREFIX (#1)]
+13 ; pce 3 : *Lowest File # [Source: *LOWEST FILE NUMBER (#10.6)]
+14 ; pce 4 : *Highest File # [Source: *HIGHEST FILE NUMBER (#11)]
+15 ; pce 5 : Pipe character (|) delimited list of Additional Prefixes [Source: ADDITIONAL PREFIXES multiple (#14)]
+16 ; pce 6 : Pipe character (|) delimited list of Excepted Prefixes [Source: EXCLUDED NAME SPACE multiple (#919)]
+17 ; pce 7 : Pipe character (|) delimited list of File entries [Source: FILE NUMBER multiple (#15001)]
+18 ; pce 8 : Pipe character (|) delimited list of File Range entries [Primary Source: LOW-HIGH RANGE multiple (#15001.1)]
+19 ; pce 9 : Parent Package [1st Source: PARENT PACKAGE field (#15003)]
+20 ;
+21 KILL ^TMP("XTVS-FILERPT")
+22 ;default
IF '$GET(XTSZARY)
SET XTSZARY=0
+23 ;
+24 NEW LPCNT,FAMTREE,SUBSCPT,DATARY,XTSZNUM
+25 ;
+26 ;Reorder ^XTMP("XTSIZE") into ^TMP("XTSIZE","IDX") to indicate family tree for a package
DO FAMINDEX(XDOLRJ)
+27 NEW PKGVAL,CHILDPKG,LINEITEM,FILENUM,FIRSTNUM
+28 SET PKGVAL=0
+29 FOR
SET PKGVAL=$ORDER(^XTMP("XTSIZE",XDOLRJ,PKGVAL))
if PKGVAL="authentication"
QUIT
if PKGVAL=""
QUIT
Begin DoDot:1
+30 SET LINEITEM=""
+31 ;Check for Package Name = Prefix
+32 ;Also: AUT,AUP,DRG,GMD,GMN,VDE,XIP,VPFS
SET LINEITEM=$SELECT("ZU |AUP |AUT |DRG |GMD |GMN |VDE |XIP "[PKGVAL:$PIECE(PKGVAL," "),1:PKGVAL)_"^"_$PIECE(^XTMP("XTSIZE",XDOLRJ,PKGVAL),"^",1,5)_"^^"_$PIECE(^XTMP("XTSIZE",XDOLRJ,PKGVAL),"^",6,7)
+33 SET FILENUM=0
+34 FOR
SET FILENUM=$ORDER(^XTMP("XTSIZE",XDOLRJ,PKGVAL,FILENUM))
if FILENUM=""
QUIT
if FILENUM'?.N
QUIT
Begin DoDot:2
+35 ;ADD File List multiple to Pce 7
SET $PIECE(LINEITEM,"^",7)=$PIECE(LINEITEM,"^",7)_FILENUM_"|"
End DoDot:2
+36 SET FAMTREE=$$LINEAGE(PKGVAL,$JOB)
+37 KILL SUBS
+38 FOR LPCNT=1:1
SET SUBSCPT=$PIECE(FAMTREE,"^",LPCNT)
if SUBSCPT=""
QUIT
SET SUBS(LPCNT)=SUBSCPT
+39 SET DATARY=$PIECE($NAME(^TMP("XTSIZE",$JOB)),")")
+40 SET LPCNT=0
+41 FOR
SET LPCNT=$ORDER(SUBS(LPCNT))
if (LPCNT="")
QUIT
Begin DoDot:2
+42 SET SUBSCPT=SUBS(LPCNT)
+43 SET DATARY=DATARY_","_""_SUBSCPT
End DoDot:2
+44 SET DATARY=DATARY_")"
+45 ;
+46 ;NOTE: RPT - 0: no report, 3: both no files and added ranges [future use 1: No Ranges in multiple, 2: Files added to Range]
+47 ;;To report file changes
IF $GET(RPT)=""
SET RPT=3
+48 ;CLEANUP File Range multiple in Pce 8
SET $PIECE(LINEITEM,"^",8)=$$FLRNGCLN(LINEITEM,PKGVAL,RPT)
+49 ;Set ^TMP("XTSIZE",$J) to LINEITEM
SET @DATARY=LINEITEM
+50 ;
+51 ;;Create for XTSSVR
IF XTSZARY
Begin DoDot:2
+52 SET XTSZNUM=$GET(XTSZNUM)+1
+53 SET ^TMP("XTVS-FORUMPKG",$JOB,XTSZNUM)=LINEITEM
End DoDot:2
+54 ;
+55 ; If no FILE or RANGE Multiple Entries, report High/Low File number fields
+56 IF RPT
Begin DoDot:2
+57 NEW LOW,HIGH,RPTRNG,LINERNG
+58 SET LINERNG=$PIECE(LINEITEM,"^",8)
+59 ;Only check High/Low fields when Range multiple undefined
IF $PIECE(LINERNG,"|")=""
Begin DoDot:3
+60 SET LOW=$PIECE(LINEITEM,"^",3)
+61 SET HIGH=$PIECE(LINEITEM,"^",4)
+62 SET RPTRNG=LOW_"-"_HIGH
+63 if RPTRNG="-"
SET RPTRNG="No File Ranges or High/Low Fields"
+64 IF RPTRNG["-"
Begin DoDot:4
+65 if $PIECE(RPTRNG,"-")=""
SET $PIECE(RPTRNG,"-",1)="<begin undefined>"
+66 if $PIECE(RPTRNG,"-",2)=""
SET $PIECE(RPTRNG,"-",2)="<end undefined>"
End DoDot:4
+67 DO RPTFLADD(PKGVAL,"HL",RPTRNG)
End DoDot:3
End DoDot:2
End DoDot:1
+68 ;
+69 KILL SUBS,^TMP("XTSIZE","IDX",$JOB)
+70 ;
+71 QUIT
+72 ;
FAMINDEX(XDOLRJ) ; Create a package family tree ^TMP global=pkg^parentpkg^grndparentpkg^etc.
+1 NEW PARNTPKG
+2 NEW FAMTREE,PKGVAL
+3 SET PKGVAL=0
+4 FOR
SET PKGVAL=$ORDER(^XTMP("XTSIZE",XDOLRJ,PKGVAL))
if PKGVAL="authentication"
QUIT
if PKGVAL=""
QUIT
Begin DoDot:1
+5 SET FAMTREE=""
+6 IF '$DATA(^TMP("XTSIZE","IDX",$JOB,PKGVAL))
Begin DoDot:2
+7 SET FAMTREE=$$ANCESTRY(PKGVAL,XDOLRJ)
+8 SET ^TMP("XTSIZE","IDX",$JOB,PKGVAL)=FAMTREE
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
ANCESTRY(PKGVAL,XDOLRJ) ; Return list of package-parent-grandparent-etc. relationships
+1 NEW FAMTREE,PARENT,LASTPRNT
+2 SET PARENT=PKGVAL
+3 ;Cleanup Namespace returned from Forum Package file (Also: VPFS)
SET FAMTREE=$SELECT("ZU |AUP |AUT |DRG |GMD |GMN |VDE |XIP "[PKGVAL:$PIECE(PKGVAL," "),1:PKGVAL)
+4 FOR
if PARENT=""
QUIT
SET LASTPRNT=PARENT
SET PARENT=$PIECE($GET(^XTMP("XTSIZE",XDOLRJ,PARENT)),"^",7)
if PARENT=LASTPRNT
QUIT
if ((FAMTREE["^")&(FAMTREE[PARENT))
QUIT
Begin DoDot:1
+5 IF PARENT'=""
Begin DoDot:2
+6 SET FAMTREE=FAMTREE_"^"_PARENT
End DoDot:2
End DoDot:1
+7 QUIT FAMTREE
+8 ;
LINEAGE(PKG,DOLRJ) ; Return a family tree subscript string
+1 NEW CHKLVL,SUBLVL,SUBSCPT,FAMTREE,SUB
+2 SET SUBSCPT=""
+3 IF $DATA(^TMP("XTSIZE","IDX",DOLRJ,PKG))
Begin DoDot:1
+4 SET SUBSCPT=^TMP("XTSIZE","IDX",DOLRJ,PKG)
+5 FOR SUBLVL=1:1
SET SUB(SUBLVL)=$PIECE(SUBSCPT,"^",SUBLVL)
IF SUB(SUBLVL)=""
KILL SUB(SUBLVL)
QUIT
+6 SET (SUBSCPT,SUBLVL)=""
+7 FOR
SET SUBLVL=$ORDER(SUB(SUBLVL),-1)
if SUBLVL=""
QUIT
SET SUBSCPT=SUBSCPT_SUB(SUBLVL)_""""_"^"_""""
+8 SET SUBSCPT=""""_$PIECE(SUBSCPT,"^",1,$ORDER(SUB(SUBLVL),-1))
End DoDot:1
+9 QUIT SUBSCPT
+10 ;
FLRNGCLN(LINEITEM,PKGVAL,RPT) ;Cleanup File Ranges received from Forum Package file
+1 ; INPUT : LINEITEM - Value of ^XTMP("XTSIZE") node
+2 ; PKGVAL - Package reporting from ^XTMP("XTSIZE") node
+3 ; RPT - >0 : Report Range additions
+4 ; 0 : Do not report Range additions
+5 ;
+6 ; File range of LineItem (pce 8) will be "cleaned up" as follows:
+7 ; Any "end of range" file number that does not have a decimal end will be changed to 9999/10000 (E.G. 7 becomes 7.9999)
+8 ; Any File number in the FILE number on LineItem (Pce 7) that is not in a range will be added as a range (7 becomes 7-7.9999)
+9 ;
+10 NEW RANGE,BEGFLNM,ENDFLNM,ENDFNDC,FILERNG,RNGPCE,FILENUM,FILEPCE,FILENUM,PCENUM
+11 NEW ADDRNGE,FNUMLNG,LPCNT,START,END,FNNEWRNG,FILELIST
+12 ;
+13 ;Check for existence of File List
+14 IF $GET(RPT)=""
SET RPT=0
+15 SET FILELIST=$PIECE(LINEITEM,"^",7)
+16 IF RPT
IF ($PIECE(FILELIST,"|",1)']"")
DO RPTFLADD(PKGVAL,"NOLISTF","")
+17 ;
+18 ;Check End number of Ranges for an ending decimal place
+19 SET RANGE=$PIECE(LINEITEM,"^",8)
+20 FOR RNGPCE=1:1
SET FLERNGE=$PIECE(RANGE,"|",RNGPCE)
if FLERNGE=""
QUIT
Begin DoDot:1
+21 SET ENDFLNM=$PIECE(FLERNGE,"-",2)
+22 SET ENDFNDC=$PIECE(ENDFLNM,".",2)
+23 IF ENDFNDC=""
Begin DoDot:2
+24 SET BEGFLNM=$PIECE($PIECE(RANGE,"|",RNGPCE),"-")
+25 SET $PIECE(ENDFLNM,".",2)="9999"
+26 SET $PIECE(FLERNG,"-",2)=ENDFLNM
+27 SET $PIECE(RANGE,"|",RNGPCE)=BEGFLNM_FLERNG
+28 IF RPT
DO RPTFLADD(PKGVAL,"RNGUPDT",BEGFLNM_FLERNG)
End DoDot:2
End DoDot:1
+29 ;
+30 ;Check file numbers in FILE list to see if included in RANGE list'
+31 SET FILEPCE=$PIECE(LINEITEM,"^",7)
+32 FOR PCENUM=1:1
SET FILENUM=$PIECE(FILEPCE,"|",PCENUM)
if FILENUM=""
QUIT
Begin DoDot:1
+33 SET FNNEWRNG=1
+34 FOR RNGPCE=1:1
SET FLERNGE=$PIECE(RANGE,"|",RNGPCE)
if FLERNGE=""
QUIT
Begin DoDot:2
+35 SET BEGFLNM=$PIECE(FLERNGE,"-",1)
+36 SET BEGFLNM=$$SETRNG(BEGFLNM,"LOWER")
+37 SET ENDFLNM=$PIECE(FLERNGE,"-",2)
+38 SET ENDFLNM=$$SETRNG(ENDFLNM,"UPPER")
+39 IF (+FILENUM>BEGFLNM)
IF (+FILENUM<ENDFLNM)
SET FNNEWRNG=0
End DoDot:2
+40 IF FNNEWRNG
Begin DoDot:2
+41 SET FNUMLNG=$LENGTH($PIECE(FILENUM,".",2))
+42 SET (START,END)=FILENUM
+43 IF FNUMLNG=0
SET END=END_"."
+44 IF FNUMLNG<4
FOR LPCNT=1:1:4-FNUMLNG
SET END=END_"9"
+45 IF FNUMLNG>3
SET END=END_"9"
+46 IF RPT
DO RPTFLADD(PKGVAL,"FILE",START_"-"_END)
+47 if RANGE'=""
SET RANGE=RANGE_START_"-"_END_"|"
+48 if RANGE=""
SET RANGE=START_"-"_END_"|"
End DoDot:2
End DoDot:1
+49 QUIT RANGE
+50 ;
SETRNG(FILENUM,PLACE) ; Either add to or subtract a fraction from the range number
+1 ; PLACE - UPPER: Add a fraction to number
+2 ; - LOWER: Subract a fraction from number
+3 NEW RESULT,DECVAL,PLCS,DELTA,LPCNT
+4 SET DECVAL=$PIECE(FILENUM,".",2)
+5 SET PLCS=$LENGTH(DECVAL)
+6 SET DELTA="0."
+7 FOR LPCNT=1:1:PLCS
SET DELTA=DELTA_"0"
+8 SET DELTA=DELTA_"1"
+9 IF PLACE="LOWER"
SET RESULT=FILENUM-DELTA
+10 IF PLACE="UPPER"
SET RESULT=FILENUM+DELTA
+11 QUIT RESULT
+12 ;
RPTFLADD(PKGVAL,TYPE,RANGE) ; Write a node in ^TMP("XTVS-FILERPT") for each file added to ranges
+1 ; INPUT : PKGVAL - Package reporting from ^XTMP("XTSIZE") node
+2 ; TYPE - FILE : File Multiple
+3 ; - HL : High/Low range fields
+4 ; - RNGUPDT : Range Multiple
+5 ; - NOLISTF : File List Multiple not defined
+6 ;
+7 ; RANGE - File Range
+8 ;
+9 ; OUTPUT: Report Node added to ^TMP("XTVS-FILERPT") array
+10 ;
+11 NEW RPTARYND,NODEVAL
+12 SET RPTARYND=$ORDER(^TMP("XTVS-FILERPT",$JOB,PKGVAL,""),-1)
+13 IF RPTARYND=""
SET ^TMP("XTVS-FILERPT",$JOB,PKGVAL,1)=PKGVAL_" Package entry file number notes:"
SET RPTARYND=1
+14 SET RPTARYND=RPTARYND+1
+15 SET NODEVAL=""
+16 IF TYPE="FILE"
SET NODEVAL=" "_RANGE_" [File Multiple added to Range Multiple]"
+17 IF (TYPE="HL")
Begin DoDot:1
+18 IF (RANGE'["No File Ranges or High/Low Fields")
SET NODEVAL=" "_RANGE_" [Range Multiple undefined, High/Low Field range only]"
+19 IF (RANGE["No File Ranges or High/Low Fields")
SET NODEVAL=" Ranges Undefined ["_RANGE_"]"
End DoDot:1
+20 IF TYPE="RNGUPDT"
SET NODEVAL=" "_RANGE_" [Decimal on Range End extended by nine(s)]"
+21 IF TYPE="NOLISTF"
SET NODEVAL=" No File List [No File Multiple Entries defined]"
+22 ;
+23 if NODEVAL]""
SET ^TMP("XTVS-FILERPT",$JOB,PKGVAL,RPTARYND)=NODEVAL
+24 QUIT
