- DDUCHK ;SFISC/RWF-CHECK DD ;11:25 AM 30 Dec 2004
- ;;22.0;VA FileMan;**130**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ; DDUCFI=home file, DDUCFE=home field, DDUCFIX=flag to fix DD
- ; DDUCRFI=referenced file, DDUCRFE=referenced field.
- A W !!,"Check the Data Dictionary." D
- . W !,"Note: Messages that begin with an asterisk(*) can NOT be corrected and"
- . W !,"will need careful evaluation by software development!"
- S DDUC=""
- D DT^DICRW
- D L^DICRW1
- I X'>0 D G EXIT
- . I X'="" Q
- . W !?5,"*The file: "_$P($G(Y),U,2)_"(#"_$P($G(Y),U)_") is missing its ""GL"" (Global Location) node."
- . W !?6,"No further checking for this file can occur!"
- S DDUCFIS=+X-.000001,DDUCFIE=DIB(1)
- S DIR(0)="Y",DIR("A")="Remove erroneous nodes",DIR("B")="NO",DIR("?",1)="This routine will try to fix certain nodes that are erroneous and may set some nodes to a file referenced by the selected file."
- S DIR("?")="Say 'NO' here to leave the DD untouched. It will only flag the ones it finds erroneous."
- D ^DIR G EXIT:$D(DIRUT) S DDUCFIX=+Y K DIR
- ZIS S %ZIS="Q" D ^%ZIS G EXIT:POP
- I $D(IO("Q")) S ZTRTN="DQ^DDUCHK",ZTSAVE("DDUCFIX")="",ZTSAVE("DDUCFIS")="",ZTSAVE("DDUCFIE")="" D ^%ZTLOAD G EXIT
- DQ U IO K DDUCSTK,^TMP("DDUCHK",$J) S DDUCSTK=0,DDUCFX=DDUCFIX
- F DDUCFILE=DDUCFIS:0:DDUCFIE S DDUCFILE=$O(^DIC(DDUCFILE)) Q:DDUCFILE'>0!(DDUCFILE>DDUCFIE) D PAGE Q:$D(DIRUT) D
- . N DDUERR S DDUERR=0
- . W !!,"Checking file ",DDUCFILE
- . S (DDUCFI,DIFILE)=+DDUCFILE
- . D DDAC
- . D CHKHDR
- . I DDUERR Q
- . D CHK
- EXIT ;
- I $G(DUZ(0))="@",$D(^TMP("DDUCHK",$J)) D
- . W:$G(IOF)]"" @IOF
- . W !!,"List of ;;<file#>^<field #>^<cross reference#> that contain $Next"
- . N DDFIL S DDFIL=0 N I S I=1 N DDSP S DDSP=" "
- . F S DDFIL=$O(^TMP("DDUCHK",$J,DDFIL)) Q:'DDFIL D
- .. N DDFLD S DDFLD=0
- .. F S DDFLD=$O(^TMP("DDUCHK",$J,DDFIL,DDFLD)) Q:'DDFLD D
- ... N DDXRN S DDXRN=0
- ... F S DDXRN=$O(^TMP("DDUCHK",$J,DDFIL,DDFLD,DDXRN)) Q:'DDXRN D
- .... W !,I_$E(DDSP,1,(8-$L(I)))_";;"_DDFIL_U_DDFLD_U_DDXRN
- .... S I=I+1
- . S I=9999 W !,I_$E(DDSP,1,(8-$L(I)))_";;LAST LINE"
- K ^TMP("DDUCHK",$J)
- D ^%ZISC
- K DDUCFI,DDUCFIX,DDUCFILE,DDUCFIS,DDUCFIE,DDUCFE,DDUCX,DDUCX1,DDUCX2,DDUCX4,DDUCRFI
- K DDUCRFE,DDUCSTK,DDUCSTK,DDUCDNAM,DDUCNAME,DDUCXX,DDUCY,DDUCUP,DDUCXN
- K DDUCF,DDUCXREF,DDUCZ,DDUC5,DDUCYY,DDUCYY1,DDUCOK,DDUCYYX,DIB,DDUC,DDUCFX,DIAC,DIFILE
- Q
- ;
- PAGE I $Y+3>IOSL S DIR(0)="E" D:IOST["C-" ^DIR W @IOF
- Q
- ;
- DDAC I DUZ(0)'="@" S DIAC="DD" D ^DIAC S DDUCFIX=DDUCFX I 'DIAC,DDUCFX W !,"You don't have DD access to this file. No fixing will be done on this file." S DDUCFIX=0 Q
- Q
- CHK I $G(^DIC(DDUCFI,0))]"",'$P(^(0),U,2) S:DDUCFIX $P(^(0),U,2)=DDUCFI
- I $D(^DD(DDUCFI,0))[0 S DDUCRFI=DDUCFI W !?5,"*File: "_DDUCRFI_", is missing its file header node."
- I $D(^DD(DDUCFI,0,"ID")) D ID^DDUCHK1
- I $D(^DD(DDUCFI,0,"IX")) D IX^DDUCHK1
- I $D(^DD(DDUCFI,0,"PT")) D PT^DDUCHK1
- D CHKGL^DDUCHK2
- D CHKSB^DDUCHK2
- S DDUCNAME=$O(^DD(DDUCFI,0,"NM","")),DDUCDNAM=$O(^(DDUCNAME)),DDUCRFI=DDUCFI I DDUCDNAM]"" D WFI W "has duplicate 'NM' nodes." I DDUCFIX D NM^DDUCHK1
- I $D(^DD("ACOMP",DDUCFI)) D AC^DDUCHK1
- D INDEX^DDUCHK4(DDUCFI,DDUCFIX),KEY^DDUCHK5(DDUCFI,DDUCFIX)
- G ^DDUCHK2
- WFI W !?8,"File: ",DDUCRFI," " Q
- ;
- EN ;
- Q:'$D(DDUCFI)!'$D(DDUCFIX) S U="^"
- I DDUCFI Q:'$D(^DIC(DDUCFI,0,"GL")) G EN1
- Q:'$D(@(DDUCFI_"0)")) S DDUCFI=+$P(^(0),U,2)
- EN1 S DDUCFIS=+DDUCFI-.000001,DDUCFIE=+DDUCFI
- G ZIS
- ;
- CHKHDR ; Check for Missing or Incorrect File Header Node ;22*130
- ;W !?5,"File: ",DDUCFI," Checking File Header Node."
- N DDUCGL,DDUCNA,DDUCHDR
- S DDUCGL=$G(^DIC(DDUCFI,0,"GL"))
- I DDUCGL="" W !?5,"*File: "_DDUCFI_", is missing file's ""GL"" (Global Location) node.",!?6,"No further checking can occur!" S DDUERR=1 Q
- S DDUCHDR=DDUCGL_"0)",DDUCHDR=$G(@DDUCHDR)
- S DDUCNA=$P(^DIC(DDUCFI,0),U)
- I DDUCHDR="" W !?5,"*File: "_DDUCFI_", is missing the File header node." Q
- I $P(DDUCHDR,U)'=DDUCNA W !?5,"*File: "_DDUCFI_", header name is incorrect." Q
- I +$P(DDUCHDR,U,2)'=DDUCFI W !?5,"*File: "_DDUCFI_" File header number is incorrect." Q
- Q
- DDUCHK ;SFISC/RWF-CHECK DD ;11:25 AM 30 Dec 2004
- +1 ;;22.0;VA FileMan;**130**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ; DDUCFI=home file, DDUCFE=home field, DDUCFIX=flag to fix DD
- +4 ; DDUCRFI=referenced file, DDUCRFE=referenced field.
- A WRITE !!,"Check the Data Dictionary."
- Begin DoDot:1
- +1 WRITE !,"Note: Messages that begin with an asterisk(*) can NOT be corrected and"
- +2 WRITE !,"will need careful evaluation by software development!"
- End DoDot:1
- +3 SET DDUC=""
- +4 DO DT^DICRW
- +5 DO L^DICRW1
- +6 IF X'>0
- Begin DoDot:1
- +7 IF X'=""
- QUIT
- +8 WRITE !?5,"*The file: "_$PIECE($GET(Y),U,2)_"(#"_$PIECE($GET(Y),U)_") is missing its ""GL"" (Global Location) node."
- +9 WRITE !?6,"No further checking for this file can occur!"
- End DoDot:1
- GOTO EXIT
- +10 SET DDUCFIS=+X-.000001
- SET DDUCFIE=DIB(1)
- +11 SET DIR(0)="Y"
- SET DIR("A")="Remove erroneous nodes"
- SET DIR("B")="NO"
- SET DIR("?",1)="This routine will try to fix certain nodes that are erroneous and may set some nodes to a file referenced by the selected file."
- +12 SET DIR("?")="Say 'NO' here to leave the DD untouched. It will only flag the ones it finds erroneous."
- +13 DO ^DIR
- IF $DATA(DIRUT)
- GOTO EXIT
- SET DDUCFIX=+Y
- KILL DIR
- ZIS SET %ZIS="Q"
- DO ^%ZIS
- IF POP
- GOTO EXIT
- +1 IF $DATA(IO("Q"))
- SET ZTRTN="DQ^DDUCHK"
- SET ZTSAVE("DDUCFIX")=""
- SET ZTSAVE("DDUCFIS")=""
- SET ZTSAVE("DDUCFIE")=""
- DO ^%ZTLOAD
- GOTO EXIT
- DQ USE IO
- KILL DDUCSTK,^TMP("DDUCHK",$JOB)
- SET DDUCSTK=0
- SET DDUCFX=DDUCFIX
- +1 FOR DDUCFILE=DDUCFIS:0:DDUCFIE
- SET DDUCFILE=$ORDER(^DIC(DDUCFILE))
- IF DDUCFILE'>0!(DDUCFILE>DDUCFIE)
- QUIT
- DO PAGE
- IF $DATA(DIRUT)
- QUIT
- Begin DoDot:1
- +2 NEW DDUERR
- SET DDUERR=0
- +3 WRITE !!,"Checking file ",DDUCFILE
- +4 SET (DDUCFI,DIFILE)=+DDUCFILE
- +5 DO DDAC
- +6 DO CHKHDR
- +7 IF DDUERR
- QUIT
- +8 DO CHK
- End DoDot:1
- EXIT ;
- +1 IF $GET(DUZ(0))="@"
- IF $DATA(^TMP("DDUCHK",$JOB))
- Begin DoDot:1
- +2 IF $GET(IOF)]""
- WRITE @IOF
- +3 WRITE !!,"List of ;;<file#>^<field #>^<cross reference#> that contain $Next"
- +4 NEW DDFIL
- SET DDFIL=0
- NEW I
- SET I=1
- NEW DDSP
- SET DDSP=" "
- +5 FOR
- SET DDFIL=$ORDER(^TMP("DDUCHK",$JOB,DDFIL))
- IF 'DDFIL
- QUIT
- Begin DoDot:2
- +6 NEW DDFLD
- SET DDFLD=0
- +7 FOR
- SET DDFLD=$ORDER(^TMP("DDUCHK",$JOB,DDFIL,DDFLD))
- IF 'DDFLD
- QUIT
- Begin DoDot:3
- +8 NEW DDXRN
- SET DDXRN=0
- +9 FOR
- SET DDXRN=$ORDER(^TMP("DDUCHK",$JOB,DDFIL,DDFLD,DDXRN))
- IF 'DDXRN
- QUIT
- Begin DoDot:4
- +10 WRITE !,I_$EXTRACT(DDSP,1,(8-$LENGTH(I)))_";;"_DDFIL_U_DDFLD_U_DDXRN
- +11 SET I=I+1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +12 SET I=9999
- WRITE !,I_$EXTRACT(DDSP,1,(8-$LENGTH(I)))_";;LAST LINE"
- End DoDot:1
- +13 KILL ^TMP("DDUCHK",$JOB)
- +14 DO ^%ZISC
- +15 KILL DDUCFI,DDUCFIX,DDUCFILE,DDUCFIS,DDUCFIE,DDUCFE,DDUCX,DDUCX1,DDUCX2,DDUCX4,DDUCRFI
- +16 KILL DDUCRFE,DDUCSTK,DDUCSTK,DDUCDNAM,DDUCNAME,DDUCXX,DDUCY,DDUCUP,DDUCXN
- +17 KILL DDUCF,DDUCXREF,DDUCZ,DDUC5,DDUCYY,DDUCYY1,DDUCOK,DDUCYYX,DIB,DDUC,DDUCFX,DIAC,DIFILE
- +18 QUIT
- +19 ;
- PAGE IF $Y+3>IOSL
- SET DIR(0)="E"
- IF IOST["C-"
- DO ^DIR
- WRITE @IOF
- +1 QUIT
- +2 ;
- DDAC IF DUZ(0)'="@"
- SET DIAC="DD"
- DO ^DIAC
- SET DDUCFIX=DDUCFX
- IF 'DIAC
- IF DDUCFX
- WRITE !,"You don't have DD access to this file. No fixing will be done on this file."
- SET DDUCFIX=0
- QUIT
- +1 QUIT
- CHK IF $GET(^DIC(DDUCFI,0))]""
- IF '$PIECE(^(0),U,2)
- IF DDUCFIX
- SET $PIECE(^(0),U,2)=DDUCFI
- +1 IF $DATA(^DD(DDUCFI,0))[0
- SET DDUCRFI=DDUCFI
- WRITE !?5,"*File: "_DDUCRFI_", is missing its file header node."
- +2 IF $DATA(^DD(DDUCFI,0,"ID"))
- DO ID^DDUCHK1
- +3 IF $DATA(^DD(DDUCFI,0,"IX"))
- DO IX^DDUCHK1
- +4 IF $DATA(^DD(DDUCFI,0,"PT"))
- DO PT^DDUCHK1
- +5 DO CHKGL^DDUCHK2
- +6 DO CHKSB^DDUCHK2
- +7 SET DDUCNAME=$ORDER(^DD(DDUCFI,0,"NM",""))
- SET DDUCDNAM=$ORDER(^(DDUCNAME))
- SET DDUCRFI=DDUCFI
- IF DDUCDNAM]""
- DO WFI
- WRITE "has duplicate 'NM' nodes."
- IF DDUCFIX
- DO NM^DDUCHK1
- +8 IF $DATA(^DD("ACOMP",DDUCFI))
- DO AC^DDUCHK1
- +9 DO INDEX^DDUCHK4(DDUCFI,DDUCFIX)
- DO KEY^DDUCHK5(DDUCFI,DDUCFIX)
- +10 GOTO ^DDUCHK2
- WFI WRITE !?8,"File: ",DDUCRFI," "
- QUIT
- +1 ;
- EN ;
- +1 IF '$DATA(DDUCFI)!'$DATA(DDUCFIX)
- QUIT
- SET U="^"
- +2 IF DDUCFI
- IF '$DATA(^DIC(DDUCFI,0,"GL"))
- QUIT
- GOTO EN1
- +3 IF '$DATA(@(DDUCFI_"0)"))
- QUIT
- SET DDUCFI=+$PIECE(^(0),U,2)
- EN1 SET DDUCFIS=+DDUCFI-.000001
- SET DDUCFIE=+DDUCFI
- +1 GOTO ZIS
- +2 ;
- CHKHDR ; Check for Missing or Incorrect File Header Node ;22*130
- +1 ;W !?5,"File: ",DDUCFI," Checking File Header Node."
- +2 NEW DDUCGL,DDUCNA,DDUCHDR
- +3 SET DDUCGL=$GET(^DIC(DDUCFI,0,"GL"))
- +4 IF DDUCGL=""
- WRITE !?5,"*File: "_DDUCFI_", is missing file's ""GL"" (Global Location) node.",!?6,"No further checking can occur!"
- SET DDUERR=1
- QUIT
- +5 SET DDUCHDR=DDUCGL_"0)"
- SET DDUCHDR=$GET(@DDUCHDR)
- +6 SET DDUCNA=$PIECE(^DIC(DDUCFI,0),U)
- +7 IF DDUCHDR=""
- WRITE !?5,"*File: "_DDUCFI_", is missing the File header node."
- QUIT
- +8 IF $PIECE(DDUCHDR,U)'=DDUCNA
- WRITE !?5,"*File: "_DDUCFI_", header name is incorrect."
- QUIT
- +9 IF +$PIECE(DDUCHDR,U,2)'=DDUCFI
- WRITE !?5,"*File: "_DDUCFI_" File header number is incorrect."
- QUIT
- +10 QUIT
