A1VSLNA1 ;BHAM/MAM/GTS - VistA Package Sizing Manager; 1-JUL-2016
;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
;
PKGEXT() ;Entry point - Package File extract (ACTION Protocol: A1VS PKG EXTRACT CREATE ACTION)
;
; STOPKILL: 0^0 $JOB sub-array for ^XTMP("A1SIZE") did not exist and was created
; 0^1 $JOB sub-array for ^XTMP("A1SIZE") existed and was recreated
; 1^1 $JOB sub-array for ^XTMP("A1SIZE") existed and was NOT recreated
;
NEW STOPKILL
SET STOPKILL="0^0"
IF ($D(^XTMP("A1SIZE",$JOB))) DO QUIT:STOPKILL "1^1" ;;If STOPKILL, do NOT delete existing ^XTMP("A1SIZE",$J) global
. NEW X,Y,DIR
. SET DIR("A",1)=""
. SET DIR("A",2)="^XTMP(""A1SIZE"","_$JOB_") already exists!"
. SET DIR("A")="Do you want to delete ^XTMP(""A1SIZE"","_$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^A1VSLAPI("^XTMP(""A1SIZE"","_$JOB_") NOT DELETED!")
.. SET STOPKILL="1^1"
;
K ^XTMP("A1SIZE",$J) S ^XTMP("A1SIZE",$J,0)=$$NOW^XLFDT_"^"_^%ZOSF("PROD")
;
S VPIEN=0 F S VPIEN=$O(^DIC(9.4,VPIEN)) Q:'VPIEN S VPNAME=$P(^DIC(9.4,VPIEN,0),"^") DO
. IF $P($G(^DIC(9.4,VPIEN,15002)),"^",3)'="X" DO SETXTMP ;Screen CURRENT STATUS equals NO LONGER USED from extract
;
K VPNAME,VPN,VPLOW,VPHIGH,VPOTHER,VPNAT,VPRNGE
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 "|"
;
NEW VPPARPKG,PARNTNME
;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=""
Q:VPNAT'="I"
S VPN=$P(^DIC(9.4,VPIEN,0),"^",2) ; 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 ADITIONAL 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_^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_^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=^DIC(9.4,VPIEN,15001,VPIEN2,0)
..S:+VPFNUM>0 ^XTMP("A1SIZE",$J,VPNAME,VPFNUM)=""
;
;Get PARENT PACKAGE field (#15003) Parent name
IF VPPARPKG]"" DO
.SET PARNTNME=$P($G(^DIC(9.4,VPPARPKG,0)),"^")
;
S ^XTMP("A1SIZE",$J,VPNAME)=VPN_"^"_VPLOW_"^"_VPHIGH_"^"_VPOTHER_"^"_VPEXCPT_"^"_VPRNGE_"^"_PARNTNME
QUIT
;
XTMPORD(XDOLRJ) ; Read ^XTMP("A1SIZE) array and create ^TMP globals for listing/reporting
;Parameter List data map from Package file:
; 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("A1VS-FILERPT")
NEW LPCNT,FAMTREE,SUBSCPT,DATARY,RPT
;
DO FAMINDEX(XDOLRJ) ;Reorder ^XTMP("A1SIZE") into ^TMP("A1SIZE","IDX") to indicate family tree for a package
NEW PKGVAL,CHILDPKG,LINEITEM,FILENUM,FIRSTNUM
SET PKGVAL=0
FOR SET PKGVAL=$O(^XTMP("A1SIZE",XDOLRJ,PKGVAL)) Q:PKGVAL="authentication" QUIT:PKGVAL="" DO
. SET LINEITEM=""
. SET LINEITEM=$S("ZU |AUP |AUT |DRG |GMD |GMN |VDE |XIP "[PKGVAL:$P(PKGVAL," "),1:PKGVAL)_"^"_$P(^XTMP("A1SIZE",XDOLRJ,PKGVAL),"^",1,5)_"^^"_$P(^XTMP("A1SIZE",XDOLRJ,PKGVAL),"^",6,7) ;Also: AUT,AUP,DRG,GMD,GMN,VDE,XIP,VPFS
. SET FILENUM=0
. FOR SET FILENUM=$O(^XTMP("A1SIZE",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("A1SIZE",$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 - future use [0: no report, 1: No Ranges in multiple, 2: Files added to Range, 3: both no files and added ranges]
. 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("A1SIZE",$J) to LINEITEM
. ; If not 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
;
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("A1SIZE",XDOLRJ,PKGVAL)) Q:PKGVAL="authentication" Q:PKGVAL="" DO
. SET FAMTREE=""
. IF '$D(^TMP("A1SIZE","IDX",$J,PKGVAL)) DO
.. SET FAMTREE=$$ANCESTRY(PKGVAL,XDOLRJ)
.. SET ^TMP("A1SIZE","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("A1SIZE",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("A1SIZE","IDX",DOLRJ,PKG)) DO
. SET SUBSCPT=^TMP("A1SIZE","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("A1SIZE") node
; PKGVAL - Package reporting from ^XTMP("A1SIZE") node
; RPT - 1 : 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 the 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 End number of Ranges for an ending decimal place
IF $G(RPT)="" SET RPT=0
SET FILELIST=$P(LINEITEM,"^",7)
IF RPT,($P(FILELIST,"|",1)']"") DO RPTFLADD(PKGVAL,"NOLISTF","")
;
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("A1VS-FILERPT) for each file added to ranges
; INPUT : PKGVAL - Package reporting from ^XTMP("A1SIZE") 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("A1VS-FILERPT") array
;
NEW RPTARYND,NODEVAL
SET RPTARYND=$O(^TMP("A1VS-FILERPT",$J,PKGVAL,""),-1)
IF RPTARYND="" SET ^TMP("A1VS-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("A1VS-FILERPT",$J,PKGVAL,RPTARYND)=NODEVAL
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1VSLNA1 11745 printed Nov 22, 2024@16:48:55 Page 2
A1VSLNA1 ;BHAM/MAM/GTS - VistA Package Sizing Manager; 1-JUL-2016
+1 ;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
+2 ;
PKGEXT() ;Entry point - Package File extract (ACTION Protocol: A1VS PKG EXTRACT CREATE ACTION)
+1 ;
+2 ; STOPKILL: 0^0 $JOB sub-array for ^XTMP("A1SIZE") did not exist and was created
+3 ; 0^1 $JOB sub-array for ^XTMP("A1SIZE") existed and was recreated
+4 ; 1^1 $JOB sub-array for ^XTMP("A1SIZE") existed and was NOT recreated
+5 ;
+6 NEW STOPKILL
+7 SET STOPKILL="0^0"
+8 ;;If STOPKILL, do NOT delete existing ^XTMP("A1SIZE",$J) global
IF ($DATA(^XTMP("A1SIZE",$JOB)))
Begin DoDot:1
+9 NEW X,Y,DIR
+10 SET DIR("A",1)=""
+11 SET DIR("A",2)="^XTMP(""A1SIZE"","_$JOB_") already exists!"
+12 SET DIR("A")="Do you want to delete ^XTMP(""A1SIZE"","_$JOB_") and recreate it"
+13 SET DIR("B")="NO"
+14 SET DIR(0)="Y::"
+15 SET STOPKILL="0^1"
+16 DO ^DIR
+17 IF ($DATA(DTOUT))!($DATA(DUOUT))!(($GET(Y)=0))
Begin DoDot:2
+18 DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_$JOB_") NOT DELETED!")
+19 SET STOPKILL="1^1"
End DoDot:2
End DoDot:1
if STOPKILL
QUIT "1^1"
+20 ;
+21 KILL ^XTMP("A1SIZE",$JOB)
SET ^XTMP("A1SIZE",$JOB,0)=$$NOW^XLFDT_"^"_^%ZOSF("PROD")
+22 ;
+23 SET VPIEN=0
FOR
SET VPIEN=$ORDER(^DIC(9.4,VPIEN))
if 'VPIEN
QUIT
SET VPNAME=$PIECE(^DIC(9.4,VPIEN,0),"^")
Begin DoDot:1
+24 ;Screen CURRENT STATUS equals NO LONGER USED from extract
IF $PIECE($GET(^DIC(9.4,VPIEN,15002)),"^",3)'="X"
DO SETXTMP
End DoDot:1
+25 ;
+26 KILL VPNAME,VPN,VPLOW,VPHIGH,VPOTHER,VPNAT,VPRNGE
+27 QUIT STOPKILL
+28 ;
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 ;
+7 NEW VPPARPKG,PARNTNME
+8 ;Get Package CLASS and PARENT PACKAGE
+9 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=""
+10 if VPNAT'="I"
QUIT
+11 ; PREFIX
SET VPN=$PIECE(^DIC(9.4,VPIEN,0),"^",2)
+12 SET (VPEXCPT,VPOTHER,VPRNGE)=""
+13 ;*LOWEST/*HIGHEST FILE NUMBERS
SET VP11=$GET(^DIC(9.4,VPIEN,11))
SET VPLOW=$PIECE(VP11,"^")
SET VPHIGH=$PIECE(VP11,"^",2)
+14 ;Get ADITIONAL PREFIXES
+15 IF $DATA(^DIC(9.4,VPIEN,14))
Begin DoDot:1
+16 SET VPIEN2=0
FOR
SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,14,VPIEN2))
if 'VPIEN2
QUIT
SET VPOTHER=VPOTHER_^DIC(9.4,VPIEN,14,VPIEN2,0)_"|"
End DoDot:1
+17 ;Get EXCLUDED NAMESPACE
+18 IF $DATA(^DIC(9.4,VPIEN,"EX"))
Begin DoDot:1
+19 SET VPIEN2=0
FOR
SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,"EX",VPIEN2))
if 'VPIEN2
QUIT
SET VPEXCPT=VPEXCPT_^DIC(9.4,VPIEN,"EX",VPIEN2,0)_"|"
End DoDot:1
+20 ;
+21 ;Get File Number Ranges from multiple field 15001.1
+22 IF +$$FLDNUM^DILFD(9.4,"LOW-HIGH RANGE")=15001.1
IF $DATA(^DIC(9.4,VPIEN,15001))
Begin DoDot:1
+23 SET VPRNGE=""
+24 SET VPIEN2=0
+25 FOR
SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,15001.1,VPIEN2))
if 'VPIEN2
QUIT
Begin DoDot:2
+26 SET VPLNUM=$PIECE($GET(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^")
+27 SET VPHNUM=$PIECE($GET(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^",2)
+28 SET VPRNGE=VPRNGE_VPLNUM_"-"_VPHNUM_"|"
End DoDot:2
End DoDot:1
+29 ;
+30 ;Get File Numbers from multiple field 15001
+31 IF +$$FLDNUM^DILFD(9.4,"FILE NUMBER")=15001
IF $DATA(^DIC(9.4,VPIEN,15001))
Begin DoDot:1
+32 SET VPIEN2=0
+33 FOR
SET VPIEN2=$ORDER(^DIC(9.4,VPIEN,15001,VPIEN2))
if 'VPIEN2
QUIT
Begin DoDot:2
+34 SET (VPFNUM,VPLNUM,VPHNUM)=""
+35 SET VPFNUM=^DIC(9.4,VPIEN,15001,VPIEN2,0)
+36 if +VPFNUM>0
SET ^XTMP("A1SIZE",$JOB,VPNAME,VPFNUM)=""
End DoDot:2
End DoDot:1
+37 ;
+38 ;Get PARENT PACKAGE field (#15003) Parent name
+39 IF VPPARPKG]""
Begin DoDot:1
+40 SET PARNTNME=$PIECE($GET(^DIC(9.4,VPPARPKG,0)),"^")
End DoDot:1
+41 ;
+42 SET ^XTMP("A1SIZE",$JOB,VPNAME)=VPN_"^"_VPLOW_"^"_VPHIGH_"^"_VPOTHER_"^"_VPEXCPT_"^"_VPRNGE_"^"_PARNTNME
+43 QUIT
+44 ;
XTMPORD(XDOLRJ) ; Read ^XTMP("A1SIZE) array and create ^TMP globals for listing/reporting
+1 ;Parameter List data map from Package file:
+2 ; pce 1 : Package Name [Source: NAME (#.01)]
+3 ; pce 2 : Primary Prefix [Source: PREFIX (#1)]
+4 ; pce 3 : *Lowest File # [Source: *LOWEST FILE NUMBER (#10.6)]
+5 ; pce 4 : *Highest File # [Source: *HIGHEST FILE NUMBER (#11)]
+6 ; pce 5 : Pipe character (|) delimited list of Additional Prefixes [Source: ADDITIONAL PREFIXES multiple (#14)]
+7 ; pce 6 : Pipe character (|) delimited list of Excepted Prefixes [Source: EXCLUDED NAME SPACE multiple (#919)]
+8 ; pce 7 : Pipe character (|) delimited list of File entries [Source: FILE NUMBER multiple (#15001)]
+9 ; pce 8 : Pipe character (|) delimited list of File Range entries [Primary Source: LOW-HIGH RANGE multiple (#15001.1)]
+10 ; pce 9 : Parent Package [1st Source: PARENT PACKAGE field (#15003)]
+11 ;
+12 KILL ^TMP("A1VS-FILERPT")
+13 NEW LPCNT,FAMTREE,SUBSCPT,DATARY,RPT
+14 ;
+15 ;Reorder ^XTMP("A1SIZE") into ^TMP("A1SIZE","IDX") to indicate family tree for a package
DO FAMINDEX(XDOLRJ)
+16 NEW PKGVAL,CHILDPKG,LINEITEM,FILENUM,FIRSTNUM
+17 SET PKGVAL=0
+18 FOR
SET PKGVAL=$ORDER(^XTMP("A1SIZE",XDOLRJ,PKGVAL))
if PKGVAL="authentication"
QUIT
if PKGVAL=""
QUIT
Begin DoDot:1
+19 SET LINEITEM=""
+20 ;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("A1SIZE",XDOLRJ,PKGVAL),"^",1,5)_"^^"_$PIECE(^XTMP("A1SIZE",XDOLRJ,PKGVAL),"^",6,7)
+21 SET FILENUM=0
+22 FOR
SET FILENUM=$ORDER(^XTMP("A1SIZE",XDOLRJ,PKGVAL,FILENUM))
if FILENUM=""
QUIT
if FILENUM'?.N
QUIT
Begin DoDot:2
+23 ;ADD File List multiple to Pce 7
SET $PIECE(LINEITEM,"^",7)=$PIECE(LINEITEM,"^",7)_FILENUM_"|"
End DoDot:2
+24 SET FAMTREE=$$LINEAGE(PKGVAL,$JOB)
+25 KILL SUBS
+26 FOR LPCNT=1:1
SET SUBSCPT=$PIECE(FAMTREE,"^",LPCNT)
if SUBSCPT=""
QUIT
SET SUBS(LPCNT)=SUBSCPT
+27 SET DATARY=$PIECE($NAME(^TMP("A1SIZE",$JOB)),")")
+28 SET LPCNT=0
+29 FOR
SET LPCNT=$ORDER(SUBS(LPCNT))
if (LPCNT="")
QUIT
Begin DoDot:2
+30 SET SUBSCPT=SUBS(LPCNT)
+31 SET DATARY=DATARY_","_""_SUBSCPT
End DoDot:2
+32 SET DATARY=DATARY_")"
+33 ;
+34 ;NOTE: RPT - future use [0: no report, 1: No Ranges in multiple, 2: Files added to Range, 3: both no files and added ranges]
+35 ;;To report file changes
SET RPT=3
+36 ;CLEANUP File Range multiple in Pce 8
SET $PIECE(LINEITEM,"^",8)=$$FLRNGCLN(LINEITEM,PKGVAL,RPT)
+37 ;Set ^TMP("A1SIZE",$J) to LINEITEM
SET @DATARY=LINEITEM
+38 ; If not FILE or RANGE Multiple Entries, report High/Low File number fields
+39 IF RPT
Begin DoDot:2
+40 NEW LOW,HIGH,RPTRNG,LINERNG
+41 SET LINERNG=$PIECE(LINEITEM,"^",8)
+42 ;Only check High/Low fields when Range multiple undefined
IF $PIECE(LINERNG,"|")=""
Begin DoDot:3
+43 SET LOW=$PIECE(LINEITEM,"^",3)
+44 SET HIGH=$PIECE(LINEITEM,"^",4)
+45 SET RPTRNG=LOW_"-"_HIGH
+46 if RPTRNG="-"
SET RPTRNG="No File Ranges or High/Low Fields"
+47 IF RPTRNG["-"
Begin DoDot:4
+48 if $PIECE(RPTRNG,"-")=""
SET $PIECE(RPTRNG,"-",1)="<begin undefined>"
+49 if $PIECE(RPTRNG,"-",2)=""
SET $PIECE(RPTRNG,"-",2)="<end undefined>"
End DoDot:4
+50 DO RPTFLADD(PKGVAL,"HL",RPTRNG)
End DoDot:3
End DoDot:2
End DoDot:1
+51 ;
+52 KILL SUBS
+53 ;
+54 QUIT
+55 ;
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("A1SIZE",XDOLRJ,PKGVAL))
if PKGVAL="authentication"
QUIT
if PKGVAL=""
QUIT
Begin DoDot:1
+5 SET FAMTREE=""
+6 IF '$DATA(^TMP("A1SIZE","IDX",$JOB,PKGVAL))
Begin DoDot:2
+7 SET FAMTREE=$$ANCESTRY(PKGVAL,XDOLRJ)
+8 SET ^TMP("A1SIZE","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("A1SIZE",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("A1SIZE","IDX",DOLRJ,PKG))
Begin DoDot:1
+4 SET SUBSCPT=^TMP("A1SIZE","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("A1SIZE") node
+2 ; PKGVAL - Package reporting from ^XTMP("A1SIZE") node
+3 ; RPT - 1 : 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 the 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 End number of Ranges for an ending decimal place
+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 SET RANGE=$PIECE(LINEITEM,"^",8)
+19 FOR RNGPCE=1:1
SET FLERNGE=$PIECE(RANGE,"|",RNGPCE)
if FLERNGE=""
QUIT
Begin DoDot:1
+20 SET ENDFLNM=$PIECE(FLERNGE,"-",2)
+21 SET ENDFNDC=$PIECE(ENDFLNM,".",2)
+22 IF ENDFNDC=""
Begin DoDot:2
+23 SET BEGFLNM=$PIECE($PIECE(RANGE,"|",RNGPCE),"-")
+24 SET $PIECE(ENDFLNM,".",2)="9999"
+25 SET $PIECE(FLERNG,"-",2)=ENDFLNM
+26 SET $PIECE(RANGE,"|",RNGPCE)=BEGFLNM_FLERNG
+27 IF RPT
DO RPTFLADD(PKGVAL,"RNGUPDT",BEGFLNM_FLERNG)
End DoDot:2
End DoDot:1
+28 ;
+29 ;Check file numbers in FILE list to see if included in RANGE list'
+30 SET FILEPCE=$PIECE(LINEITEM,"^",7)
+31 FOR PCENUM=1:1
SET FILENUM=$PIECE(FILEPCE,"|",PCENUM)
if FILENUM=""
QUIT
Begin DoDot:1
+32 SET FNNEWRNG=1
+33 FOR RNGPCE=1:1
SET FLERNGE=$PIECE(RANGE,"|",RNGPCE)
if FLERNGE=""
QUIT
Begin DoDot:2
+34 SET BEGFLNM=$PIECE(FLERNGE,"-",1)
+35 SET BEGFLNM=$$SETRNG(BEGFLNM,"LOWER")
+36 SET ENDFLNM=$PIECE(FLERNGE,"-",2)
+37 SET ENDFLNM=$$SETRNG(ENDFLNM,"UPPER")
+38 IF (+FILENUM>BEGFLNM)
IF (+FILENUM<ENDFLNM)
SET FNNEWRNG=0
End DoDot:2
+39 IF FNNEWRNG
Begin DoDot:2
+40 SET FNUMLNG=$LENGTH($PIECE(FILENUM,".",2))
+41 SET (START,END)=FILENUM
+42 IF FNUMLNG=0
SET END=END_"."
+43 IF FNUMLNG<4
FOR LPCNT=1:1:4-FNUMLNG
SET END=END_"9"
+44 IF FNUMLNG>3
SET END=END_"9"
+45 IF RPT
DO RPTFLADD(PKGVAL,"FILE",START_"-"_END)
+46 if RANGE'=""
SET RANGE=RANGE_START_"-"_END_"|"
+47 if RANGE=""
SET RANGE=START_"-"_END_"|"
End DoDot:2
End DoDot:1
+48 QUIT RANGE
+49 ;
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("A1VS-FILERPT) for each file added to ranges
+1 ; INPUT : PKGVAL - Package reporting from ^XTMP("A1SIZE") 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("A1VS-FILERPT") array
+10 ;
+11 NEW RPTARYND,NODEVAL
+12 SET RPTARYND=$ORDER(^TMP("A1VS-FILERPT",$JOB,PKGVAL,""),-1)
+13 IF RPTARYND=""
SET ^TMP("A1VS-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("A1VS-FILERPT",$JOB,PKGVAL,RPTARYND)=NODEVAL
+24 QUIT
