DIKCU1 ;SFISC/MKO-FILE/RECORD INFO ;11:21 AM 20 Aug 1999
;;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.
;
;===================
; $$VDA([.]DA,Flag)
;===================
;Make sure elements DA array are positive canonic numbers.
;In:
; [.]DA = DA array
; F [ R : DA can't be 0 or null
; [ D : generate Dialog
;Returns: 1 if valid; 0 if invalid
;
VDA(DA,F) ;
N I,ERR
Q:$D(DA)[0 0
I $G(F)["R" D:0[DA
. S ERR=1 D:$G(F)["D" ERR^DIKCU2(202,"","","","RECORD")
I DA]"",DA<0!(DA'=+$P(DA,"E")) D
. S ERR=1 D:$G(F)["D" ERR^DIKCU2(202,"","","","RECORD")
E F I=1:1 Q:'$D(DA(I)) I DA(I)'>0!(DA(I)'=+$P(DA(I),"E")) D Q
. S ERR=1 D:$G(F)["D" ERR^DIKCU2(202,"","","","RECORD")
Q '$G(ERR)
;
;====================================
; $$VFLAG(InputFlags,GoodFlags,Flag)
;====================================
;Makes sure Flags contain only Good Flags.
;In:
; FLAG = flags
; GDFLAG = good flags
; F [ D : generate Dialog
;Returns: 1 if valid; 0 if invalid
;
VFLAG(FLAG,GDFLAG,F) ;
S FLAG=$G(FLAG)
I $TR($G(FLAG),$G(GDFLAG),"")'?.NP D Q 0
. D:$G(F)["D" ERR^DIKCU2(301,"","","",FLAG)
Q 1
;
;=====================
; $$VFNUM(File#,Flag)
;=====================
;Check that File# exists and has a non-wp .01 field
;In:
; FIL = File or subfile #
; F [ D : generate Dialog
;Returns: 1 if valid; 0 if invalid
;
VFNUM(FIL,F) ;
Q:$G(FIL)="" 0
I '$D(^DD(FIL)) D:$G(F)["D" ERR^DIKCU2(401,FIL) Q 0
I $P($G(^DD(FIL,.01,0)),U,2)="" D:$G(F)["D" ERR^DIKCU2(406,FIL) Q 0
I $P(^DD(FIL,.01,0),U,2)["W" D:$G(F)["D" ERR^DIKCU2(407,FIL) Q 0
Q 1
;
;===========================
; $$VFLD(File#,Field#,Flag)
;===========================
;Check that the Fil/Fld exists in the ^DD
;In:
; FIL = File or subfile #
; FLD = Field #
; F [ D : generate Dialog
;Returns: 1 if valid; 0 if invalid
;
VFLD(FIL,FLD,F) ;
Q:$G(FIL)="" 0 Q:$G(FLD)="" 0
I '$D(^DD(FIL,FLD)) D:$G(F)["D" ERR^DIKCU2(501,FIL,"",FLD,FLD) Q 0
Q 1
;
;================================================
; FRNAME(File#,[.]Rec,FileText,RecordTxt,.Level)
;================================================
;Return string that identifies (sub)file and (sub)record.
;In:
; FIL = File or subfile #
; .REC = DA array
;Out:
; .FTXT = Text that identifies file
; .RTXT = Text that identifies record
; .LEV = Level
;
FRNAME(FIL,REC,FTXT,RTXT,LEV) ;
K FTXT,RTXT,LEV
Q:'$G(FIL) Q:'$D(REC)
N FINFO
D FINFO(FIL,.FINFO) Q:'$D(FINFO)
D FILENAME("",.FTXT,.FINFO)
D RECNAME("",REC,.RTXT,.FINFO)
S LEV=FINFO
Q
;
;=================================
; FILENAME(File#,.NameArr,.FINFO)
;=================================
;Get text that identifies the (sub)file
;In:
; FIL = File or subfile #
;In/Out:
; .FINFO = File info array (optional) (see FINFO below)
;Out:
; N = Text (undefined if error)
; N(n) = Overflow text
;
FILENAME(FIL,N,FINFO) ;
K N
I '$D(FINFO) Q:'$G(FIL) D FINFO(FIL,.FINFO) Q:'$D(FINFO)
N I,L,T
;
S L=FINFO,N=0,N(0)=""
F I=L:-1:0 D
. I I S T=$P(FINFO(I),U,3)_" (#"_$P(FINFO(I),U)_"), subfield #"_$P(FINFO(I),U,2)_" of "
. E S T=$S(L:"the ",1:"")_$P(FINFO(I),U,3)_" File (#"_$P(FINFO(I),U)_")"
. I $L(N(N))+$L(T)>240 S N=N+1,N(N)=""
. S N(N)=N(N)_T
S N=N(0) K N(0)
Q
;
;========================================
; RECNAME(File#,.Record,.NameArr,.FINFO)
;========================================
;Get text that identifies the (sub)recird
;In:
; FIL = File or subfile #
; [.]REC = DA array or IENS
;In/Out:
; .FINFO = File info array (optional) (see FINFO below)
;Out:
; NA = Text (undefined if error)
; NA(n) = Overflow text
;
RECNAME(FIL,REC,NA,FINFO) ;Return string that identifies the (sub)record
K NA
Q:'$G(REC)
I '$D(FINFO) Q:'$G(FIL) D FINFO(FIL,.FINFO) Q:'$D(FINFO)
;
N DA,DIERR,ERR,J,LV,LVI,MSG,NDA,ROOT,TX,V01
;
;Set DA array
I REC'["," M DA=REC
E D DA^DILF(REC,.DA)
;
S LV=FINFO,NA=0,NA(0)=""
F LVI=LV:-1:0 D Q:$G(ERR)
. I LVI,$G(DA(LVI))'>0 S ERR=1 Q
. I 'LVI,$G(DA)'>0 S ERR=1 Q
. ;
. I '$D(DDS) D Q:$G(ERR)
.. S ROOT=$P(FINFO(LVI),U,4,999)
.. S V01=$P($G(@ROOT@(0)),U) I V01="" S ERR=1 Q
.. S TX=$$EXTERNAL^DILFD($P(FINFO(LVI),U),.01,"",V01,"MSG")
.. I $G(DIERR) S TX=V01 K MSG,DIERR
. ;
. E D
.. F J=LVI:-1:1 S NDA(J)=DA(J+LV-LVI)
.. S NDA=$S(LVI=LV:DA,1:DA(LV-LVI))
.. S TX=$$GET^DDSVAL($P(FINFO(LVI),U),.NDA,.01,"","E") K NDA
. ;
. I LV-LVI S TX="'"_TX_"' (#"_DA(LV-LVI)_")"
. E S TX="'"_TX_"' (#"_DA_")"
. I LVI S TX=TX_" of "
. I $L(NA(NA))+$L(TX)>240 S NA=NA+1,NA(NA)=""
. S NA(NA)=NA(NA)_TX
;
I $G(ERR) K NA Q
S NA=NA(0) K NA(0)
Q
;
;========================
; FINFO(File#,.FileInfo)
;========================
;Get (sub)file info
;In:
; FIL = File or subfile #
;Out:
; FINFO = n (level)
; FINFO(0) = file#^^fileName^fileRootw/DA
; FINFO(n) = subfile#^mfield#^mfieldName^^subfileRootw/DA
;Example:
; FINFO = 3
; FINFO(0) = 1000^^My File^^DIZ(1000,DA(3))
; FINFO(1) = 1000.01^100^Mult1^^DIZ(1000,DA(3),10,DA(2))
; FINFO(2) = 1000.02^200^Mult2^^DIZ(1000,DA(3),10,DA(2),20,DA(1))
; FINFO(3) = 1000.03^300^Mult3^^DIZ(1000,DA(3),10,DA(2),20,DA(1),30,DA)
;
FINFO(FIL,FINFO) ;
Q:'$G(FIL)
K FINFO
;
;If top level, set FINFO and quit
I $D(^DIC(FIL,0,"GL"))#2 D Q
. S FINFO=0,FINFO(0)=FIL_U_U_$P(^DIC(FIL,0),U)_U_^DIC(FIL,0,"GL")_"DA)"
;
;Must be a subfile level, get mult nodes, and level
N A,ERR,I,L,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,"")) I 'MFLD S ERR=1 Q
. I $D(^DD(PAR,MFLD,0))[0 S ERR=1 Q
. S FINFO(L)=SUB_U_MFLD_U_$P(^DD(PAR,MFLD,0),U)
. ;
. S ND=$P($P(^DD(PAR,MFLD,0),U,4),";")
. S:ND'=+$P(ND,"E") ND=""""_ND_""""
. S ND(L+1)=ND
. S SUB=PAR
I $G(ERR) K FINFO,L Q
S FIL=SUB
I $D(^DIC(FIL,0))[0 K FINFO,L Q
S FINFO(L)=FIL_U_U_$P(^DIC(FIL,0),U)
;
;Build global roots
S ROOT=$G(^DIC(FIL,0,"GL")) I ROOT="" K FINFO,L Q
F I=L:-1:1 D
. S ROOT=ROOT_"DA("_I_")"
. S FINFO(I)=FINFO(I)_U_ROOT_")"
. S ROOT=ROOT_","_ND(I)_","
S FINFO(0)=FINFO(0)_U_ROOT_"DA)"
S FINFO=L
;
;Invert the FINFO array
K A M A=FINFO K FINFO S FINFO=A F A=0:1:FINFO S FINFO(A)=A(FINFO-A)
Q
;
;#202 The input parameter that identifies the |1| is missing or invalid.
;#301 The passed flag(s) '|1|' are unknown or inconsistent.
;#401 File #|FILE| does not exist.
;#406 File #|FILE| has no .01 field definition.
;#407 A word-processing field is not a file.
;#501 File #|FILE| does not contain a field |1|.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCU1 6932 printed Dec 13, 2024@02:48:51 Page 2
DIKCU1 ;SFISC/MKO-FILE/RECORD INFO ;11:21 AM 20 Aug 1999
+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 ; $$VDA([.]DA,Flag)
+9 ;===================
+10 ;Make sure elements DA array are positive canonic numbers.
+11 ;In:
+12 ; [.]DA = DA array
+13 ; F [ R : DA can't be 0 or null
+14 ; [ D : generate Dialog
+15 ;Returns: 1 if valid; 0 if invalid
+16 ;
VDA(DA,F) ;
+1 NEW I,ERR
+2 if $DATA(DA)[0
QUIT 0
+3 IF $GET(F)["R"
if 0[DA
Begin DoDot:1
+4 SET ERR=1
if $GET(F)["D"
DO ERR^DIKCU2(202,"","","","RECORD")
End DoDot:1
+5 IF DA]""
IF DA<0!(DA'=+$PIECE(DA,"E"))
Begin DoDot:1
+6 SET ERR=1
if $GET(F)["D"
DO ERR^DIKCU2(202,"","","","RECORD")
End DoDot:1
+7 IF '$TEST
FOR I=1:1
if '$DATA(DA(I))
QUIT
IF DA(I)'>0!(DA(I)'=+$PIECE(DA(I),"E"))
Begin DoDot:1
+8 SET ERR=1
if $GET(F)["D"
DO ERR^DIKCU2(202,"","","","RECORD")
End DoDot:1
QUIT
+9 QUIT '$GET(ERR)
+10 ;
+11 ;====================================
+12 ; $$VFLAG(InputFlags,GoodFlags,Flag)
+13 ;====================================
+14 ;Makes sure Flags contain only Good Flags.
+15 ;In:
+16 ; FLAG = flags
+17 ; GDFLAG = good flags
+18 ; F [ D : generate Dialog
+19 ;Returns: 1 if valid; 0 if invalid
+20 ;
VFLAG(FLAG,GDFLAG,F) ;
+1 SET FLAG=$GET(FLAG)
+2 IF $TRANSLATE($GET(FLAG),$GET(GDFLAG),"")'?.NP
Begin DoDot:1
+3 if $GET(F)["D"
DO ERR^DIKCU2(301,"","","",FLAG)
End DoDot:1
QUIT 0
+4 QUIT 1
+5 ;
+6 ;=====================
+7 ; $$VFNUM(File#,Flag)
+8 ;=====================
+9 ;Check that File# exists and has a non-wp .01 field
+10 ;In:
+11 ; FIL = File or subfile #
+12 ; F [ D : generate Dialog
+13 ;Returns: 1 if valid; 0 if invalid
+14 ;
VFNUM(FIL,F) ;
+1 if $GET(FIL)=""
QUIT 0
+2 IF '$DATA(^DD(FIL))
if $GET(F)["D"
DO ERR^DIKCU2(401,FIL)
QUIT 0
+3 IF $PIECE($GET(^DD(FIL,.01,0)),U,2)=""
if $GET(F)["D"
DO ERR^DIKCU2(406,FIL)
QUIT 0
+4 IF $PIECE(^DD(FIL,.01,0),U,2)["W"
if $GET(F)["D"
DO ERR^DIKCU2(407,FIL)
QUIT 0
+5 QUIT 1
+6 ;
+7 ;===========================
+8 ; $$VFLD(File#,Field#,Flag)
+9 ;===========================
+10 ;Check that the Fil/Fld exists in the ^DD
+11 ;In:
+12 ; FIL = File or subfile #
+13 ; FLD = Field #
+14 ; F [ D : generate Dialog
+15 ;Returns: 1 if valid; 0 if invalid
+16 ;
VFLD(FIL,FLD,F) ;
+1 if $GET(FIL)=""
QUIT 0
if $GET(FLD)=""
QUIT 0
+2 IF '$DATA(^DD(FIL,FLD))
if $GET(F)["D"
DO ERR^DIKCU2(501,FIL,"",FLD,FLD)
QUIT 0
+3 QUIT 1
+4 ;
+5 ;================================================
+6 ; FRNAME(File#,[.]Rec,FileText,RecordTxt,.Level)
+7 ;================================================
+8 ;Return string that identifies (sub)file and (sub)record.
+9 ;In:
+10 ; FIL = File or subfile #
+11 ; .REC = DA array
+12 ;Out:
+13 ; .FTXT = Text that identifies file
+14 ; .RTXT = Text that identifies record
+15 ; .LEV = Level
+16 ;
FRNAME(FIL,REC,FTXT,RTXT,LEV) ;
+1 KILL FTXT,RTXT,LEV
+2 if '$GET(FIL)
QUIT
if '$DATA(REC)
QUIT
+3 NEW FINFO
+4 DO FINFO(FIL,.FINFO)
if '$DATA(FINFO)
QUIT
+5 DO FILENAME("",.FTXT,.FINFO)
+6 DO RECNAME("",REC,.RTXT,.FINFO)
+7 SET LEV=FINFO
+8 QUIT
+9 ;
+10 ;=================================
+11 ; FILENAME(File#,.NameArr,.FINFO)
+12 ;=================================
+13 ;Get text that identifies the (sub)file
+14 ;In:
+15 ; FIL = File or subfile #
+16 ;In/Out:
+17 ; .FINFO = File info array (optional) (see FINFO below)
+18 ;Out:
+19 ; N = Text (undefined if error)
+20 ; N(n) = Overflow text
+21 ;
FILENAME(FIL,N,FINFO) ;
+1 KILL N
+2 IF '$DATA(FINFO)
if '$GET(FIL)
QUIT
DO FINFO(FIL,.FINFO)
if '$DATA(FINFO)
QUIT
+3 NEW I,L,T
+4 ;
+5 SET L=FINFO
SET N=0
SET N(0)=""
+6 FOR I=L:-1:0
Begin DoDot:1
+7 IF I
SET T=$PIECE(FINFO(I),U,3)_" (#"_$PIECE(FINFO(I),U)_"), subfield #"_$PIECE(FINFO(I),U,2)_" of "
+8 IF '$TEST
SET T=$SELECT(L:"the ",1:"")_$PIECE(FINFO(I),U,3)_" File (#"_$PIECE(FINFO(I),U)_")"
+9 IF $LENGTH(N(N))+$LENGTH(T)>240
SET N=N+1
SET N(N)=""
+10 SET N(N)=N(N)_T
End DoDot:1
+11 SET N=N(0)
KILL N(0)
+12 QUIT
+13 ;
+14 ;========================================
+15 ; RECNAME(File#,.Record,.NameArr,.FINFO)
+16 ;========================================
+17 ;Get text that identifies the (sub)recird
+18 ;In:
+19 ; FIL = File or subfile #
+20 ; [.]REC = DA array or IENS
+21 ;In/Out:
+22 ; .FINFO = File info array (optional) (see FINFO below)
+23 ;Out:
+24 ; NA = Text (undefined if error)
+25 ; NA(n) = Overflow text
+26 ;
RECNAME(FIL,REC,NA,FINFO) ;Return string that identifies the (sub)record
+1 KILL NA
+2 if '$GET(REC)
QUIT
+3 IF '$DATA(FINFO)
if '$GET(FIL)
QUIT
DO FINFO(FIL,.FINFO)
if '$DATA(FINFO)
QUIT
+4 ;
+5 NEW DA,DIERR,ERR,J,LV,LVI,MSG,NDA,ROOT,TX,V01
+6 ;
+7 ;Set DA array
+8 IF REC'[","
MERGE DA=REC
+9 IF '$TEST
DO DA^DILF(REC,.DA)
+10 ;
+11 SET LV=FINFO
SET NA=0
SET NA(0)=""
+12 FOR LVI=LV:-1:0
Begin DoDot:1
+13 IF LVI
IF $GET(DA(LVI))'>0
SET ERR=1
QUIT
+14 IF 'LVI
IF $GET(DA)'>0
SET ERR=1
QUIT
+15 ;
+16 IF '$DATA(DDS)
Begin DoDot:2
+17 SET ROOT=$PIECE(FINFO(LVI),U,4,999)
+18 SET V01=$PIECE($GET(@ROOT@(0)),U)
IF V01=""
SET ERR=1
QUIT
+19 SET TX=$$EXTERNAL^DILFD($PIECE(FINFO(LVI),U),.01,"",V01,"MSG")
+20 IF $GET(DIERR)
SET TX=V01
KILL MSG,DIERR
End DoDot:2
if $GET(ERR)
QUIT
+21 ;
+22 IF '$TEST
Begin DoDot:2
+23 FOR J=LVI:-1:1
SET NDA(J)=DA(J+LV-LVI)
+24 SET NDA=$SELECT(LVI=LV:DA,1:DA(LV-LVI))
+25 SET TX=$$GET^DDSVAL($PIECE(FINFO(LVI),U),.NDA,.01,"","E")
KILL NDA
End DoDot:2
+26 ;
+27 IF LV-LVI
SET TX="'"_TX_"' (#"_DA(LV-LVI)_")"
+28 IF '$TEST
SET TX="'"_TX_"' (#"_DA_")"
+29 IF LVI
SET TX=TX_" of "
+30 IF $LENGTH(NA(NA))+$LENGTH(TX)>240
SET NA=NA+1
SET NA(NA)=""
+31 SET NA(NA)=NA(NA)_TX
End DoDot:1
if $GET(ERR)
QUIT
+32 ;
+33 IF $GET(ERR)
KILL NA
QUIT
+34 SET NA=NA(0)
KILL NA(0)
+35 QUIT
+36 ;
+37 ;========================
+38 ; FINFO(File#,.FileInfo)
+39 ;========================
+40 ;Get (sub)file info
+41 ;In:
+42 ; FIL = File or subfile #
+43 ;Out:
+44 ; FINFO = n (level)
+45 ; FINFO(0) = file#^^fileName^fileRootw/DA
+46 ; FINFO(n) = subfile#^mfield#^mfieldName^^subfileRootw/DA
+47 ;Example:
+48 ; FINFO = 3
+49 ; FINFO(0) = 1000^^My File^^DIZ(1000,DA(3))
+50 ; FINFO(1) = 1000.01^100^Mult1^^DIZ(1000,DA(3),10,DA(2))
+51 ; FINFO(2) = 1000.02^200^Mult2^^DIZ(1000,DA(3),10,DA(2),20,DA(1))
+52 ; FINFO(3) = 1000.03^300^Mult3^^DIZ(1000,DA(3),10,DA(2),20,DA(1),30,DA)
+53 ;
FINFO(FIL,FINFO) ;
+1 if '$GET(FIL)
QUIT
+2 KILL FINFO
+3 ;
+4 ;If top level, set FINFO and quit
+5 IF $DATA(^DIC(FIL,0,"GL"))#2
Begin DoDot:1
+6 SET FINFO=0
SET FINFO(0)=FIL_U_U_$PIECE(^DIC(FIL,0),U)_U_^DIC(FIL,0,"GL")_"DA)"
End DoDot:1
QUIT
+7 ;
+8 ;Must be a subfile level, get mult nodes, and level
+9 NEW A,ERR,I,L,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,""))
IF 'MFLD
SET ERR=1
QUIT
+13 IF $DATA(^DD(PAR,MFLD,0))[0
SET ERR=1
QUIT
+14 SET FINFO(L)=SUB_U_MFLD_U_$PIECE(^DD(PAR,MFLD,0),U)
+15 ;
+16 SET ND=$PIECE($PIECE(^DD(PAR,MFLD,0),U,4),";")
+17 if ND'=+$PIECE(ND,"E")
SET ND=""""_ND_""""
+18 SET ND(L+1)=ND
+19 SET SUB=PAR
End DoDot:1
if $GET(ERR)
QUIT
+20 IF $GET(ERR)
KILL FINFO,L
QUIT
+21 SET FIL=SUB
+22 IF $DATA(^DIC(FIL,0))[0
KILL FINFO,L
QUIT
+23 SET FINFO(L)=FIL_U_U_$PIECE(^DIC(FIL,0),U)
+24 ;
+25 ;Build global roots
+26 SET ROOT=$GET(^DIC(FIL,0,"GL"))
IF ROOT=""
KILL FINFO,L
QUIT
+27 FOR I=L:-1:1
Begin DoDot:1
+28 SET ROOT=ROOT_"DA("_I_")"
+29 SET FINFO(I)=FINFO(I)_U_ROOT_")"
+30 SET ROOT=ROOT_","_ND(I)_","
End DoDot:1
+31 SET FINFO(0)=FINFO(0)_U_ROOT_"DA)"
+32 SET FINFO=L
+33 ;
+34 ;Invert the FINFO array
+35 KILL A
MERGE A=FINFO
KILL FINFO
SET FINFO=A
FOR A=0:1:FINFO
SET FINFO(A)=A(FINFO-A)
+36 QUIT
+37 ;
+38 ;#202 The input parameter that identifies the |1| is missing or invalid.
+39 ;#301 The passed flag(s) '|1|' are unknown or inconsistent.
+40 ;#401 File #|FILE| does not exist.
+41 ;#406 File #|FILE| has no .01 field definition.
+42 ;#407 A word-processing field is not a file.
+43 ;#501 File #|FILE| does not contain a field |1|.
