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

DIKCU.m

Go to the documentation of this file. 
  1. DIKCU ;SFISC/MKO-LIBRARY OF GENERIC MODULES ;9:29 AM  22 Oct 1998
  1.  ;;22.0;VA FileMan;;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;===============
  1.  ; PUSHDA(.DA,N)
  1.  ;===============
  1.  ;Push down the DA array, N times
  1.  ;
  1. PUSHDA(DA,N) ;
  1.  N I
  1.  S:'$G(N) N=1
  1.  F I=+$O(DA(""),-1):-1:1 S DA(I+N)=$G(DA(I))
  1.  S DA(N)=$G(DA)
  1.  S DA=0 F I=N-1:-1:1 S DA(I)=0
  1.  Q
  1.  ;
  1.  ;==============
  1.  ; POPDA(.DA,N)
  1.  ;==============
  1.  ;Pop the DA array
  1.  ;
  1. POPDA(DA,N) ;
  1.  N I,L
  1.  S:'$G(N) N=1
  1.  S L=+$O(DA(""),-1)
  1.  S DA=$G(DA(N))
  1.  F I=N+1:1:L S DA(I-N)=$G(DA(I))
  1.  F I=L-N+1:1:L K DA(I)
  1.  Q
  1.  ;
  1.  ;=================
  1.  ; $$IENS(File,DA)
  1.  ;=================
  1.  ;Return IENS given file# and DA array
  1.  ;In:
  1.  ; FIL = File or subfile #
  1.  ; DA  = DA array (any unneeded elements in the DA array are ignored)
  1.  ;
  1. IENS(FIL,DA) ;
  1.  N LEV,I,IENS,ERR
  1.  Q:$G(FIL)="" ""
  1.  S LEV=$$FLEV(FIL) Q:LEV="" ""
  1.  ;
  1.  ;Build IENS
  1.  S IENS=$G(DA)_","
  1.  F I=1:1:LEV S IENS=IENS_$G(DA(I))_","
  1.  Q IENS
  1.  ;
  1.  ;=========================
  1.  ; $$FNUM(Root,Flag)
  1.  ;=========================
  1.  ;Given file root, return File # from 2nd piece of header node.
  1.  ;Also check that that file has a DD entry and a non-wp .01 field.
  1.  ;Return null if error.
  1.  ;In:
  1.  ;  ROOT = file root
  1.  ;  F    [ D : generate dialog
  1.  ;
  1. FNUM(ROOT,F) ;
  1.  Q:$G(ROOT)="" ""
  1.  N FIL
  1.  S ROOT=$$CREF(ROOT)
  1.  I $D(@ROOT@(0))[0 D:$G(F)["D" ERR^DIKCU2(404,"","","",ROOT) Q ""
  1.  S FIL=+$P(@ROOT@(0),U,2)
  1.  I '$$VFNUM^DIKCU1(FIL,$G(F)) Q ""
  1.  Q FIL
  1.  ;
  1.  ;===============================
  1.  ; $$FROOTDA(File,Flag,.L,.TRoot
  1.  ;===============================
  1.  ;Return global root of File; may include DA(1), DA(2), ... for subfiles
  1.  ;Examples: ^DIZ(9999) and ^DIZ(9999,DA(1),"MULT1")
  1.  ;In:
  1.  ;  FIL  = file #
  1.  ;  FLAG [ O : return open root
  1.  ;       [ D : generate dialog
  1.  ;       starts with number : indicates offset to use for DA array
  1.  ;Out:
  1.  ; .L     = level of file
  1.  ; .TROOT = top level root
  1.  ;
  1. FROOTDA(FIL,F,L,TROOT) ;
  1.  I $G(FIL)="" S (L,TROOT)="" Q ""
  1.  S F=$G(F)
  1.  ;
  1.  ;If top level, return "GL"
  1.  I $D(^DIC(FIL,0,"GL"))#2 D  Q TROOT
  1.  . S L=0,TROOT=$S(F["O":^("GL"),1:$$CREF(^("GL")))
  1.  ;
  1.  ;Must be a subfile level, get mult nodes, and level
  1.  N ERR,I,MFLD,ND,PAR,ROOT,SUB
  1.  S SUB=FIL
  1.  F L=0:1 S PAR=$G(^DD(SUB,0,"UP")) Q:'PAR  D  Q:$G(ERR)
  1.  . S MFLD=$O(^DD(PAR,"SB",SUB,""))
  1.  . S ND=$P($P($G(^DD(PAR,MFLD,0)),U,4),";")
  1.  . I ND?." " S ERR=1 D:F["D" ERR^DIKCU2(502,PAR,"",MFLD) Q
  1.  . S:ND'=+$P(ND,"E") ND=""""_ND_""""
  1.  . S ND(L+1)=ND
  1.  . S SUB=PAR
  1.  I $G(ERR) S (L,TROOT)="" Q ""
  1.  ;
  1.  ;Build global root for subfile
  1.  S (ROOT,TROOT)=$G(^DIC(SUB,0,"GL"))
  1.  I ROOT="" D:F["D" ERR^DIKCU2(402,SUB) S L="" Q ""
  1.  ;
  1.  F I=L:-1:1 S ROOT=ROOT_"DA("_(I+F)_"),"_ND(I)_","
  1.  S:F'["O" TROOT=$$CREF(TROOT)
  1.  Q $S(F["O":ROOT,1:$$CREF(ROOT))
  1.  ;
  1. CREF(X) ;Return closed root of X
  1.  N F,L
  1.  S L=$E(X,$L(X)),F=$E(X,1,$L(X)-1)
  1.  Q $S(L="(":F,L=",":F_")",1:X)
  1.  ;
  1.  ;================
  1.  ; $$FLEV(File,F)
  1.  ;================
  1.  ;Return the level of File
  1.  ;In:
  1.  ; FIL = file#
  1.  ; F   [ "D" : generate Dialog
  1.  ;
  1. FLEV(FIL,F) ;
  1.  Q:$G(FIL)="" ""
  1.  ;
  1.  N LEV
  1.  F LEV=0:1 Q:$G(^DD(FIL,0,"UP"))=""  S FIL=^("UP")
  1.  I '$D(^DD(FIL)) D:$G(F)["D" ERR^DIKCU2(402,FIL) Q ""
  1.  Q LEV
  1.  ;
  1.  ;=========================
  1.  ; $$FLEVDIFF(File1,File2)
  1.  ;=========================
  1.  ;Find the difference in levels between File1 and File2.
  1.  ;File1 is an ancestor of File2.
  1.  ;In:
  1.  ; FIL1 = File or subfile # of ancestor
  1.  ; FIL2 = File or subfile #
  1.  ;Returns: level difference; null if invalid input
  1.  ;
  1. FLEVDIFF(FIL1,FIL2) ;
  1.  Q:$G(FIL1)=""!($G(FIL2)="") ""
  1.  ;
  1.  N DIFF,FIL
  1.  S FIL=FIL2
  1.  F DIFF=0:1 Q:FIL=FIL1  S FIL=$G(^DD(FIL,0,"UP")) Q:FIL=""
  1.  Q $S(FIL=FIL1:DIFF,1:"")
  1.  ;
  1.  ;===============================================
  1.  ; SUBFILES(File,.Subfile#Array,.NodeArray,Flag)
  1.  ;===============================================
  1.  ;Build list of subfiles
  1.  ;In:
  1.  ;  FIL = file #
  1.  ;  FLG = 1 (if wp subfiles should be returned)
  1.  ;Out:
  1.  ; .SB(subfile#)           = parentFile#
  1.  ; .MF(file#,multField#)   = node
  1.  ; .MF(file#,multField#,0) = subfile#
  1.  ;
  1. SUBFILES(FIL,SB,MF,FLG) ;
  1.  Q:$G(FIL)=""
  1.  N SUB,MUL,ND
  1.  ;
  1.  ;Loop through "SB" nodes
  1.  S SUB="" F  S SUB=$O(^DD(FIL,"SB",SUB)) Q:'SUB  D
  1.  . S MUL=$O(^DD(FIL,"SB",SUB,0)) Q:'MUL
  1.  . Q:$D(^DD(SUB,.01,0))[0  Q:$P(^(0),U,2)["W"&'$G(FLG)
  1.  . ;
  1.  . S ND=$P($P(^DD(FIL,MUL,0),U,4),";") Q:ND=""
  1.  . S SB(SUB)=FIL,MF(FIL,MUL)=ND,MF(FIL,MUL,0)=SUB
  1.  . ;
  1.  . ;Make a recursive call to get all subfiles under file SUB
  1.  . D SUBFILES(SUB,.SB,.MF,$G(FLG))
  1.  Q
  1.  ;
  1.  ;============================
  1.  ; SBINFO(Subfile,.NodeArray)
  1.  ;============================
  1.  ;Get info for Subfile
  1.  ;In:
  1.  ;  SUB = subfile #
  1.  ;Out:
  1.  ; .MF(file#,multField#)   = node
  1.  ; .MF(file#,multField#,0) = subfile#
  1.  ;
  1. SBINFO(SUB,MF) ;
  1.  N ERR,MUL,ND,PAR
  1.  F  S PAR=$G(^DD(SUB,0,"UP")) Q:'PAR  D  Q:$G(ERR)
  1.  . S MUL=$O(^DD(PAR,"SB",SUB,0)) I 'MUL S ERR=1 Q
  1.  . S ND=$P($P(^DD(PAR,MUL,0),U,4),";") I ND="" S ERR=1 Q
  1.  . S MF(PAR,MUL)=ND,MF(PAR,MUL,0)=SUB,SUB=PAR
  1.  Q
  1.  ;
  1.  ;============================
  1.  ; SELFILE(Root,TopFile,File)
  1.  ;============================
  1.  ;Prompt for file/subfile
  1.  ;Out:
  1.  ; .ROOT = open root of top level file
  1.  ; .TOP  = top level file #
  1.  ; .FILE = (sub)file #
  1.  ;
  1. SELFILE(ROOT,TOP,FILE) ;
  1.  N %,C,D,DA,DDA,DI,DIAC,DIC,DICS,DIFILE,X,Y
  1.  S (ROOT,TOP,FILE)=""
  1.  D D^DICRW Q:Y<0
  1.  ;
  1.  ;Check if this is a new file
  1.  I '$D(DIC) D  Q:'$D(DIC)
  1.  . N DG,DIE,DIK,DLAYGO,F,Z
  1.  . D DIE^DIB
  1.  . S:$D(DG) DIC=DG
  1.  ;
  1.  ;Check that file exists
  1.  S DI=+$P($G(@(DIC_"0)")),U,2)
  1.  I 'DI W $C(7),!,$$EZBLD^DIALOG(410,DIC_"0)"),! Q
  1.  ;
  1.  ;Get subfile, root, and top
  1.  S FILE=$$SUB^DIKCU(DI) Q:FILE=""
  1.  S ROOT=DIC,TOP=DI
  1.  Q
  1.  ;
  1.  ;==============
  1.  ; $$SUB(File#)
  1.  ;==============
  1.  ;Prompt for subfiles under file
  1.  ;Returns: file or subfile #
  1.  ;         null : if user ^-out
  1.  ;
  1. SUB(FIL) ;
  1.  N D,DIC,DTOUT,DUOUT,QUIT,X,Y
  1.  ;
  1.  S DIC(0)="QEAI"
  1.  S DIC("A")="Select Subfile: "
  1.  S DIC("S")="N % S %=+$P(^(0),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'[""W"""
  1.  ;
  1.  F  Q:$O(^DD(+$G(FIL),"SB",0))'>0!$D(QUIT)  D
  1.  . S DIC="^DD("_FIL_","
  1.  . D ^DIC
  1.  . I X="" S QUIT=1 Q
  1.  . I Y=-1 S QUIT=1 S FIL="" Q
  1.  . S FIL=+$P(^DD(FIL,+Y,0),U,2)
  1.  . W "  (Subfile #"_FIL_")"
  1.  Q FIL
  1.  ;
  1.  ;#401  File #|FILE| does not exist.
  1.  ;#402  The global root of file #|FILE| is missing or not valid.
  1.  ;#404  The File Header node of the file stored at |1| lacks a file number.
  1.  ;#410  Missing or incomplete global node |1|.
  1.  ;#502  Field# |FIELD| in file# |FILE| has a corrupted definition.