DIKCU ;SFISC/MKO-LIBRARY OF GENERIC MODULES ;9:29 AM 22 Oct 1998
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
;===============
; PUSHDA(.DA,N)
;===============
;Push down the DA array, N times
;
PUSHDA(DA,N) ;
N I
S:'$G(N) N=1
F I=+$O(DA(""),-1):-1:1 S DA(I+N)=$G(DA(I))
S DA(N)=$G(DA)
S DA=0 F I=N-1:-1:1 S DA(I)=0
Q
;
;==============
; POPDA(.DA,N)
;==============
;Pop the DA array
;
POPDA(DA,N) ;
N I,L
S:'$G(N) N=1
S L=+$O(DA(""),-1)
S DA=$G(DA(N))
F I=N+1:1:L S DA(I-N)=$G(DA(I))
F I=L-N+1:1:L K DA(I)
Q
;
;=================
; $$IENS(File,DA)
;=================
;Return IENS given file# and DA array
;In:
; FIL = File or subfile #
; DA = DA array (any unneeded elements in the DA array are ignored)
;
IENS(FIL,DA) ;
N LEV,I,IENS,ERR
Q:$G(FIL)="" ""
S LEV=$$FLEV(FIL) Q:LEV="" ""
;
;Build IENS
S IENS=$G(DA)_","
F I=1:1:LEV S IENS=IENS_$G(DA(I))_","
Q IENS
;
;=========================
; $$FNUM(Root,Flag)
;=========================
;Given file root, return File # from 2nd piece of header node.
;Also check that that file has a DD entry and a non-wp .01 field.
;Return null if error.
;In:
; ROOT = file root
; F [ D : generate dialog
;
FNUM(ROOT,F) ;
Q:$G(ROOT)="" ""
N FIL
S ROOT=$$CREF(ROOT)
I $D(@ROOT@(0))[0 D:$G(F)["D" ERR^DIKCU2(404,"","","",ROOT) Q ""
S FIL=+$P(@ROOT@(0),U,2)
I '$$VFNUM^DIKCU1(FIL,$G(F)) Q ""
Q FIL
;
;===============================
; $$FROOTDA(File,Flag,.L,.TRoot
;===============================
;Return global root of File; may include DA(1), DA(2), ... for subfiles
;Examples: ^DIZ(9999) and ^DIZ(9999,DA(1),"MULT1")
;In:
; FIL = file #
; FLAG [ O : return open root
; [ D : generate dialog
; starts with number : indicates offset to use for DA array
;Out:
; .L = level of file
; .TROOT = top level root
;
FROOTDA(FIL,F,L,TROOT) ;
I $G(FIL)="" S (L,TROOT)="" Q ""
S F=$G(F)
;
;If top level, return "GL"
I $D(^DIC(FIL,0,"GL"))#2 D Q TROOT
. S L=0,TROOT=$S(F["O":^("GL"),1:$$CREF(^("GL")))
;
;Must be a subfile level, get mult nodes, and level
N ERR,I,MFLD,ND,PAR,ROOT,SUB
S SUB=FIL
F L=0:1 S PAR=$G(^DD(SUB,0,"UP")) Q:'PAR D Q:$G(ERR)
. S MFLD=$O(^DD(PAR,"SB",SUB,""))
. S ND=$P($P($G(^DD(PAR,MFLD,0)),U,4),";")
. I ND?." " S ERR=1 D:F["D" ERR^DIKCU2(502,PAR,"",MFLD) Q
. S:ND'=+$P(ND,"E") ND=""""_ND_""""
. S ND(L+1)=ND
. S SUB=PAR
I $G(ERR) S (L,TROOT)="" Q ""
;
;Build global root for subfile
S (ROOT,TROOT)=$G(^DIC(SUB,0,"GL"))
I ROOT="" D:F["D" ERR^DIKCU2(402,SUB) S L="" Q ""
;
F I=L:-1:1 S ROOT=ROOT_"DA("_(I+F)_"),"_ND(I)_","
S:F'["O" TROOT=$$CREF(TROOT)
Q $S(F["O":ROOT,1:$$CREF(ROOT))
;
CREF(X) ;Return closed root of X
N F,L
S L=$E(X,$L(X)),F=$E(X,1,$L(X)-1)
Q $S(L="(":F,L=",":F_")",1:X)
;
;================
; $$FLEV(File,F)
;================
;Return the level of File
;In:
; FIL = file#
; F [ "D" : generate Dialog
;
FLEV(FIL,F) ;
Q:$G(FIL)="" ""
;
N LEV
F LEV=0:1 Q:$G(^DD(FIL,0,"UP"))="" S FIL=^("UP")
I '$D(^DD(FIL)) D:$G(F)["D" ERR^DIKCU2(402,FIL) Q ""
Q LEV
;
;=========================
; $$FLEVDIFF(File1,File2)
;=========================
;Find the difference in levels between File1 and File2.
;File1 is an ancestor of File2.
;In:
; FIL1 = File or subfile # of ancestor
; FIL2 = File or subfile #
;Returns: level difference; null if invalid input
;
FLEVDIFF(FIL1,FIL2) ;
Q:$G(FIL1)=""!($G(FIL2)="") ""
;
N DIFF,FIL
S FIL=FIL2
F DIFF=0:1 Q:FIL=FIL1 S FIL=$G(^DD(FIL,0,"UP")) Q:FIL=""
Q $S(FIL=FIL1:DIFF,1:"")
;
;===============================================
; SUBFILES(File,.Subfile#Array,.NodeArray,Flag)
;===============================================
;Build list of subfiles
;In:
; FIL = file #
; FLG = 1 (if wp subfiles should be returned)
;Out:
; .SB(subfile#) = parentFile#
; .MF(file#,multField#) = node
; .MF(file#,multField#,0) = subfile#
;
SUBFILES(FIL,SB,MF,FLG) ;
Q:$G(FIL)=""
N SUB,MUL,ND
;
;Loop through "SB" nodes
S SUB="" F S SUB=$O(^DD(FIL,"SB",SUB)) Q:'SUB D
. S MUL=$O(^DD(FIL,"SB",SUB,0)) Q:'MUL
. Q:$D(^DD(SUB,.01,0))[0 Q:$P(^(0),U,2)["W"&'$G(FLG)
. ;
. S ND=$P($P(^DD(FIL,MUL,0),U,4),";") Q:ND=""
. S SB(SUB)=FIL,MF(FIL,MUL)=ND,MF(FIL,MUL,0)=SUB
. ;
. ;Make a recursive call to get all subfiles under file SUB
. D SUBFILES(SUB,.SB,.MF,$G(FLG))
Q
;
;============================
; SBINFO(Subfile,.NodeArray)
;============================
;Get info for Subfile
;In:
; SUB = subfile #
;Out:
; .MF(file#,multField#) = node
; .MF(file#,multField#,0) = subfile#
;
SBINFO(SUB,MF) ;
N ERR,MUL,ND,PAR
F S PAR=$G(^DD(SUB,0,"UP")) Q:'PAR D Q:$G(ERR)
. S MUL=$O(^DD(PAR,"SB",SUB,0)) I 'MUL S ERR=1 Q
. S ND=$P($P(^DD(PAR,MUL,0),U,4),";") I ND="" S ERR=1 Q
. S MF(PAR,MUL)=ND,MF(PAR,MUL,0)=SUB,SUB=PAR
Q
;
;============================
; SELFILE(Root,TopFile,File)
;============================
;Prompt for file/subfile
;Out:
; .ROOT = open root of top level file
; .TOP = top level file #
; .FILE = (sub)file #
;
SELFILE(ROOT,TOP,FILE) ;
N %,C,D,DA,DDA,DI,DIAC,DIC,DICS,DIFILE,X,Y
S (ROOT,TOP,FILE)=""
D D^DICRW Q:Y<0
;
;Check if this is a new file
I '$D(DIC) D Q:'$D(DIC)
. N DG,DIE,DIK,DLAYGO,F,Z
. D DIE^DIB
. S:$D(DG) DIC=DG
;
;Check that file exists
S DI=+$P($G(@(DIC_"0)")),U,2)
I 'DI W $C(7),!,$$EZBLD^DIALOG(410,DIC_"0)"),! Q
;
;Get subfile, root, and top
S FILE=$$SUB^DIKCU(DI) Q:FILE=""
S ROOT=DIC,TOP=DI
Q
;
;==============
; $$SUB(File#)
;==============
;Prompt for subfiles under file
;Returns: file or subfile #
; null : if user ^-out
;
SUB(FIL) ;
N D,DIC,DTOUT,DUOUT,QUIT,X,Y
;
S DIC(0)="QEAI"
S DIC("A")="Select Subfile: "
S DIC("S")="N % S %=+$P(^(0),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'[""W"""
;
F Q:$O(^DD(+$G(FIL),"SB",0))'>0!$D(QUIT) D
. S DIC="^DD("_FIL_","
. D ^DIC
. I X="" S QUIT=1 Q
. I Y=-1 S QUIT=1 S FIL="" Q
. S FIL=+$P(^DD(FIL,+Y,0),U,2)
. W " (Subfile #"_FIL_")"
Q FIL
;
;#401 File #|FILE| does not exist.
;#402 The global root of file #|FILE| is missing or not valid.
;#404 The File Header node of the file stored at |1| lacks a file number.
;#410 Missing or incomplete global node |1|.
;#502 Field# |FIELD| in file# |FILE| has a corrupted definition.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCU 6774 printed Nov 22, 2024@17:58:45 Page 2
DIKCU ;SFISC/MKO-LIBRARY OF GENERIC MODULES ;9:29 AM 22 Oct 1998
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 ;===============
+8 ; PUSHDA(.DA,N)
+9 ;===============
+10 ;Push down the DA array, N times
+11 ;
PUSHDA(DA,N) ;
+1 NEW I
+2 if '$GET(N)
SET N=1
+3 FOR I=+$ORDER(DA(""),-1):-1:1
SET DA(I+N)=$GET(DA(I))
+4 SET DA(N)=$GET(DA)
+5 SET DA=0
FOR I=N-1:-1:1
SET DA(I)=0
+6 QUIT
+7 ;
+8 ;==============
+9 ; POPDA(.DA,N)
+10 ;==============
+11 ;Pop the DA array
+12 ;
POPDA(DA,N) ;
+1 NEW I,L
+2 if '$GET(N)
SET N=1
+3 SET L=+$ORDER(DA(""),-1)
+4 SET DA=$GET(DA(N))
+5 FOR I=N+1:1:L
SET DA(I-N)=$GET(DA(I))
+6 FOR I=L-N+1:1:L
KILL DA(I)
+7 QUIT
+8 ;
+9 ;=================
+10 ; $$IENS(File,DA)
+11 ;=================
+12 ;Return IENS given file# and DA array
+13 ;In:
+14 ; FIL = File or subfile #
+15 ; DA = DA array (any unneeded elements in the DA array are ignored)
+16 ;
IENS(FIL,DA) ;
+1 NEW LEV,I,IENS,ERR
+2 if $GET(FIL)=""
QUIT ""
+3 SET LEV=$$FLEV(FIL)
if LEV=""
QUIT ""
+4 ;
+5 ;Build IENS
+6 SET IENS=$GET(DA)_","
+7 FOR I=1:1:LEV
SET IENS=IENS_$GET(DA(I))_","
+8 QUIT IENS
+9 ;
+10 ;=========================
+11 ; $$FNUM(Root,Flag)
+12 ;=========================
+13 ;Given file root, return File # from 2nd piece of header node.
+14 ;Also check that that file has a DD entry and a non-wp .01 field.
+15 ;Return null if error.
+16 ;In:
+17 ; ROOT = file root
+18 ; F [ D : generate dialog
+19 ;
FNUM(ROOT,F) ;
+1 if $GET(ROOT)=""
QUIT ""
+2 NEW FIL
+3 SET ROOT=$$CREF(ROOT)
+4 IF $DATA(@ROOT@(0))[0
if $GET(F)["D"
DO ERR^DIKCU2(404,"","","",ROOT)
QUIT ""
+5 SET FIL=+$PIECE(@ROOT@(0),U,2)
+6 IF '$$VFNUM^DIKCU1(FIL,$GET(F))
QUIT ""
+7 QUIT FIL
+8 ;
+9 ;===============================
+10 ; $$FROOTDA(File,Flag,.L,.TRoot
+11 ;===============================
+12 ;Return global root of File; may include DA(1), DA(2), ... for subfiles
+13 ;Examples: ^DIZ(9999) and ^DIZ(9999,DA(1),"MULT1")
+14 ;In:
+15 ; FIL = file #
+16 ; FLAG [ O : return open root
+17 ; [ D : generate dialog
+18 ; starts with number : indicates offset to use for DA array
+19 ;Out:
+20 ; .L = level of file
+21 ; .TROOT = top level root
+22 ;
FROOTDA(FIL,F,L,TROOT) ;
+1 IF $GET(FIL)=""
SET (L,TROOT)=""
QUIT ""
+2 SET F=$GET(F)
+3 ;
+4 ;If top level, return "GL"
+5 IF $DATA(^DIC(FIL,0,"GL"))#2
Begin DoDot:1
+6 SET L=0
SET TROOT=$SELECT(F["O":^("GL"),1:$$CREF(^("GL")))
End DoDot:1
QUIT TROOT
+7 ;
+8 ;Must be a subfile level, get mult nodes, and level
+9 NEW ERR,I,MFLD,ND,PAR,ROOT,SUB
+10 SET SUB=FIL
+11 FOR L=0:1
SET PAR=$GET(^DD(SUB,0,"UP"))
if 'PAR
QUIT
Begin DoDot:1
+12 SET MFLD=$ORDER(^DD(PAR,"SB",SUB,""))
+13 SET ND=$PIECE($PIECE($GET(^DD(PAR,MFLD,0)),U,4),";")
+14 IF ND?." "
SET ERR=1
if F["D"
DO ERR^DIKCU2(502,PAR,"",MFLD)
QUIT
+15 if ND'=+$PIECE(ND,"E")
SET ND=""""_ND_""""
+16 SET ND(L+1)=ND
+17 SET SUB=PAR
End DoDot:1
if $GET(ERR)
QUIT
+18 IF $GET(ERR)
SET (L,TROOT)=""
QUIT ""
+19 ;
+20 ;Build global root for subfile
+21 SET (ROOT,TROOT)=$GET(^DIC(SUB,0,"GL"))
+22 IF ROOT=""
if F["D"
DO ERR^DIKCU2(402,SUB)
SET L=""
QUIT ""
+23 ;
+24 FOR I=L:-1:1
SET ROOT=ROOT_"DA("_(I+F)_"),"_ND(I)_","
+25 if F'["O"
SET TROOT=$$CREF(TROOT)
+26 QUIT $SELECT(F["O":ROOT,1:$$CREF(ROOT))
+27 ;
CREF(X) ;Return closed root of X
+1 NEW F,L
+2 SET L=$EXTRACT(X,$LENGTH(X))
SET F=$EXTRACT(X,1,$LENGTH(X)-1)
+3 QUIT $SELECT(L="(":F,L=",":F_")",1:X)
+4 ;
+5 ;================
+6 ; $$FLEV(File,F)
+7 ;================
+8 ;Return the level of File
+9 ;In:
+10 ; FIL = file#
+11 ; F [ "D" : generate Dialog
+12 ;
FLEV(FIL,F) ;
+1 if $GET(FIL)=""
QUIT ""
+2 ;
+3 NEW LEV
+4 FOR LEV=0:1
if $GET(^DD(FIL,0,"UP"))=""
QUIT
SET FIL=^("UP")
+5 IF '$DATA(^DD(FIL))
if $GET(F)["D"
DO ERR^DIKCU2(402,FIL)
QUIT ""
+6 QUIT LEV
+7 ;
+8 ;=========================
+9 ; $$FLEVDIFF(File1,File2)
+10 ;=========================
+11 ;Find the difference in levels between File1 and File2.
+12 ;File1 is an ancestor of File2.
+13 ;In:
+14 ; FIL1 = File or subfile # of ancestor
+15 ; FIL2 = File or subfile #
+16 ;Returns: level difference; null if invalid input
+17 ;
FLEVDIFF(FIL1,FIL2) ;
+1 if $GET(FIL1)=""!($GET(FIL2)="")
QUIT ""
+2 ;
+3 NEW DIFF,FIL
+4 SET FIL=FIL2
+5 FOR DIFF=0:1
if FIL=FIL1
QUIT
SET FIL=$GET(^DD(FIL,0,"UP"))
if FIL=""
QUIT
+6 QUIT $SELECT(FIL=FIL1:DIFF,1:"")
+7 ;
+8 ;===============================================
+9 ; SUBFILES(File,.Subfile#Array,.NodeArray,Flag)
+10 ;===============================================
+11 ;Build list of subfiles
+12 ;In:
+13 ; FIL = file #
+14 ; FLG = 1 (if wp subfiles should be returned)
+15 ;Out:
+16 ; .SB(subfile#) = parentFile#
+17 ; .MF(file#,multField#) = node
+18 ; .MF(file#,multField#,0) = subfile#
+19 ;
SUBFILES(FIL,SB,MF,FLG) ;
+1 if $GET(FIL)=""
QUIT
+2 NEW SUB,MUL,ND
+3 ;
+4 ;Loop through "SB" nodes
+5 SET SUB=""
FOR
SET SUB=$ORDER(^DD(FIL,"SB",SUB))
if 'SUB
QUIT
Begin DoDot:1
+6 SET MUL=$ORDER(^DD(FIL,"SB",SUB,0))
if 'MUL
QUIT
+7 if $DATA(^DD(SUB,.01,0))[0
QUIT
if $PIECE(^(0),U,2)["W"&'$GET(FLG)
QUIT
+8 ;
+9 SET ND=$PIECE($PIECE(^DD(FIL,MUL,0),U,4),";")
if ND=""
QUIT
+10 SET SB(SUB)=FIL
SET MF(FIL,MUL)=ND
SET MF(FIL,MUL,0)=SUB
+11 ;
+12 ;Make a recursive call to get all subfiles under file SUB
+13 DO SUBFILES(SUB,.SB,.MF,$GET(FLG))
End DoDot:1
+14 QUIT
+15 ;
+16 ;============================
+17 ; SBINFO(Subfile,.NodeArray)
+18 ;============================
+19 ;Get info for Subfile
+20 ;In:
+21 ; SUB = subfile #
+22 ;Out:
+23 ; .MF(file#,multField#) = node
+24 ; .MF(file#,multField#,0) = subfile#
+25 ;
SBINFO(SUB,MF) ;
+1 NEW ERR,MUL,ND,PAR
+2 FOR
SET PAR=$GET(^DD(SUB,0,"UP"))
if 'PAR
QUIT
Begin DoDot:1
+3 SET MUL=$ORDER(^DD(PAR,"SB",SUB,0))
IF 'MUL
SET ERR=1
QUIT
+4 SET ND=$PIECE($PIECE(^DD(PAR,MUL,0),U,4),";")
IF ND=""
SET ERR=1
QUIT
+5 SET MF(PAR,MUL)=ND
SET MF(PAR,MUL,0)=SUB
SET SUB=PAR
End DoDot:1
if $GET(ERR)
QUIT
+6 QUIT
+7 ;
+8 ;============================
+9 ; SELFILE(Root,TopFile,File)
+10 ;============================
+11 ;Prompt for file/subfile
+12 ;Out:
+13 ; .ROOT = open root of top level file
+14 ; .TOP = top level file #
+15 ; .FILE = (sub)file #
+16 ;
SELFILE(ROOT,TOP,FILE) ;
+1 NEW %,C,D,DA,DDA,DI,DIAC,DIC,DICS,DIFILE,X,Y
+2 SET (ROOT,TOP,FILE)=""
+3 DO D^DICRW
if Y<0
QUIT
+4 ;
+5 ;Check if this is a new file
+6 IF '$DATA(DIC)
Begin DoDot:1
+7 NEW DG,DIE,DIK,DLAYGO,F,Z
+8 DO DIE^DIB
+9 if $DATA(DG)
SET DIC=DG
End DoDot:1
if '$DATA(DIC)
QUIT
+10 ;
+11 ;Check that file exists
+12 SET DI=+$PIECE($GET(@(DIC_"0)")),U,2)
+13 IF 'DI
WRITE $CHAR(7),!,$$EZBLD^DIALOG(410,DIC_"0)"),!
QUIT
+14 ;
+15 ;Get subfile, root, and top
+16 SET FILE=$$SUB^DIKCU(DI)
if FILE=""
QUIT
+17 SET ROOT=DIC
SET TOP=DI
+18 QUIT
+19 ;
+20 ;==============
+21 ; $$SUB(File#)
+22 ;==============
+23 ;Prompt for subfiles under file
+24 ;Returns: file or subfile #
+25 ; null : if user ^-out
+26 ;
SUB(FIL) ;
+1 NEW D,DIC,DTOUT,DUOUT,QUIT,X,Y
+2 ;
+3 SET DIC(0)="QEAI"
+4 SET DIC("A")="Select Subfile: "
+5 SET DIC("S")="N % S %=+$P(^(0),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'[""W"""
+6 ;
+7 FOR
if $ORDER(^DD(+$GET(FIL),"SB",0))'>0!$DATA(QUIT)
QUIT
Begin DoDot:1
+8 SET DIC="^DD("_FIL_","
+9 DO ^DIC
+10 IF X=""
SET QUIT=1
QUIT
+11 IF Y=-1
SET QUIT=1
SET FIL=""
QUIT
+12 SET FIL=+$PIECE(^DD(FIL,+Y,0),U,2)
+13 WRITE " (Subfile #"_FIL_")"
End DoDot:1
+14 QUIT FIL
+15 ;
+16 ;#401 File #|FILE| does not exist.
+17 ;#402 The global root of file #|FILE| is missing or not valid.
+18 ;#404 The File Header node of the file stored at |1| lacks a file number.
+19 ;#410 Missing or incomplete global node |1|.
+20 ;#502 Field# |FIELD| in file# |FILE| has a corrupted definition.
