Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: A1VSLNA1

A1VSLNA1.m

Go to the documentation of this file. 
  1. A1VSLNA1 ;BHAM/MAM/GTS - VistA Package Sizing Manager; 1-JUL-2016
  1.  ;;1.0;VistA Package Sizing;;Oct 10, 2016;Build 25
  1.  ;
  1. PKGEXT() ;Entry point - Package File extract (ACTION Protocol: A1VS PKG EXTRACT CREATE ACTION)
  1.  ;
  1.  ; STOPKILL: 0^0  $JOB sub-array for ^XTMP("A1SIZE") did not exist and was created
  1.  ;           0^1  $JOB sub-array for ^XTMP("A1SIZE") existed and was recreated
  1.  ;           1^1  $JOB sub-array for ^XTMP("A1SIZE") existed and was NOT recreated
  1.  ;
  1.  NEW STOPKILL
  1.  SET STOPKILL="0^0"
  1.  IF ($D(^XTMP("A1SIZE",$JOB))) DO  QUIT:STOPKILL "1^1"  ;;If STOPKILL, do NOT delete existing ^XTMP("A1SIZE",$J) global
  1.  . NEW X,Y,DIR
  1.  . SET DIR("A",1)=""
  1.  . SET DIR("A",2)="^XTMP(""A1SIZE"","_$JOB_") already exists!"
  1.  . SET DIR("A")="Do you want to delete ^XTMP(""A1SIZE"","_$JOB_") and recreate it"
  1.  . SET DIR("B")="NO"
  1.  . SET DIR(0)="Y::"
  1.  . SET STOPKILL="0^1"
  1.  . DO ^DIR
  1.  . IF ($D(DTOUT))!($D(DUOUT))!(($G(Y)=0)) DO
  1.  .. DO JUSTPAWS^A1VSLAPI("^XTMP(""A1SIZE"","_$JOB_") NOT DELETED!")
  1.  .. SET STOPKILL="1^1"
  1.  ;
  1.  K ^XTMP("A1SIZE",$J) S ^XTMP("A1SIZE",$J,0)=$$NOW^XLFDT_"^"_^%ZOSF("PROD")
  1.  ;
  1.  S VPIEN=0 F  S VPIEN=$O(^DIC(9.4,VPIEN)) Q:'VPIEN  S VPNAME=$P(^DIC(9.4,VPIEN,0),"^") DO
  1.  . IF $P($G(^DIC(9.4,VPIEN,15002)),"^",3)'="X" DO SETXTMP ;Screen CURRENT STATUS equals NO LONGER USED from extract
  1.  ;
  1.  K VPNAME,VPN,VPLOW,VPHIGH,VPOTHER,VPNAT,VPRNGE
  1.  QUIT STOPKILL
  1.  ;
  1. SETXTMP ; set ^XTMP global with PACKAGE data
  1.  ;
  1.  ; Piece 1 = Namespace
  1.  ; Piece 2 = Lower File Number Range
  1.  ; Piece 3 = Highest File Number Range
  1.  ; Piece 4 = Other Namepaces separated by "|"
  1.  ;
  1.  NEW VPPARPKG,PARNTNME
  1.  ;Get Package CLASS and PARENT PACKAGE
  1.  S VPNAT=$G(^DIC(9.4,VPIEN,7)),VPNAT=$P(VPNAT,"^",3),VPPARPKG=$P($GET(^DIC(9.4,VPIEN,15002)),"^",2),PARNTNME=""
  1.  Q:VPNAT'="I"
  1.  S VPN=$P(^DIC(9.4,VPIEN,0),"^",2) ; PREFIX
  1.  S (VPEXCPT,VPOTHER,VPRNGE)=""
  1.  S VP11=$G(^DIC(9.4,VPIEN,11)),VPLOW=$P(VP11,"^"),VPHIGH=$P(VP11,"^",2) ;*LOWEST/*HIGHEST FILE NUMBERS
  1.  ;Get ADITIONAL PREFIXES
  1.  IF $D(^DIC(9.4,VPIEN,14)) DO
  1.  . 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)_"|"
  1.  ;Get EXCLUDED NAMESPACE
  1.  IF $D(^DIC(9.4,VPIEN,"EX")) DO
  1.  . 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)_"|"
  1.  ;
  1.  ;Get File Number Ranges from multiple field 15001.1
  1.  IF +$$FLDNUM^DILFD(9.4,"LOW-HIGH RANGE")=15001.1,$D(^DIC(9.4,VPIEN,15001)) DO
  1.  .S VPRNGE=""
  1.  .S VPIEN2=0
  1.  .F  S VPIEN2=$O(^DIC(9.4,VPIEN,15001.1,VPIEN2)) Q:'VPIEN2  DO
  1.  ..S VPLNUM=$P($G(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^")
  1.  ..S VPHNUM=$P($G(^DIC(9.4,VPIEN,15001.1,VPIEN2,0)),"^",2)
  1.  ..S VPRNGE=VPRNGE_VPLNUM_"-"_VPHNUM_"|"
  1.  ;
  1.  ;Get File Numbers from multiple field 15001
  1.  IF +$$FLDNUM^DILFD(9.4,"FILE NUMBER")=15001,$D(^DIC(9.4,VPIEN,15001)) DO
  1.  .S VPIEN2=0
  1.  .FOR  S VPIEN2=$O(^DIC(9.4,VPIEN,15001,VPIEN2)) Q:'VPIEN2  DO
  1.  ..S (VPFNUM,VPLNUM,VPHNUM)=""
  1.  ..S VPFNUM=^DIC(9.4,VPIEN,15001,VPIEN2,0)
  1.  ..S:+VPFNUM>0 ^XTMP("A1SIZE",$J,VPNAME,VPFNUM)=""
  1.  ;
  1.  ;Get PARENT PACKAGE field (#15003) Parent name
  1.  IF VPPARPKG]"" DO
  1.  .SET PARNTNME=$P($G(^DIC(9.4,VPPARPKG,0)),"^")
  1.  ;
  1.  S ^XTMP("A1SIZE",$J,VPNAME)=VPN_"^"_VPLOW_"^"_VPHIGH_"^"_VPOTHER_"^"_VPEXCPT_"^"_VPRNGE_"^"_PARNTNME
  1.  QUIT
  1.  ;
  1. XTMPORD(XDOLRJ) ; Read ^XTMP("A1SIZE) array and create ^TMP globals for listing/reporting
  1.  ;Parameter List data map from Package file:
  1.  ; pce 1 : Package Name [Source: NAME (#.01)]
  1.  ; pce 2 : Primary Prefix [Source: PREFIX (#1)]
  1.  ; pce 3 : *Lowest File # [Source: *LOWEST FILE NUMBER (#10.6)]
  1.  ; pce 4 : *Highest File # [Source: *HIGHEST FILE NUMBER (#11)]
  1.  ; pce 5 : Pipe character (|) delimited list of Additional Prefixes [Source: ADDITIONAL PREFIXES multiple (#14)]
  1.  ; pce 6 : Pipe character (|) delimited list of Excepted Prefixes [Source: EXCLUDED NAME SPACE multiple (#919)]
  1.  ; pce 7 : Pipe character (|) delimited list of File entries [Source: FILE NUMBER multiple (#15001)]
  1.  ; pce 8 : Pipe character (|) delimited list of File Range entries [Primary Source: LOW-HIGH RANGE multiple (#15001.1)]
  1.  ; pce 9 : Parent Package [1st Source: PARENT PACKAGE field (#15003)]
  1.  ;
  1.  KILL ^TMP("A1VS-FILERPT")
  1.  NEW LPCNT,FAMTREE,SUBSCPT,DATARY,RPT
  1.  ;
  1.  DO FAMINDEX(XDOLRJ) ;Reorder ^XTMP("A1SIZE") into ^TMP("A1SIZE","IDX") to indicate family tree for a package
  1.  NEW PKGVAL,CHILDPKG,LINEITEM,FILENUM,FIRSTNUM
  1.  SET PKGVAL=0
  1.  FOR  SET PKGVAL=$O(^XTMP("A1SIZE",XDOLRJ,PKGVAL)) Q:PKGVAL="authentication"  QUIT:PKGVAL=""  DO
  1.  . SET LINEITEM=""
  1.  . 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
  1.  . SET FILENUM=0
  1.  . FOR  SET FILENUM=$O(^XTMP("A1SIZE",XDOLRJ,PKGVAL,FILENUM)) QUIT:FILENUM=""  Q:FILENUM'?.N  DO
  1.  .. SET $P(LINEITEM,"^",7)=$P(LINEITEM,"^",7)_FILENUM_"|" ;ADD File List multiple to Pce 7
  1.  . SET FAMTREE=$$LINEAGE(PKGVAL,$J)
  1.  . KILL SUBS
  1.  . FOR LPCNT=1:1 SET SUBSCPT=$P(FAMTREE,"^",LPCNT) QUIT:SUBSCPT=""  S SUBS(LPCNT)=SUBSCPT
  1.  . SET DATARY=$P($NAME(^TMP("A1SIZE",$J)),")")
  1.  . SET LPCNT=0
  1.  . FOR  SET LPCNT=$O(SUBS(LPCNT)) QUIT:(LPCNT="")  DO
  1.  .. SET SUBSCPT=SUBS(LPCNT)
  1.  .. SET DATARY=DATARY_","_""_SUBSCPT
  1.  . SET DATARY=DATARY_")"
  1.  . ;
  1.  . ;NOTE: RPT - future use [0: no report, 1: No Ranges in multiple, 2: Files added to Range, 3: both no files and added ranges]
  1.  . SET RPT=3 ;;To report file changes
  1.  . SET $P(LINEITEM,"^",8)=$$FLRNGCLN(LINEITEM,PKGVAL,RPT) ;CLEANUP File Range multiple in Pce 8
  1.  . SET @DATARY=LINEITEM ;Set ^TMP("A1SIZE",$J) to LINEITEM
  1.  . ; If not FILE or RANGE Multiple Entries, report High/Low File number fields
  1.  . IF RPT DO
  1.  .. NEW LOW,HIGH,RPTRNG,LINERNG
  1.  .. SET LINERNG=$P(LINEITEM,"^",8)
  1.  .. IF $P(LINERNG,"|")="" DO  ;Only check High/Low fields when Range multiple undefined
  1.  ... SET LOW=$P(LINEITEM,"^",3)
  1.  ... SET HIGH=$P(LINEITEM,"^",4)
  1.  ... SET RPTRNG=LOW_"-"_HIGH
  1.  ... SET:RPTRNG="-" RPTRNG="No File Ranges or High/Low Fields"
  1.  ... IF RPTRNG["-" DO
  1.  .... SET:$P(RPTRNG,"-")="" $P(RPTRNG,"-",1)="<begin undefined>"
  1.  .... SET:$P(RPTRNG,"-",2)="" $P(RPTRNG,"-",2)="<end undefined>"
  1.  ... DO RPTFLADD(PKGVAL,"HL",RPTRNG)
  1.  ;
  1.  KILL SUBS
  1.  ;
  1.  QUIT
  1.  ;
  1. FAMINDEX(XDOLRJ) ; Create a package family tree ^TMP global=pkg^parentpkg^grndparentpkg^etc.
  1.  NEW PARNTPKG
  1.  NEW FAMTREE,PKGVAL
  1.  SET PKGVAL=0
  1.  FOR  SET PKGVAL=$O(^XTMP("A1SIZE",XDOLRJ,PKGVAL)) Q:PKGVAL="authentication"  Q:PKGVAL=""  DO
  1.  . SET FAMTREE=""
  1.  . IF '$D(^TMP("A1SIZE","IDX",$J,PKGVAL)) DO
  1.  .. SET FAMTREE=$$ANCESTRY(PKGVAL,XDOLRJ)
  1.  .. SET ^TMP("A1SIZE","IDX",$J,PKGVAL)=FAMTREE
  1.  QUIT
  1.  ;
  1. ANCESTRY(PKGVAL,XDOLRJ) ; Return list of package-parent-grandparent-etc. relationships
  1.  NEW FAMTREE,PARENT,LASTPRNT
  1.  SET PARENT=PKGVAL
  1.  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)
  1.  FOR  QUIT:PARENT=""  SET LASTPRNT=PARENT SET PARENT=$P($G(^XTMP("A1SIZE",XDOLRJ,PARENT)),"^",7) QUIT:PARENT=LASTPRNT  QUIT:((FAMTREE["^")&(FAMTREE[PARENT))  DO
  1.  . IF PARENT'="" DO
  1.  .. SET FAMTREE=FAMTREE_"^"_PARENT
  1.  QUIT FAMTREE
  1.  ;
  1. LINEAGE(PKG,DOLRJ) ; Return a family tree subscript string
  1.  NEW CHKLVL,SUBLVL,SUBSCPT,FAMTREE,SUB
  1.  SET SUBSCPT=""
  1.  IF $D(^TMP("A1SIZE","IDX",DOLRJ,PKG)) DO
  1.  . SET SUBSCPT=^TMP("A1SIZE","IDX",DOLRJ,PKG)
  1.  . FOR SUBLVL=1:1 SET SUB(SUBLVL)=$P(SUBSCPT,"^",SUBLVL)  IF SUB(SUBLVL)="" KILL SUB(SUBLVL) QUIT
  1.  . SET (SUBSCPT,SUBLVL)=""
  1.  . FOR  SET SUBLVL=$O(SUB(SUBLVL),-1) Q:SUBLVL=""  SET SUBSCPT=SUBSCPT_SUB(SUBLVL)_""""_"^"_""""
  1.  . SET SUBSCPT=""""_$P(SUBSCPT,"^",1,$O(SUB(SUBLVL),-1))
  1.  QUIT SUBSCPT
  1.  ;
  1. FLRNGCLN(LINEITEM,PKGVAL,RPT) ;Cleanup File Ranges received from Forum Package file
  1.  ; INPUT : LINEITEM - Value of ^XTMP("A1SIZE") node
  1.  ;         PKGVAL   - Package reporting from ^XTMP("A1SIZE") node
  1.  ;         RPT      - 1 : Report Range additions
  1.  ;                    0 : Do not report Range additions
  1.  ;
  1.  ; File range of LineItem (pce 8) will be "cleaned up" as follows:
  1.  ;  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)
  1.  ;  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)
  1.  ;
  1.  NEW RANGE,BEGFLNM,ENDFLNM,ENDFNDC,FILERNG,RNGPCE,FILENUM,FILEPCE,FILENUM,PCENUM
  1.  NEW ADDRNGE,FNUMLNG,LPCNT,START,END,FNNEWRNG,FILELIST
  1.  ;
  1.  ;Check End number of Ranges for an ending decimal place
  1.  IF $G(RPT)="" SET RPT=0
  1.  SET FILELIST=$P(LINEITEM,"^",7)
  1.  IF RPT,($P(FILELIST,"|",1)']"") DO RPTFLADD(PKGVAL,"NOLISTF","")
  1.  ;
  1.  SET RANGE=$P(LINEITEM,"^",8)
  1.  FOR RNGPCE=1:1 SET FLERNGE=$P(RANGE,"|",RNGPCE) Q:FLERNGE=""  DO
  1.  . SET ENDFLNM=$P(FLERNGE,"-",2)
  1.  . SET ENDFNDC=$P(ENDFLNM,".",2)
  1.  . IF ENDFNDC="" DO
  1.  .. SET BEGFLNM=$P($P(RANGE,"|",RNGPCE),"-")
  1.  .. SET $P(ENDFLNM,".",2)="9999"
  1.  .. SET $P(FLERNG,"-",2)=ENDFLNM
  1.  .. SET $P(RANGE,"|",RNGPCE)=BEGFLNM_FLERNG
  1.  .. IF RPT DO RPTFLADD(PKGVAL,"RNGUPDT",BEGFLNM_FLERNG)
  1.  ;
  1.  ;Check file numbers in FILE list to see if included in RANGE list'
  1.  SET FILEPCE=$P(LINEITEM,"^",7)
  1.  FOR PCENUM=1:1 SET FILENUM=$P(FILEPCE,"|",PCENUM) Q:FILENUM=""  DO
  1.  . SET FNNEWRNG=1
  1.  . FOR RNGPCE=1:1 SET FLERNGE=$P(RANGE,"|",RNGPCE) Q:FLERNGE=""  DO
  1.  .. SET BEGFLNM=$P(FLERNGE,"-",1)
  1.  .. SET BEGFLNM=$$SETRNG(BEGFLNM,"LOWER")
  1.  .. SET ENDFLNM=$P(FLERNGE,"-",2)
  1.  .. SET ENDFLNM=$$SETRNG(ENDFLNM,"UPPER")
  1.  .. IF (+FILENUM>BEGFLNM),(+FILENUM<ENDFLNM) SET FNNEWRNG=0
  1.  . IF FNNEWRNG DO
  1.  .. SET FNUMLNG=$L($P(FILENUM,".",2))
  1.  .. SET (START,END)=FILENUM
  1.  .. IF FNUMLNG=0 SET END=END_"."
  1.  .. IF FNUMLNG<4 FOR LPCNT=1:1:4-FNUMLNG SET END=END_"9"
  1.  .. IF FNUMLNG>3 SET END=END_"9"
  1.  .. IF RPT DO RPTFLADD(PKGVAL,"FILE",START_"-"_END)
  1.  .. SET:RANGE'="" RANGE=RANGE_START_"-"_END_"|"
  1.  .. SET:RANGE="" RANGE=START_"-"_END_"|"
  1.  Q RANGE
  1.  ;
  1. SETRNG(FILENUM,PLACE) ; Either add to or subtract a fraction from the range number
  1.  ; PLACE - UPPER: Add a fraction to number
  1.  ;       - LOWER: Subract a fraction from number
  1.  NEW RESULT,DECVAL,PLCS,DELTA,LPCNT
  1.  SET DECVAL=$P(FILENUM,".",2)
  1.  SET PLCS=$L(DECVAL)
  1.  SET DELTA="0."
  1.  FOR LPCNT=1:1:PLCS SET DELTA=DELTA_"0"
  1.  SET DELTA=DELTA_"1"
  1.  IF PLACE="LOWER" SET RESULT=FILENUM-DELTA
  1.  IF PLACE="UPPER" SET RESULT=FILENUM+DELTA
  1.  Q RESULT
  1.  ;
  1. 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
  1.  ;         TYPE     - FILE    : File Multiple
  1.  ;                  - HL      : High/Low range fields
  1.  ;                  - RNGUPDT : Range Multiple
  1.  ;                  - NOLISTF : File List Multiple not defined
  1.  ;
  1.  ;         RANGE    - File Range
  1.  ;
  1.  ; OUTPUT: Report Node added to ^TMP("A1VS-FILERPT") array
  1.  ;
  1.  NEW RPTARYND,NODEVAL
  1.  SET RPTARYND=$O(^TMP("A1VS-FILERPT",$J,PKGVAL,""),-1)
  1.  IF RPTARYND="" SET ^TMP("A1VS-FILERPT",$J,PKGVAL,1)=PKGVAL_" Package entry file number notes:" SET RPTARYND=1
  1.  SET RPTARYND=RPTARYND+1
  1.  SET NODEVAL=""
  1.  IF TYPE="FILE" SET NODEVAL="    "_RANGE_"  [File Multiple added to Range Multiple]"
  1.  IF (TYPE="HL") DO
  1.  . IF (RANGE'["No File Ranges or High/Low Fields") SET NODEVAL="    "_RANGE_"  [Range Multiple undefined, High/Low Field range only]"
  1.  . IF (RANGE["No File Ranges or High/Low Fields") SET NODEVAL="    Ranges Undefined ["_RANGE_"]"
  1.  IF TYPE="RNGUPDT" SET NODEVAL="    "_RANGE_"  [Decimal on Range End extended by nine(s)]"
  1.  IF TYPE="NOLISTF" SET NODEVAL="    No File List  [No File Multiple Entries defined]"
  1.  ;
  1.  SET:NODEVAL]"" ^TMP("A1VS-FILERPT",$J,PKGVAL,RPTARYND)=NODEVAL
  1.  QUIT