DDUCHK ;SFISC/RWF-CHECK DD ;11:25 AM 30 Dec 2004
;;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.
;
; 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDUCHK 4340 printed Sep 23, 2025@20:19:50 Page 2
DDUCHK ;SFISC/RWF-CHECK DD ;11:25 AM 30 Dec 2004
+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 ; DDUCFI=home file, DDUCFE=home field, DDUCFIX=flag to fix DD
+8 ; 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
