DIKC1 ;SFISC/MKO-LOAD XREF INFO ;19DEC2010
;;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.
;
;============================================
; LOADALL(File,Log,Activ,ValRt,Tmp,Flag,.MF)
;============================================
;Load all xrefs for a file. Uses the "AC" index on Root File.
;In:
; RFIL = Root File #
; LOG [ K : load kill logic
; [ S : load set logic
; ACT = Codes: IR
; If ACT '= null, a xref is picked up only if ACT
; and the Activity field (#.41) have codes in common.
; VALRT = Array Ref where old/new values are located
; TMP = Root to store xref info
; FLAG [ s : don't include subfiles under file
; [ i : don't load index-type xrefs (only load whole file xrefs)
; [ f : don't load field-type xrefs
; [ r : don't load record-type xrefs
; [ x : don't load "NOREINDEX" xrefs
;
;Out:
; MF(file#,mField#) = multiple node
; MF(file#,mField#,0) = subfile#
; Set only for those files/multiples that have xrefs
; and only if FLAG '[ "s"
;
LOADALL(RFIL,LOG,ACT,VALRT,TMP,FLAG,MF) ;
N XR
;
;Loop through "AC" index
S XR=0 F S XR=$O(^DD("IX","AC",RFIL,XR)) Q:'XR D
. ;Skip if no .01, wrong Activity, wrong Type, or wrong Execution
. I $P($G(^DD("IX",XR,0)),U)="" K ^DD("IX","AC",RFIL,XR) Q
. I $G(ACT)]"",$TR(ACT,$P(^DD("IX",XR,0),U,7),$TR($J("",$L($P(^(0),U,7)))," ","*"))'["*" Q
. I $G(FLAG)["i",$P(^DD("IX",XR,0),U,8)="I" Q
. I $G(FLAG)["f",$P(^DD("IX",XR,0),U,6)="F" Q
. I $G(FLAG)["r",$P(^DD("IX",XR,0),U,6)="R" Q
NOREIN .I $G(FLAG)["x",$G(^DD("IX",XR,"NOREINDEX")) Q ;PATCH 167
. ;
. ;Load xref
. D CRV^DIKC2(XR,$G(VALRT),TMP)
. D:$G(LOG)]"" LOG^DIKC2(XR,LOG,TMP)
. D:$G(LOG)["K" KW^DIKC2(XR,TMP)
Q:$G(FLAG)["s"
;
;Build info for all subfiles under FILE into arrays SB and MF
N CHK,FIL,MFLD,PAR,SB
D SUBFILES^DIKCU(RFIL,.SB,.MF)
;
;Load xref for each subfile
S:$G(FLAG)'["s" FLAG=$G(FLAG)_"s"
S SB=0 F S SB=$O(SB(SB)) Q:'SB D
. D LOADALL(SB,$G(LOG),$G(ACT),$G(VALRT),TMP,FLAG)
. Q:'$D(@TMP@(SB))
. ;
. ;Set CHK(f)="" flag for subfile and its antecedents
. S PAR=SB F Q:$D(CHK(PAR)) S CHK(PAR)=1,PAR=$G(SB(PAR)) Q:PAR=""
;
;Use the CHK array to get rid of unneeded elements in MF
S FIL=0 F S FIL=$O(MF(FIL)) Q:'FIL D
. S MFLD=0 F S MFLD=$O(MF(FIL,MFLD)) Q:'MFLD D
.. K:'$D(CHK(MF(FIL,MFLD,0))) MF(FIL,MFLD)
Q
;
;========================================
; LOADXREF(File,Fld,Log,.XRef,ValRt,Tmp)
;========================================
;Load specified xrefs. Uses the "AC" index on Root file if Index
;Names are passed in. Also, uses the "F" index, if Field is passed in.
;In:
; RFIL = if FLD is not passed in : Root File or subfile#
; (required if XREF contains names)
; if FLD is passed in : The file of the field
; (defaults to Root file of XREF)
; FLD = Field # (optional) (if passed in, a specified index is
; loaded only if FLD is one of the cross-reference values.
; LOG [ K : load kill logic (incl. whole kill)
; [ S : load set logic
; .XREF = ^-delimited list of xref names or numbers;
; (overflow in XREF(n) where n=1,2,...)
; VALRT = Array Ref where old/new values are located
; TMP = Root to store info
;
LOADXREF(RFIL,FLD,LOG,XREF,VALRT,TMP) ;
N I,N,PC,RF,XR,XRLIST
;
;Loop through XREF array
S N=0,XRLIST=$G(XREF) F Q:XRLIST="" D
. ;
. ;Loop through each xref in XRLIST
. F PC=1:1:$L(XRLIST,U) K XR S XR=$P(XRLIST,U,PC) D:XR]""
.. ;
.. ;Convert xref name to number, if necessary
.. I XR'=+$P(XR,"E") D Q:$D(XR)<2
... S I=0 F S I=$O(^DD("IX","AC",RFIL,I)) Q:'I D
.... S:$P($G(^DD("IX",I,0)),U,2)=XR XR(I)=""
.. E Q:$P($G(^DD("IX",XR,0)),U)="" S XR(XR)=""
.. ;
.. ;Load code from Cross-Reference Values multiple
.. S XR=0 F S XR=$O(XR(XR)) Q:'XR D
... S RF=$P(^DD("IX",XR,0),U,9)
... I $G(FLD) Q:'$D(^DD("IX","F",$S($G(RFIL):RFIL,1:RF),FLD,XR))
... E I $G(RFIL) Q:RFIL'=RF
... D CRV^DIKC2(XR,$G(VALRT),TMP)
... D:$G(LOG)]"" LOG^DIKC2(XR,LOG,TMP)
... D:$G(LOG)["K" KW^DIKC2(XR,TMP)
. ;
. ;Process next overflow
. S N=$O(XREF(N)),XRLIST=$S(N:$G(XREF(N)),1:"")
Q
;
;================================================================
; LOADFLD(File,Field,Log,Activ,ValRt,TmpF,TmpR,FList,RList,Flag)
;================================================================
;Get all xrefs for a field. Uses the "F" index on file/field.
;In:
; FIL = File #
; FLD = Field #
; LOG [ K : load kill logic
; [ S : load set logic
; [ W : load entire kill logic (if LOG also [ "K")
; ACT = codes: IR
; If ACT is not null, a xref is picked up only if ACT
; and the Activity field (#.41) have codes in common.
; VALRT = Array Ref where old/new values are located
; TMPF = Root to store field-level xref info
; TMPR = Root to store record-level xref info
; FLAG [ i : don't load index-type xrefs (only load whole file xrefs)
; [ f : don't load field-type xrefs
; [ r : don't load record-type xrefs
;Out:
; .FLIST = ^-delimited list of field xrefs (overflow in FLIST(n))
; .RLIST = ^-delimited list of record xrefs (overflow in RLIST(n))
;
LOADFLD(FIL,FLD,LOG,ACT,VALRT,TMPF,TMPR,FLIST,RLIST,FLAG) ;
N EXECFLD,TMP,XR
K FLIST,RLIST S (FLIST,RLIST)=0,(FLIST(0),RLIST(0))=""
S:$G(TMPR)="" TMPR=TMPF
;
;Loop through "F" index and pick up xrefs
S XR=0 F S XR=$O(^DD("IX","F",FIL,FLD,XR)) Q:'XR D
. I $P($G(^DD("IX",XR,0)),U)="" K ^DD("IX","F",FIL,FLD,XR) Q
. S EXECFLD=$P(^DD("IX",XR,0),U,6)
. I $G(ACT)]"",$TR(ACT,$P(^DD("IX",XR,0),U,7),$TR($J("",$L($P(^(0),U,7)))," ","*"))'["*" Q
. I $G(FLAG)["i",$P(^DD("IX",XR,0),U,8)="I" Q
. I $G(FLAG)["f",$P(^DD("IX",XR,0),U,6)="F" Q
. I $G(FLAG)["r",$P(^DD("IX",XR,0),U,6)="R" Q
. I $G(FLAG)["x",$G(^DD("IX",XR,"NOREINDEX")) Q
. ;
. ;Set TMP, RLIST, and FLIST
. K TMP
. I EXECFLD="R" D
.. S TMP=$G(TMPR)
.. I $L(RLIST(RLIST))+$L(XR)+1>255 S RLIST=RLIST+1,RLIST(RLIST)=""
.. S RLIST(RLIST)=RLIST(RLIST)_$E(U,RLIST(RLIST)]"")_XR
. E D
.. S TMP=$G(TMPF)
.. I $L(FLIST(FLIST))+$L(XR)+1>255 S FLIST=FLIST+1,FLIST(FLIST)=""
.. S FLIST(FLIST)=FLIST(FLIST)_$E(U,FLIST(FLIST)]"")_XR
. ;
. ;Load xref
. Q:$G(TMP)="" Q:$D(@TMP@(FIL,XR))
. D CRV^DIKC2(XR,$G(VALRT),TMP)
. D:$G(LOG)]"" LOG^DIKC2(XR,LOG,TMP)
. I $G(LOG)["K",$G(LOG)["W" D KW^DIKC2(XR,TMP)
;
I FLIST(0)]"" S FLIST=FLIST(0) K FLIST(0)
E K FLIST S FLIST=""
I RLIST(0)]"" S RLIST=RLIST(0) K RLIST(0)
E K RLIST S RLIST=""
Q
;
GETTMP(DIKC) ;Find next available root in ^TMP(DIKC)
;Time stamp ^TMP(DIKC,J)
;Out:
; Name of available ^TMP root; e.g. ^TMP("DIKC",$J+.01)
;
N DAY,FREE,J
S FREE=0 F J=$J:.01 D Q:FREE
. S DAY=$G(^TMP(DIKC,J))
. I DAY<($H-1) K ^TMP(DIKC,J) S ^TMP(DIKC,J)=$H,FREE=1
Q $NA(^TMP(DIKC,J))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKC1 7273 printed Sep 23, 2025@20:24:47 Page 2
DIKC1 ;SFISC/MKO-LOAD XREF INFO ;19DEC2010
+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 ; LOADALL(File,Log,Activ,ValRt,Tmp,Flag,.MF)
+9 ;============================================
+10 ;Load all xrefs for a file. Uses the "AC" index on Root File.
+11 ;In:
+12 ; RFIL = Root File #
+13 ; LOG [ K : load kill logic
+14 ; [ S : load set logic
+15 ; ACT = Codes: IR
+16 ; If ACT '= null, a xref is picked up only if ACT
+17 ; and the Activity field (#.41) have codes in common.
+18 ; VALRT = Array Ref where old/new values are located
+19 ; TMP = Root to store xref info
+20 ; FLAG [ s : don't include subfiles under file
+21 ; [ i : don't load index-type xrefs (only load whole file xrefs)
+22 ; [ f : don't load field-type xrefs
+23 ; [ r : don't load record-type xrefs
+24 ; [ x : don't load "NOREINDEX" xrefs
+25 ;
+26 ;Out:
+27 ; MF(file#,mField#) = multiple node
+28 ; MF(file#,mField#,0) = subfile#
+29 ; Set only for those files/multiples that have xrefs
+30 ; and only if FLAG '[ "s"
+31 ;
LOADALL(RFIL,LOG,ACT,VALRT,TMP,FLAG,MF) ;
+1 NEW XR
+2 ;
+3 ;Loop through "AC" index
+4 SET XR=0
FOR
SET XR=$ORDER(^DD("IX","AC",RFIL,XR))
if 'XR
QUIT
Begin DoDot:1
+5 ;Skip if no .01, wrong Activity, wrong Type, or wrong Execution
+6 IF $PIECE($GET(^DD("IX",XR,0)),U)=""
KILL ^DD("IX","AC",RFIL,XR)
QUIT
+7 IF $GET(ACT)]""
IF $TRANSLATE(ACT,$PIECE(^DD("IX",XR,0),U,7),$TRANSLATE($JUSTIFY("",$LENGTH($PIECE(^(0),U,7)))," ","*"))'["*"
QUIT
+8 IF $GET(FLAG)["i"
IF $PIECE(^DD("IX",XR,0),U,8)="I"
QUIT
+9 IF $GET(FLAG)["f"
IF $PIECE(^DD("IX",XR,0),U,6)="F"
QUIT
+10 IF $GET(FLAG)["r"
IF $PIECE(^DD("IX",XR,0),U,6)="R"
QUIT
NOREIN ;PATCH 167
IF $GET(FLAG)["x"
IF $GET(^DD("IX",XR,"NOREINDEX"))
QUIT
+1 ;
+2 ;Load xref
+3 DO CRV^DIKC2(XR,$GET(VALRT),TMP)
+4 if $GET(LOG)]""
DO LOG^DIKC2(XR,LOG,TMP)
+5 if $GET(LOG)["K"
DO KW^DIKC2(XR,TMP)
End DoDot:1
+6 if $GET(FLAG)["s"
QUIT
+7 ;
+8 ;Build info for all subfiles under FILE into arrays SB and MF
+9 NEW CHK,FIL,MFLD,PAR,SB
+10 DO SUBFILES^DIKCU(RFIL,.SB,.MF)
+11 ;
+12 ;Load xref for each subfile
+13 if $GET(FLAG)'["s"
SET FLAG=$GET(FLAG)_"s"
+14 SET SB=0
FOR
SET SB=$ORDER(SB(SB))
if 'SB
QUIT
Begin DoDot:1
+15 DO LOADALL(SB,$GET(LOG),$GET(ACT),$GET(VALRT),TMP,FLAG)
+16 if '$DATA(@TMP@(SB))
QUIT
+17 ;
+18 ;Set CHK(f)="" flag for subfile and its antecedents
+19 SET PAR=SB
FOR
if $DATA(CHK(PAR))
QUIT
SET CHK(PAR)=1
SET PAR=$GET(SB(PAR))
if PAR=""
QUIT
End DoDot:1
+20 ;
+21 ;Use the CHK array to get rid of unneeded elements in MF
+22 SET FIL=0
FOR
SET FIL=$ORDER(MF(FIL))
if 'FIL
QUIT
Begin DoDot:1
+23 SET MFLD=0
FOR
SET MFLD=$ORDER(MF(FIL,MFLD))
if 'MFLD
QUIT
Begin DoDot:2
+24 if '$DATA(CHK(MF(FIL,MFLD,0)))
KILL MF(FIL,MFLD)
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
+27 ;========================================
+28 ; LOADXREF(File,Fld,Log,.XRef,ValRt,Tmp)
+29 ;========================================
+30 ;Load specified xrefs. Uses the "AC" index on Root file if Index
+31 ;Names are passed in. Also, uses the "F" index, if Field is passed in.
+32 ;In:
+33 ; RFIL = if FLD is not passed in : Root File or subfile#
+34 ; (required if XREF contains names)
+35 ; if FLD is passed in : The file of the field
+36 ; (defaults to Root file of XREF)
+37 ; FLD = Field # (optional) (if passed in, a specified index is
+38 ; loaded only if FLD is one of the cross-reference values.
+39 ; LOG [ K : load kill logic (incl. whole kill)
+40 ; [ S : load set logic
+41 ; .XREF = ^-delimited list of xref names or numbers;
+42 ; (overflow in XREF(n) where n=1,2,...)
+43 ; VALRT = Array Ref where old/new values are located
+44 ; TMP = Root to store info
+45 ;
LOADXREF(RFIL,FLD,LOG,XREF,VALRT,TMP) ;
+1 NEW I,N,PC,RF,XR,XRLIST
+2 ;
+3 ;Loop through XREF array
+4 SET N=0
SET XRLIST=$GET(XREF)
FOR
if XRLIST=""
QUIT
Begin DoDot:1
+5 ;
+6 ;Loop through each xref in XRLIST
+7 FOR PC=1:1:$LENGTH(XRLIST,U)
KILL XR
SET XR=$PIECE(XRLIST,U,PC)
if XR]""
Begin DoDot:2
+8 ;
+9 ;Convert xref name to number, if necessary
+10 IF XR'=+$PIECE(XR,"E")
Begin DoDot:3
+11 SET I=0
FOR
SET I=$ORDER(^DD("IX","AC",RFIL,I))
if 'I
QUIT
Begin DoDot:4
+12 if $PIECE($GET(^DD("IX",I,0)),U,2)=XR
SET XR(I)=""
End DoDot:4
End DoDot:3
if $DATA(XR)<2
QUIT
+13 IF '$TEST
if $PIECE($GET(^DD("IX",XR,0)),U)=""
QUIT
SET XR(XR)=""
+14 ;
+15 ;Load code from Cross-Reference Values multiple
+16 SET XR=0
FOR
SET XR=$ORDER(XR(XR))
if 'XR
QUIT
Begin DoDot:3
+17 SET RF=$PIECE(^DD("IX",XR,0),U,9)
+18 IF $GET(FLD)
if '$DATA(^DD("IX","F",$SELECT($GET(RFIL)
QUIT
+19 IF '$TEST
IF $GET(RFIL)
if RFIL'=RF
QUIT
+20 DO CRV^DIKC2(XR,$GET(VALRT),TMP)
+21 if $GET(LOG)]""
DO LOG^DIKC2(XR,LOG,TMP)
+22 if $GET(LOG)["K"
DO KW^DIKC2(XR,TMP)
End DoDot:3
End DoDot:2
+23 ;
+24 ;Process next overflow
+25 SET N=$ORDER(XREF(N))
SET XRLIST=$SELECT(N:$GET(XREF(N)),1:"")
End DoDot:1
+26 QUIT
+27 ;
+28 ;================================================================
+29 ; LOADFLD(File,Field,Log,Activ,ValRt,TmpF,TmpR,FList,RList,Flag)
+30 ;================================================================
+31 ;Get all xrefs for a field. Uses the "F" index on file/field.
+32 ;In:
+33 ; FIL = File #
+34 ; FLD = Field #
+35 ; LOG [ K : load kill logic
+36 ; [ S : load set logic
+37 ; [ W : load entire kill logic (if LOG also [ "K")
+38 ; ACT = codes: IR
+39 ; If ACT is not null, a xref is picked up only if ACT
+40 ; and the Activity field (#.41) have codes in common.
+41 ; VALRT = Array Ref where old/new values are located
+42 ; TMPF = Root to store field-level xref info
+43 ; TMPR = Root to store record-level xref info
+44 ; FLAG [ i : don't load index-type xrefs (only load whole file xrefs)
+45 ; [ f : don't load field-type xrefs
+46 ; [ r : don't load record-type xrefs
+47 ;Out:
+48 ; .FLIST = ^-delimited list of field xrefs (overflow in FLIST(n))
+49 ; .RLIST = ^-delimited list of record xrefs (overflow in RLIST(n))
+50 ;
LOADFLD(FIL,FLD,LOG,ACT,VALRT,TMPF,TMPR,FLIST,RLIST,FLAG) ;
+1 NEW EXECFLD,TMP,XR
+2 KILL FLIST,RLIST
SET (FLIST,RLIST)=0
SET (FLIST(0),RLIST(0))=""
+3 if $GET(TMPR)=""
SET TMPR=TMPF
+4 ;
+5 ;Loop through "F" index and pick up xrefs
+6 SET XR=0
FOR
SET XR=$ORDER(^DD("IX","F",FIL,FLD,XR))
if 'XR
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^DD("IX",XR,0)),U)=""
KILL ^DD("IX","F",FIL,FLD,XR)
QUIT
+8 SET EXECFLD=$PIECE(^DD("IX",XR,0),U,6)
+9 IF $GET(ACT)]""
IF $TRANSLATE(ACT,$PIECE(^DD("IX",XR,0),U,7),$TRANSLATE($JUSTIFY("",$LENGTH($PIECE(^(0),U,7)))," ","*"))'["*"
QUIT
+10 IF $GET(FLAG)["i"
IF $PIECE(^DD("IX",XR,0),U,8)="I"
QUIT
+11 IF $GET(FLAG)["f"
IF $PIECE(^DD("IX",XR,0),U,6)="F"
QUIT
+12 IF $GET(FLAG)["r"
IF $PIECE(^DD("IX",XR,0),U,6)="R"
QUIT
+13 IF $GET(FLAG)["x"
IF $GET(^DD("IX",XR,"NOREINDEX"))
QUIT
+14 ;
+15 ;Set TMP, RLIST, and FLIST
+16 KILL TMP
+17 IF EXECFLD="R"
Begin DoDot:2
+18 SET TMP=$GET(TMPR)
+19 IF $LENGTH(RLIST(RLIST))+$LENGTH(XR)+1>255
SET RLIST=RLIST+1
SET RLIST(RLIST)=""
+20 SET RLIST(RLIST)=RLIST(RLIST)_$EXTRACT(U,RLIST(RLIST)]"")_XR
End DoDot:2
+21 IF '$TEST
Begin DoDot:2
+22 SET TMP=$GET(TMPF)
+23 IF $LENGTH(FLIST(FLIST))+$LENGTH(XR)+1>255
SET FLIST=FLIST+1
SET FLIST(FLIST)=""
+24 SET FLIST(FLIST)=FLIST(FLIST)_$EXTRACT(U,FLIST(FLIST)]"")_XR
End DoDot:2
+25 ;
+26 ;Load xref
+27 if $GET(TMP)=""
QUIT
if $DATA(@TMP@(FIL,XR))
QUIT
+28 DO CRV^DIKC2(XR,$GET(VALRT),TMP)
+29 if $GET(LOG)]""
DO LOG^DIKC2(XR,LOG,TMP)
+30 IF $GET(LOG)["K"
IF $GET(LOG)["W"
DO KW^DIKC2(XR,TMP)
End DoDot:1
+31 ;
+32 IF FLIST(0)]""
SET FLIST=FLIST(0)
KILL FLIST(0)
+33 IF '$TEST
KILL FLIST
SET FLIST=""
+34 IF RLIST(0)]""
SET RLIST=RLIST(0)
KILL RLIST(0)
+35 IF '$TEST
KILL RLIST
SET RLIST=""
+36 QUIT
+37 ;
GETTMP(DIKC) ;Find next available root in ^TMP(DIKC)
+1 ;Time stamp ^TMP(DIKC,J)
+2 ;Out:
+3 ; Name of available ^TMP root; e.g. ^TMP("DIKC",$J+.01)
+4 ;
+5 NEW DAY,FREE,J
+6 SET FREE=0
FOR J=$JOB:.01
Begin DoDot:1
+7 SET DAY=$GET(^TMP(DIKC,J))
+8 IF DAY<($HOROLOG-1)
KILL ^TMP(DIKC,J)
SET ^TMP(DIKC,J)=$HOROLOG
SET FREE=1
End DoDot:1
if FREE
QUIT
+9 QUIT $NAME(^TMP(DIKC,J))
