DIKK1 ;SFISC/MKO-CHECK KEY INTEGRITY ;9:19 AM 5 Feb 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.
;
;========================
; LOADALL(File,Flag,.MF)
;========================
;Load info about all keys on a file. Use the "B" xref on the Key file.
;In:
; KFIL = File # [.31,.01]
; FLAG [ "s" : don't include subfile under file
;Out:
; ^TMP("DIKK",$J,keyFile#,file#) = levDif(keyfile,file) (if > 0)
; ^openRootDA
; ... file#,field#) = S X=$P($G(...),U,n)
; or S X=$E($G(...),m,n)
;
; ^TMP("DIKK",$J,"UI",file[.01],ui#) = key#
; ^TMP("DIKK",$J,"UIR",rFile[.51],ui#) = key#
;
; MF(file#,mField#) = multiple node
; MF(file#,mField#,0) = subfile#
;
LOADALL(KFIL,FLAG,MF) ;
N FLD,KEY,ROOT
;
;Get info for all keys on this file
S KEY=0
F S KEY=$O(^DD("KEY","B",KFIL,KEY)) Q:'KEY D LOADKEY(KEY,.ROOT)
Q:$G(FLAG)["s"
;
;Make a recursive call to get subfiles under KFIL
N CHK,FIL,MFLD,PAR,SB
D SUBFILES^DIKCU(KFIL,.SB,.MF)
S SB=0 F S SB=$O(SB(SB)) Q:'SB D
. D LOADALL(SB,"s") Q:'$D(^TMP("DIKK",$J,SB))
. ;
. ;Set CHK(subfile)="" 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
;
;=====================
; LOADFLD(File,Field)
;=====================
;Load info for all keys of which a field is a part.
;
LOADFLD(FIL,FLD) ;
N KEY
S KEY=0 F S KEY=$O(^DD("KEY","F",FIL,FLD,KEY)) Q:'KEY D LOADKEY(KEY)
Q
;
;===================
; LOADKEY(Key,Root)
;===================
;Load info about a key.
;In:
; KEY = Key #
; .OROOT = Open root of File of Key [.31,.01] (optional) (also output)
;Out:
; .OROOT = Open root of File of Key [.31,.01]
; ^TMP (see LOADALL above)
;
LOADKEY(KEY,OROOT) ;
N DEC,FIL,FLD,FLDN,KFIL,LDIF,UI,UIFIL,UIRFIL
;
;Get key data
S KFIL=$P($G(^DD("KEY",KEY,0)),U),UI=$P($G(^(0)),U,4) Q:'KFIL!'UI
;
;Get info about UI
S UIFIL=$P($G(^DD("IX",UI,0)),U),UIRFIL=$P(^(0),U,9) Q:'UIFIL!'UIRFIL
Q:$D(^TMP("DIKK",$J,"UI",UIFIL,UI)) S ^(UI)=KEY
S ^TMP("DIKK",$J,"UIR",UIRFIL,UI)=KEY
;
;Get root of file [.31,.01]
I $G(OROOT)="" S OROOT=$$FROOTDA^DIKCU(KFIL,"O")_"DA," Q:OROOT="DA,"
;
;Loop through fields in key; get data extraction code
S FLDN=0 F S FLDN=$O(^DD("KEY",KEY,2,FLDN)) Q:'FLDN D
. Q:'$D(^DD("KEY",KEY,2,FLDN,0)) S FLD=$P(^(0),U),FIL=$P(^(0),U,2)
. Q:'FLD!'FIL Q:$D(^TMP("DIKK",$J,KFIL,FIL,FLD))#2
. ;
. I FIL'=KFIL N OROOT D Q:$G(OROOT)=""
.. I $D(^TMP("DIKK",$J,KFIL,FIL))#2 S LDIF=+^(FIL),OROOT=U_$P(^(FIL),U,2,999)
.. E D
... S LDIF=$$FLEVDIFF^DIKCU(FIL,KFIL) Q:'LDIF
... S OROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O") Q:OROOT=""
... S OROOT=OROOT_"DA("_LDIF_"),"
... S ^TMP("DIKK",$J,KFIL,FIL)=LDIF_OROOT
. ;
. S DEC=$$DEC(FIL,FLD,OROOT) Q:DEC=""
. S ^TMP("DIKK",$J,KFIL,FIL,FLD)=DEC
;
Q
;
;==============================
; $$DEC(File#,Field#,OpenRoot)
;==============================
;Return code that sets X=data from file; examples:
; S X=$P($G(^DIZ(1000,DA(2),"m1",DA(1),"m2",DA,0)),U,3)
; S X=$E($G(^DIZ(1000,DA(2),"m1",DA(1),"m2",DA,0)),1,245)
;In:
; FIL = File #
; FLD = Field #
; OROOT = Open root of record (with DA strings) (optional)
;
DEC(FIL,FLD,OROOT) ;Get data extraction code
N ND,PC
S PC=$P($G(^DD(FIL,FLD,0)),U,4)
S ND=$P(PC,";"),PC=$P(PC,";",2) Q:ND?." " "" Q:"0 "[PC ""
S:ND'=+$P(ND,"E") ND=""""_ND_""""
;
I $G(OROOT)="" S OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA," Q:OROOT="DA," ""
I PC Q "S X=$P($G("_OROOT_ND_")),U,"_PC_")"
E Q "S X=$E($G("_OROOT_ND_")),"_+$E(PC,2,999)_","_$P(PC,",",2)_")"
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKK1 4166 printed Nov 22, 2024@17:58:57 Page 2
DIKK1 ;SFISC/MKO-CHECK KEY INTEGRITY ;9:19 AM 5 Feb 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 ; LOADALL(File,Flag,.MF)
+9 ;========================
+10 ;Load info about all keys on a file. Use the "B" xref on the Key file.
+11 ;In:
+12 ; KFIL = File # [.31,.01]
+13 ; FLAG [ "s" : don't include subfile under file
+14 ;Out:
+15 ; ^TMP("DIKK",$J,keyFile#,file#) = levDif(keyfile,file) (if > 0)
+16 ; ^openRootDA
+17 ; ... file#,field#) = S X=$P($G(...),U,n)
+18 ; or S X=$E($G(...),m,n)
+19 ;
+20 ; ^TMP("DIKK",$J,"UI",file[.01],ui#) = key#
+21 ; ^TMP("DIKK",$J,"UIR",rFile[.51],ui#) = key#
+22 ;
+23 ; MF(file#,mField#) = multiple node
+24 ; MF(file#,mField#,0) = subfile#
+25 ;
LOADALL(KFIL,FLAG,MF) ;
+1 NEW FLD,KEY,ROOT
+2 ;
+3 ;Get info for all keys on this file
+4 SET KEY=0
+5 FOR
SET KEY=$ORDER(^DD("KEY","B",KFIL,KEY))
if 'KEY
QUIT
DO LOADKEY(KEY,.ROOT)
+6 if $GET(FLAG)["s"
QUIT
+7 ;
+8 ;Make a recursive call to get subfiles under KFIL
+9 NEW CHK,FIL,MFLD,PAR,SB
+10 DO SUBFILES^DIKCU(KFIL,.SB,.MF)
+11 SET SB=0
FOR
SET SB=$ORDER(SB(SB))
if 'SB
QUIT
Begin DoDot:1
+12 DO LOADALL(SB,"s")
if '$DATA(^TMP("DIKK",$JOB,SB))
QUIT
+13 ;
+14 ;Set CHK(subfile)="" for subfile and its antecedents
+15 SET PAR=SB
FOR
if $DATA(CHK(PAR))
QUIT
SET CHK(PAR)=1
SET PAR=$GET(SB(PAR))
if PAR=""
QUIT
End DoDot:1
+16 ;
+17 ;Use the CHK array to get rid of unneeded elements in MF
+18 SET FIL=0
FOR
SET FIL=$ORDER(MF(FIL))
if 'FIL
QUIT
Begin DoDot:1
+19 SET MFLD=0
FOR
SET MFLD=$ORDER(MF(FIL,MFLD))
if 'MFLD
QUIT
Begin DoDot:2
+20 if '$DATA(CHK(MF(FIL,MFLD,0)))
KILL MF(FIL,MFLD)
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
+23 ;=====================
+24 ; LOADFLD(File,Field)
+25 ;=====================
+26 ;Load info for all keys of which a field is a part.
+27 ;
LOADFLD(FIL,FLD) ;
+1 NEW KEY
+2 SET KEY=0
FOR
SET KEY=$ORDER(^DD("KEY","F",FIL,FLD,KEY))
if 'KEY
QUIT
DO LOADKEY(KEY)
+3 QUIT
+4 ;
+5 ;===================
+6 ; LOADKEY(Key,Root)
+7 ;===================
+8 ;Load info about a key.
+9 ;In:
+10 ; KEY = Key #
+11 ; .OROOT = Open root of File of Key [.31,.01] (optional) (also output)
+12 ;Out:
+13 ; .OROOT = Open root of File of Key [.31,.01]
+14 ; ^TMP (see LOADALL above)
+15 ;
LOADKEY(KEY,OROOT) ;
+1 NEW DEC,FIL,FLD,FLDN,KFIL,LDIF,UI,UIFIL,UIRFIL
+2 ;
+3 ;Get key data
+4 SET KFIL=$PIECE($GET(^DD("KEY",KEY,0)),U)
SET UI=$PIECE($GET(^(0)),U,4)
if 'KFIL!'UI
QUIT
+5 ;
+6 ;Get info about UI
+7 SET UIFIL=$PIECE($GET(^DD("IX",UI,0)),U)
SET UIRFIL=$PIECE(^(0),U,9)
if 'UIFIL!'UIRFIL
QUIT
+8 if $DATA(^TMP("DIKK",$JOB,"UI",UIFIL,UI))
QUIT
SET ^(UI)=KEY
+9 SET ^TMP("DIKK",$JOB,"UIR",UIRFIL,UI)=KEY
+10 ;
+11 ;Get root of file [.31,.01]
+12 IF $GET(OROOT)=""
SET OROOT=$$FROOTDA^DIKCU(KFIL,"O")_"DA,"
if OROOT="DA,"
QUIT
+13 ;
+14 ;Loop through fields in key; get data extraction code
+15 SET FLDN=0
FOR
SET FLDN=$ORDER(^DD("KEY",KEY,2,FLDN))
if 'FLDN
QUIT
Begin DoDot:1
+16 if '$DATA(^DD("KEY",KEY,2,FLDN,0))
QUIT
SET FLD=$PIECE(^(0),U)
SET FIL=$PIECE(^(0),U,2)
+17 if 'FLD!'FIL
QUIT
if $DATA(^TMP("DIKK",$JOB,KFIL,FIL,FLD))#2
QUIT
+18 ;
+19 IF FIL'=KFIL
NEW OROOT
Begin DoDot:2
+20 IF $DATA(^TMP("DIKK",$JOB,KFIL,FIL))#2
SET LDIF=+^(FIL)
SET OROOT=U_$PIECE(^(FIL),U,2,999)
+21 IF '$TEST
Begin DoDot:3
+22 SET LDIF=$$FLEVDIFF^DIKCU(FIL,KFIL)
if 'LDIF
QUIT
+23 SET OROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O")
if OROOT=""
QUIT
+24 SET OROOT=OROOT_"DA("_LDIF_"),"
+25 SET ^TMP("DIKK",$JOB,KFIL,FIL)=LDIF_OROOT
End DoDot:3
End DoDot:2
if $GET(OROOT)=""
QUIT
+26 ;
+27 SET DEC=$$DEC(FIL,FLD,OROOT)
if DEC=""
QUIT
+28 SET ^TMP("DIKK",$JOB,KFIL,FIL,FLD)=DEC
End DoDot:1
+29 ;
+30 QUIT
+31 ;
+32 ;==============================
+33 ; $$DEC(File#,Field#,OpenRoot)
+34 ;==============================
+35 ;Return code that sets X=data from file; examples:
+36 ; S X=$P($G(^DIZ(1000,DA(2),"m1",DA(1),"m2",DA,0)),U,3)
+37 ; S X=$E($G(^DIZ(1000,DA(2),"m1",DA(1),"m2",DA,0)),1,245)
+38 ;In:
+39 ; FIL = File #
+40 ; FLD = Field #
+41 ; OROOT = Open root of record (with DA strings) (optional)
+42 ;
DEC(FIL,FLD,OROOT) ;Get data extraction code
+1 NEW ND,PC
+2 SET PC=$PIECE($GET(^DD(FIL,FLD,0)),U,4)
+3 SET ND=$PIECE(PC,";")
SET PC=$PIECE(PC,";",2)
if ND?." "
QUIT ""
if "0 "[PC
QUIT ""
+4 if ND'=+$PIECE(ND,"E")
SET ND=""""_ND_""""
+5 ;
+6 IF $GET(OROOT)=""
SET OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA,"
if OROOT="DA,"
QUIT ""
+7 IF PC
QUIT "S X=$P($G("_OROOT_ND_")),U,"_PC_")"
+8 IF '$TEST
QUIT "S X=$E($G("_OROOT_ND_")),"_+$EXTRACT(PC,2,999)_","_$PIECE(PC,",",2)_")"
+9 ;
