DIKKUTL3 ;SFISC/MKO-VERIFY KEY INTEGRITY ;3:10 PM 27 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.
;
VERIFY(DIKKEY,DIKKTOP,DIKKFILE) ;Verify key integrity
N DIKKTEMP,POP,%ZIS
;
;Ask whether to save records in a template
S DIKKTEMP=$$ASKTEMP(DIKKTOP)
;
;Select Device
S %ZIS=$S($D(^%ZTSK):"Q",1:"")
W ! D ^%ZIS Q:$G(POP)
K %ZIS,POP
;
;Queue report
I $D(IO("Q")) D Q
. N I,ZTSK
. S ZTRTN="MAIN^DIKKUTL3"
. S ZTDESC="KEY INTEGRITY CHECK"
. F I="DIKKEY","DIKKTOP","DIKKFILE","DIKKTEMP" S ZTSAVE(I)=""
. D ^%ZTLOAD
. I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
. E W !,"Report canceled!",!
. S IOP="HOME" D ^%ZIS
;
U IO
;
MAIN ;Queued tasks enter here
N DIKKHLIN,DIKKFIL,DIKKNAME,DIKKPAGE,DIKKTAB,DIKKUI,DIKKUIFL,DIKKUINM
N DIKKIENS,DIKKFLD,DIKKFNAM,DIKKROOT,DIKKSUPP
K ^TMP("DIKKUTL",$J)
;
;Check key integrity
D INTEG^DIKK(DIKKTOP,"","",DIKKEY,"",1)
I $D(DIERR) D MSG^DIALOG() Q
;
;Initialize "global" variables for report
S DIKKPAGE=0
S %H=$H D YX^%DTC
S DIKKHLIN=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)_" PAGE "
S DIKKTAB(1)=9,DIKKTAB(2)=41
S DIKKNAME=$P($G(^DD("KEY",DIKKEY,0)),U,2)
S DIKKUI=$P($G(^DD("KEY",DIKKEY,0)),U,4)
S DIKKUINM=$P($G(^DD("IX",+DIKKUI,0)),U,2),DIKKUIFL=$P($G(^(0)),U)
;
;Print first header
W:$E(IOST,1,2)="C-" @IOF
D HDR
I '$D(^TMP("DIKKTAR",$J)) W !!," ** NO PROBLEMS **" G END
;
;Loop through target error and list problems
S DIKKFIL=0
F S DIKKFIL=$O(^TMP("DIKKTAR",$J,DIKKFIL)) Q:'DIKKFIL!$D(DIRUT) D
. D COLHDR
. S DIKKROOT=$$FROOTDA^DIKCU(DIKKFIL)
. S DIKKIENS=" "
. F S DIKKIENS=$O(^TMP("DIKKTAR",$J,DIKKFIL,DIKKIENS)) Q:DIKKIENS=""!$D(DIRUT) D
.. D:$D(^TMP("DIKKTAR",$J,DIKKFIL,DIKKIENS,"K",DIKKEY)) KEYERR(DIKKFIL,DIKKIENS,DIKKEY,DIKKROOT)
.. S (DIKKSUPP,DIKKFLD)=0
.. F S DIKKFLD=$O(^TMP("DIKKTAR",$J,DIKKFIL,DIKKIENS,DIKKFLD)) Q:'DIKKFLD!$D(DIRUT) D FLDERR(DIKKFIL,DIKKIENS,DIKKFLD,DIKKROOT,.DIKKSUPP)
.. Q:$D(DIRUT)
.. D W()
;
END D:'$D(DIRUT) EOPREAD
;
;Save in template, cleanup, and quit
D:$G(DIKKTEMP) SAVETEMP(DIKKTEMP)
K ^TMP("DIKKTAR",$J)
I $D(ZTQUEUED) S ZTREQ="@"
E X $G(^%ZIS("C"))
Q
;
KEYERR(RFIL,IENS,KEY,ROOT) ;
D WRREC(RFIL,IENS,DIKKTAB(1),.ROOT) Q:$D(DIRUT)
W ?DIKKTAB(2),"Duplicate Key "_$P($G(^DD("KEY",KEY,0)),U,2)_" (#"_KEY_")"
Q
;
FLDERR(FIL,IENS,FLD,ROOT,SUPP) ;
I '$G(SUPP) D Q:$D(DIRUT)
. D WRREC(FIL,IENS,DIKKTAB(1),.ROOT) Q:$D(DIRUT)
. W ?DIKKTAB(2),"Missing Key Field(s):"
D W($P($G(^DD(FIL,FLD,0)),U)_" ["_FIL_","_FLD_"]",DIKKTAB(2)+1)
S SUPP=1
Q
;
WRREC(FILE,IENS,TAB,ROOT) ;Write the record info
N DA,DIERR,ENAM,MSG
S:$G(ROOT)="" ROOT=$$FROOTDA^DIKCU(FILE)
D DA(IENS,.DA) Q:$D(DIRUT)
S ENAM=$P($G(@ROOT@(DA,0)),U)
S:ENAM]"" ENAM=$$EXTERNAL^DILFD(FILE,.01,"",ENAM,"MSG")
W ?TAB,$S(ENAM]"":ENAM,1:"Unknown record name")
Q
;
W(STR,TAB,KWN) ;Write STR
I $Y+3+$G(KWN)'<IOSL D Q:$D(DIRUT)
. D EOP Q:$D(DIRUT)
. D HDR,COLHDR
W !?+$G(TAB),$G(STR)
Q
;
EOP ;Check whether task should be stopped
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1 Q
D EOPREAD Q:$D(DIRUT)
W @IOF
Q
;
EOPREAD ;
Q:$E(IOST,1,2)'="C-"!$D(ZTQUEUED)
N DIR,DIROUT,DTOUT,DUOUT,X,Y
S DIR(0)="E" W ! D ^DIR
Q
;
HDR ;Write page header
S DIKKPAGE=$G(DIKKPAGE)+1
S $X=0 W "KEY INTEGRITY CHECK"
W ?(IOM-$L(DIKKHLIN)-$L(DIKKPAGE)-1),DIKKHLIN_DIKKPAGE
W !,$TR($J("",IOM-1)," ","-")
W !," Key: "_DIKKNAME_" (#"_DIKKEY_"), File #"_DIKKFILE
W !,"Uniqueness Index: "_DIKKUINM_" (#"_DIKKUI_")"
W:DIKKFILE'=DIKKUIFL ", Whole File #"_DIKKUIFL
Q
;
COLHDR ;Write column headers
N FNAM
S FNAM=$P($G(^DD(DIKKFIL,.01,0)),U)
D W() Q:$D(DIRUT)
D W("ENTRY #","",2) Q:$D(DIRUT) W ?DIKKTAB(1),FNAM,?DIKKTAB(2),"ERROR"
W !,"-------",?DIKKTAB(1),$TR($J("",$L(FNAM))," ","-"),?DIKKTAB(2),"-----"
Q
;
ASKTEMP(DIKKTOP) ;Ask for a template name
N DDA,DIC,DICKL,DIR,DIROUT,DIRUT,DIU0,DK,DQ,DTOUT,DUOUT
N C,D,D1,D1,D2,D3,D4,I,J,L,O,X,Y
;
S DK=DIKKTOP
D S2^DIBT1 Q:Y<0!$D(DIRUT) ""
Q +Y
;
SAVETEMP(Y) ;Save records in template Y
N CNT,DK,FILE,FLD,IENS,REC
S (CNT,FILE)=0 F S FILE=$O(^TMP("DIKKTAR",$J,FILE)) Q:'FILE D
. S IENS="" F S IENS=$O(^TMP("DIKKTAR",$J,FILE,IENS)) Q:IENS="" D
.. S REC=$P(IENS,",",$L(IENS,",")-1)
.. S:$D(^DIBT(+Y,1,REC))[0 CNT=CNT+1,^DIBT(+Y,1,REC)=""
S:CNT>0 ^DIBT(+Y,"QR")=DT_U_CNT
Q
;
DA(IENS,DA) ;Given IENS, write ien's and setup DA array
N I
D W("","",$L(IENS,",")-2) Q:$D(DIRUT)
K DA
F I=$L(IENS,",")-1:-1:2 S DA(I-1)=$P(IENS,",",I) W DA(I-1),!
S DA=$P(IENS,",") W DA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKKUTL3 4905 printed Sep 23, 2025@20:25:14 Page 2
DIKKUTL3 ;SFISC/MKO-VERIFY KEY INTEGRITY ;3:10 PM 27 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 ;
VERIFY(DIKKEY,DIKKTOP,DIKKFILE) ;Verify key integrity
+1 NEW DIKKTEMP,POP,%ZIS
+2 ;
+3 ;Ask whether to save records in a template
+4 SET DIKKTEMP=$$ASKTEMP(DIKKTOP)
+5 ;
+6 ;Select Device
+7 SET %ZIS=$SELECT($DATA(^%ZTSK):"Q",1:"")
+8 WRITE !
DO ^%ZIS
if $GET(POP)
QUIT
+9 KILL %ZIS,POP
+10 ;
+11 ;Queue report
+12 IF $DATA(IO("Q"))
Begin DoDot:1
+13 NEW I,ZTSK
+14 SET ZTRTN="MAIN^DIKKUTL3"
+15 SET ZTDESC="KEY INTEGRITY CHECK"
+16 FOR I="DIKKEY","DIKKTOP","DIKKFILE","DIKKTEMP"
SET ZTSAVE(I)=""
+17 DO ^%ZTLOAD
+18 IF $DATA(ZTSK)#2
WRITE !,"Report queued!",!,"Task number: "_$GET(ZTSK),!
+19 IF '$TEST
WRITE !,"Report canceled!",!
+20 SET IOP="HOME"
DO ^%ZIS
End DoDot:1
QUIT
+21 ;
+22 USE IO
+23 ;
MAIN ;Queued tasks enter here
+1 NEW DIKKHLIN,DIKKFIL,DIKKNAME,DIKKPAGE,DIKKTAB,DIKKUI,DIKKUIFL,DIKKUINM
+2 NEW DIKKIENS,DIKKFLD,DIKKFNAM,DIKKROOT,DIKKSUPP
+3 KILL ^TMP("DIKKUTL",$JOB)
+4 ;
+5 ;Check key integrity
+6 DO INTEG^DIKK(DIKKTOP,"","",DIKKEY,"",1)
+7 IF $DATA(DIERR)
DO MSG^DIALOG()
QUIT
+8 ;
+9 ;Initialize "global" variables for report
+10 SET DIKKPAGE=0
+11 SET %H=$HOROLOG
DO YX^%DTC
+12 SET DIKKHLIN=$PIECE(Y,"@")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)_" PAGE "
+13 SET DIKKTAB(1)=9
SET DIKKTAB(2)=41
+14 SET DIKKNAME=$PIECE($GET(^DD("KEY",DIKKEY,0)),U,2)
+15 SET DIKKUI=$PIECE($GET(^DD("KEY",DIKKEY,0)),U,4)
+16 SET DIKKUINM=$PIECE($GET(^DD("IX",+DIKKUI,0)),U,2)
SET DIKKUIFL=$PIECE($GET(^(0)),U)
+17 ;
+18 ;Print first header
+19 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+20 DO HDR
+21 IF '$DATA(^TMP("DIKKTAR",$JOB))
WRITE !!," ** NO PROBLEMS **"
GOTO END
+22 ;
+23 ;Loop through target error and list problems
+24 SET DIKKFIL=0
+25 FOR
SET DIKKFIL=$ORDER(^TMP("DIKKTAR",$JOB,DIKKFIL))
if 'DIKKFIL!$DATA(DIRUT)
QUIT
Begin DoDot:1
+26 DO COLHDR
+27 SET DIKKROOT=$$FROOTDA^DIKCU(DIKKFIL)
+28 SET DIKKIENS=" "
+29 FOR
SET DIKKIENS=$ORDER(^TMP("DIKKTAR",$JOB,DIKKFIL,DIKKIENS))
if DIKKIENS=""!$DATA(DIRUT)
QUIT
Begin DoDot:2
+30 if $DATA(^TMP("DIKKTAR",$JOB,DIKKFIL,DIKKIENS,"K",DIKKEY))
DO KEYERR(DIKKFIL,DIKKIENS,DIKKEY,DIKKROOT)
+31 SET (DIKKSUPP,DIKKFLD)=0
+32 FOR
SET DIKKFLD=$ORDER(^TMP("DIKKTAR",$JOB,DIKKFIL,DIKKIENS,DIKKFLD))
if 'DIKKFLD!$DATA(DIRUT)
QUIT
DO FLDERR(DIKKFIL,DIKKIENS,DIKKFLD,DIKKROOT,.DIKKSUPP)
+33 if $DATA(DIRUT)
QUIT
+34 DO W()
End DoDot:2
End DoDot:1
+35 ;
END if '$DATA(DIRUT)
DO EOPREAD
+1 ;
+2 ;Save in template, cleanup, and quit
+3 if $GET(DIKKTEMP)
DO SAVETEMP(DIKKTEMP)
+4 KILL ^TMP("DIKKTAR",$JOB)
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 IF '$TEST
XECUTE $GET(^%ZIS("C"))
+7 QUIT
+8 ;
KEYERR(RFIL,IENS,KEY,ROOT) ;
+1 DO WRREC(RFIL,IENS,DIKKTAB(1),.ROOT)
if $DATA(DIRUT)
QUIT
+2 WRITE ?DIKKTAB(2),"Duplicate Key "_$PIECE($GET(^DD("KEY",KEY,0)),U,2)_" (#"_KEY_")"
+3 QUIT
+4 ;
FLDERR(FIL,IENS,FLD,ROOT,SUPP) ;
+1 IF '$GET(SUPP)
Begin DoDot:1
+2 DO WRREC(FIL,IENS,DIKKTAB(1),.ROOT)
if $DATA(DIRUT)
QUIT
+3 WRITE ?DIKKTAB(2),"Missing Key Field(s):"
End DoDot:1
if $DATA(DIRUT)
QUIT
+4 DO W($PIECE($GET(^DD(FIL,FLD,0)),U)_" ["_FIL_","_FLD_"]",DIKKTAB(2)+1)
+5 SET SUPP=1
+6 QUIT
+7 ;
WRREC(FILE,IENS,TAB,ROOT) ;Write the record info
+1 NEW DA,DIERR,ENAM,MSG
+2 if $GET(ROOT)=""
SET ROOT=$$FROOTDA^DIKCU(FILE)
+3 DO DA(IENS,.DA)
if $DATA(DIRUT)
QUIT
+4 SET ENAM=$PIECE($GET(@ROOT@(DA,0)),U)
+5 if ENAM]""
SET ENAM=$$EXTERNAL^DILFD(FILE,.01,"",ENAM,"MSG")
+6 WRITE ?TAB,$SELECT(ENAM]"":ENAM,1:"Unknown record name")
+7 QUIT
+8 ;
W(STR,TAB,KWN) ;Write STR
+1 IF $Y+3+$GET(KWN)'<IOSL
Begin DoDot:1
+2 DO EOP
if $DATA(DIRUT)
QUIT
+3 DO HDR
DO COLHDR
End DoDot:1
if $DATA(DIRUT)
QUIT
+4 WRITE !?+$GET(TAB),$GET(STR)
+5 QUIT
+6 ;
EOP ;Check whether task should be stopped
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DIRUT)=1
QUIT
+2 DO EOPREAD
if $DATA(DIRUT)
QUIT
+3 WRITE @IOF
+4 QUIT
+5 ;
EOPREAD ;
+1 if $EXTRACT(IOST,1,2)'="C-"!$DATA(ZTQUEUED)
QUIT
+2 NEW DIR,DIROUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="E"
WRITE !
DO ^DIR
+4 QUIT
+5 ;
HDR ;Write page header
+1 SET DIKKPAGE=$GET(DIKKPAGE)+1
+2 SET $X=0
WRITE "KEY INTEGRITY CHECK"
+3 WRITE ?(IOM-$LENGTH(DIKKHLIN)-$LENGTH(DIKKPAGE)-1),DIKKHLIN_DIKKPAGE
+4 WRITE !,$TRANSLATE($JUSTIFY("",IOM-1)," ","-")
+5 WRITE !," Key: "_DIKKNAME_" (#"_DIKKEY_"), File #"_DIKKFILE
+6 WRITE !,"Uniqueness Index: "_DIKKUINM_" (#"_DIKKUI_")"
+7 if DIKKFILE'=DIKKUIFL
WRITE ", Whole File #"_DIKKUIFL
+8 QUIT
+9 ;
COLHDR ;Write column headers
+1 NEW FNAM
+2 SET FNAM=$PIECE($GET(^DD(DIKKFIL,.01,0)),U)
+3 DO W()
if $DATA(DIRUT)
QUIT
+4 DO W("ENTRY #","",2)
if $DATA(DIRUT)
QUIT
WRITE ?DIKKTAB(1),FNAM,?DIKKTAB(2),"ERROR"
+5 WRITE !,"-------",?DIKKTAB(1),$TRANSLATE($JUSTIFY("",$LENGTH(FNAM))," ","-"),?DIKKTAB(2),"-----"
+6 QUIT
+7 ;
ASKTEMP(DIKKTOP) ;Ask for a template name
+1 NEW DDA,DIC,DICKL,DIR,DIROUT,DIRUT,DIU0,DK,DQ,DTOUT,DUOUT
+2 NEW C,D,D1,D1,D2,D3,D4,I,J,L,O,X,Y
+3 ;
+4 SET DK=DIKKTOP
+5 DO S2^DIBT1
if Y<0!$DATA(DIRUT)
QUIT ""
+6 QUIT +Y
+7 ;
SAVETEMP(Y) ;Save records in template Y
+1 NEW CNT,DK,FILE,FLD,IENS,REC
+2 SET (CNT,FILE)=0
FOR
SET FILE=$ORDER(^TMP("DIKKTAR",$JOB,FILE))
if 'FILE
QUIT
Begin DoDot:1
+3 SET IENS=""
FOR
SET IENS=$ORDER(^TMP("DIKKTAR",$JOB,FILE,IENS))
if IENS=""
QUIT
Begin DoDot:2
+4 SET REC=$PIECE(IENS,",",$LENGTH(IENS,",")-1)
+5 if $DATA(^DIBT(+Y,1,REC))[0
SET CNT=CNT+1
SET ^DIBT(+Y,1,REC)=""
End DoDot:2
End DoDot:1
+6 if CNT>0
SET ^DIBT(+Y,"QR")=DT_U_CNT
+7 QUIT
+8 ;
DA(IENS,DA) ;Given IENS, write ien's and setup DA array
+1 NEW I
+2 DO W("","",$LENGTH(IENS,",")-2)
if $DATA(DIRUT)
QUIT
+3 KILL DA
+4 FOR I=$LENGTH(IENS,",")-1:-1:2
SET DA(I-1)=$PIECE(IENS,",",I)
WRITE DA(I-1),!
+5 SET DA=$PIECE(IENS,",")
WRITE DA
+6 QUIT
+7 ;
