- 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 Feb 19, 2025@00:15:23 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 ;