XBCFXREF ; IHS/ADC/GTH - CHECK/FIX XREFS ; [ 02/07/97 3:02 PM ]
;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
;
; This routine checks all REGULAR xrefs at the file level
; for selected files to insure all pointed to entries exist.
;
START ;
D INIT
I XBCFXREF("QFLG") D EOJ Q
D FILES
D EOJ
Q
;
INIT ;
S XBCFXREF("QFLG")=0
D ^XBKVAR
W !,"This routine will check the xrefs for the files you select and display",!," all errors found. You may also delete the bad xrefs."
W !!,"You should probably capture the output to an aux printer."
S XBCFXREF("DF")=$$DIR^XBDIR("S^1:DISPLAY ONLY;2:DISPLAY & FIX","","1")
I $D(DIRUT) S XBCFXREF("QFLG")=1 Q
D ^XBDSET
I '$D(^UTILITY("XBDSET")) S XBCFXREF("QFLG")=1 Q
Q
;
FILES ; CHECK FILES
S XBCFXREF("C")=0
F XBCFXREF("FILE")=0:0 S XBCFXREF("FILE")=$O(^UTILITY("XBDSET",$J,XBCFXREF("FILE"))) Q:XBCFXREF("FILE")="" D FILE
Q
;
;---------------------------------------------------------------------
; Gather up xrefs to check
;
FILE ; CHECK ONE FILE
W !!,"Checking the ",$P(^DIC(XBCFXREF("FILE"),0),U,1)," (",XBCFXREF("FILE"),") file"
KILL XBCFXREF("TBL")
S XBCFXREF("XREF")=""
F S XBCFXREF("XREF")=$O(^DD(XBCFXREF("FILE"),0,"IX",XBCFXREF("XREF"))) Q:XBCFXREF("XREF")="" S XBCFXREF("XREF FILE")=$O(^(XBCFXREF("XREF"),0)),XBCFXREF("XREF FIELD")=$O(^(XBCFXREF("XREF FILE"),0)) D
. S XBCFXREF("TBL",XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"),XBCFXREF("XREF"))=""
.Q
I $D(XBCFXREF("TBL")) D XREFILE KILL XBCFXREF("TBL")
I $D(XBCFXREF("TBL2")) D CHECK KILL XBCFXREF("TBL2")
Q
;
XREFILE ; CHECK EACH FILE/FIELD CREATING XREFS
F XBCFXREF("XREF FILE")=0:0 S XBCFXREF("XREF FILE")=$O(XBCFXREF("TBL",XBCFXREF("XREF FILE"))) Q:XBCFXREF("XREF FILE")="" D D XREFIELD
. S XBCFXREF("TOP DA")=0,XBCFXREF("PARENT")=""
. Q:'$D(^DD(XBCFXREF("XREF FILE"),0,"UP")) ; quit if not subfile
. NEW SUBFILE,PARENT,FIELD,LVL
. S SUBFILE=XBCFXREF("XREF FILE"),PARENT="",LVL=1
. D BACKUP
. S XBCFXREF("TOP DA")=LVL,XBCFXREF("PARENT")=PARENT
. Q
Q
;
BACKUP ; BACKUP TREE (CALLED RECURSIVELY)
S PARENT=^DD(SUBFILE,0,"UP")
S FIELD=$O(^DD(PARENT,"SB",SUBFILE,""))
I $D(^DD(PARENT,0,"UP")) S SUBFILE=PARENT,LVL=LVL+1 D BACKUP ; Recurse
Q
;
XREFIELD ; CHECK EACH FIELD CREATING XREFS
F XBCFXREF("XREF FIELD")=0:0 S XBCFXREF("XREF FIELD")=$O(XBCFXREF("TBL",XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"))) Q:XBCFXREF("XREF FIELD")="" D XREF
Q
;
XREF ; CHECK XREFS ON FIELD
NEW G,L,S,X,Y
KILL XBCFXRT,XBCFXREF("XREFS")
D ^XBGXREFS(XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"),.XBCFXRT)
F XBCFXREF("XN")=0:0 S XBCFXREF("XN")=$O(XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN"))) Q:XBCFXREF("XN")="" S X=XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN")) D
. Q:$P(X,U,2)="" ; must be trigger
. Q:$P(X,U,3)]"" ; not REGULAR xref
. Q:'$D(XBCFXREF("TBL",XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"),$P(X,U,2))) ; not of interest
. Q:'$D(XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN"),"S")) ; no set
. S Y=XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN"),"S")
. I '$F(Y,",DA"),'$F(Y,",D0") D Q
.. W !?2,$P(X,U,2)," doesn't use DA or D0. Skipping."
.. Q
. I $F(Y,",D0)=") D SAVE Q
. I XBCFXREF("PARENT")="",$F(Y,",DA)=") D SAVE Q
. I XBCFXREF("PARENT")]"" S S=",DA("_XBCFXREF("TOP DA")_"))=" I $F(Y,S) D SAVE Q
. Q
KILL XBCFXRT
Q
;
SAVE ; SAVE XREF TO CHECK
S XBCFXREF("C")=XBCFXREF("C")+1
S XBCFXREF("TBL2",XBCFXREF("C"))=$P(X,U,2) ; save it
Q
;
;---------------------------------------------------------------------
; Check data global for xrefs previously gathered
;
CHECK ; CHECK DATA GLOBAL FOR XREFS
W !!," Checking the following xrefs:"
NEW I
F I=0:0 S I=$O(XBCFXREF("TBL2",I)) Q:I="" W:$X>73 ! W " ",XBCFXREF("TBL2",I)
F XBCFXREF("C")=0:0 S XBCFXREF("C")=$O(XBCFXREF("TBL2",XBCFXREF("C"))) Q:XBCFXREF("C")="" S XBCFXREF("XREF")=XBCFXREF("TBL2",XBCFXREF("C")) D CHKXREF
Q
;
CHKXREF ; CHECK ONE XREF
W !!," Checking the """,XBCFXREF("XREF"),""" xref."
NEW G,L,R,V,X,Y
S X=XBCFXREF("XREF")
S G=^DIC(XBCFXREF("FILE"),0,"GL"),R=G_""""_X_""",",X=$E(R,1,$L(R)-1)_")",L=$L(R)
F S X=$Q(@X) Q:$E(X,1,L)'=R D
. Q:@X ; quit if mnemonic xref
. S Y=+$P(X,",",$L(X,","))
. Q:$D(@(G_Y_",0)"))
. W !?4,$$MSMZR^ZIBNSSV," does not exist.",!?6,"XREF node=",X
. I XBCFXREF("DF")=2 KILL @X W " deleted."
.Q
Q
;
;---------------------------------------------------------------------
EOJ ;
KILL ^UTILITY("XBDSET",$J)
KILL XBCFXREF,XBCFXRT
KILL DIRUT,DUOUT,DTOUT
W !!,"All done",!
Q
;
XBCFXREF ; IHS/ADC/GTH - CHECK/FIX XREFS ; [ 02/07/97 3:02 PM ]
+1 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
+2 ;
+3 ; This routine checks all REGULAR xrefs at the file level
+4 ; for selected files to insure all pointed to entries exist.
+5 ;
START ;
+1 DO INIT
+2 IF XBCFXREF("QFLG")
DO EOJ
QUIT
+3 DO FILES
+4 DO EOJ
+5 QUIT
+6 ;
INIT ;
+1 SET XBCFXREF("QFLG")=0
+2 DO ^XBKVAR
+3 WRITE !,"This routine will check the xrefs for the files you select and display",!," all errors found. You may also delete the bad xrefs."
+4 WRITE !!,"You should probably capture the output to an aux printer."
+5 SET XBCFXREF("DF")=$$DIR^XBDIR("S^1:DISPLAY ONLY;2:DISPLAY & FIX","","1")
+6 IF $DATA(DIRUT)
SET XBCFXREF("QFLG")=1
QUIT
+7 DO ^XBDSET
+8 IF '$DATA(^UTILITY("XBDSET"))
SET XBCFXREF("QFLG")=1
QUIT
+9 QUIT
+10 ;
FILES ; CHECK FILES
+1 SET XBCFXREF("C")=0
+2 FOR XBCFXREF("FILE")=0:0
SET XBCFXREF("FILE")=$ORDER(^UTILITY("XBDSET",$JOB,XBCFXREF("FILE")))
IF XBCFXREF("FILE")=""
QUIT
DO FILE
+3 QUIT
+4 ;
+5 ;---------------------------------------------------------------------
+6 ; Gather up xrefs to check
+7 ;
FILE ; CHECK ONE FILE
+1 WRITE !!,"Checking the ",$PIECE(^DIC(XBCFXREF("FILE"),0),U,1)," (",XBCFXREF("FILE"),") file"
+2 KILL XBCFXREF("TBL")
+3 SET XBCFXREF("XREF")=""
+4 FOR
SET XBCFXREF("XREF")=$ORDER(^DD(XBCFXREF("FILE"),0,"IX",XBCFXREF("XREF")))
IF XBCFXREF("XREF")=""
QUIT
SET XBCFXREF("XREF FILE")=$ORDER(^(XBCFXREF("XREF"),0))
SET XBCFXREF("XREF FIELD")=$ORDER(^(XBCFXREF("XREF FILE"),0))
Begin DoDot:1
+5 SET XBCFXREF("TBL",XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"),XBCFXREF("XREF"))=""
+6 QUIT
End DoDot:1
+7 IF $DATA(XBCFXREF("TBL"))
DO XREFILE
KILL XBCFXREF("TBL")
+8 IF $DATA(XBCFXREF("TBL2"))
DO CHECK
KILL XBCFXREF("TBL2")
+9 QUIT
+10 ;
XREFILE ; CHECK EACH FILE/FIELD CREATING XREFS
+1 FOR XBCFXREF("XREF FILE")=0:0
SET XBCFXREF("XREF FILE")=$ORDER(XBCFXREF("TBL",XBCFXREF("XREF FILE")))
IF XBCFXREF("XREF FILE")=""
QUIT
Begin DoDot:1
+2 SET XBCFXREF("TOP DA")=0
SET XBCFXREF("PARENT")=""
+3 ; quit if not subfile
IF '$DATA(^DD(XBCFXREF("XREF FILE"),0,"UP"))
QUIT
+4 NEW SUBFILE,PARENT,FIELD,LVL
+5 SET SUBFILE=XBCFXREF("XREF FILE")
SET PARENT=""
SET LVL=1
+6 DO BACKUP
+7 SET XBCFXREF("TOP DA")=LVL
SET XBCFXREF("PARENT")=PARENT
+8 QUIT
End DoDot:1
DO XREFIELD
+9 QUIT
+10 ;
BACKUP ; BACKUP TREE (CALLED RECURSIVELY)
+1 SET PARENT=^DD(SUBFILE,0,"UP")
+2 SET FIELD=$ORDER(^DD(PARENT,"SB",SUBFILE,""))
+3 ; Recurse
IF $DATA(^DD(PARENT,0,"UP"))
SET SUBFILE=PARENT
SET LVL=LVL+1
DO BACKUP
+4 QUIT
+5 ;
XREFIELD ; CHECK EACH FIELD CREATING XREFS
+1 FOR XBCFXREF("XREF FIELD")=0:0
SET XBCFXREF("XREF FIELD")=$ORDER(XBCFXREF("TBL",XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD")))
IF XBCFXREF("XREF FIELD")=""
QUIT
DO XREF
+2 QUIT
+3 ;
XREF ; CHECK XREFS ON FIELD
+1 NEW G,L,S,X,Y
+2 KILL XBCFXRT,XBCFXREF("XREFS")
+3 DO ^XBGXREFS(XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"),.XBCFXRT)
+4 FOR XBCFXREF("XN")=0:0
SET XBCFXREF("XN")=$ORDER(XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN")))
IF XBCFXREF("XN")=""
QUIT
SET X=XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN"))
Begin DoDot:1
+5 ; must be trigger
IF $PIECE(X,U,2)=""
QUIT
+6 ; not REGULAR xref
IF $PIECE(X,U,3)]""
QUIT
+7 ; not of interest
IF '$DATA(XBCFXREF("TBL",XBCFXREF("XREF FILE"),XBCFXREF("XREF FIELD"),$PIECE(X,U,2)))
QUIT
+8 ; no set
IF '$DATA(XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN"),"S"))
QUIT
+9 SET Y=XBCFXRT(XBCFXREF("XREF FIELD"),XBCFXREF("XN"),"S")
+10 IF '$FIND(Y,",DA")
IF '$FIND(Y,",D0")
Begin DoDot:2
+11 WRITE !?2,$PIECE(X,U,2)," doesn't use DA or D0. Skipping."
+12 QUIT
End DoDot:2
QUIT
+13 IF $FIND(Y,",D0)=")
DO SAVE
QUIT
+14 IF XBCFXREF("PARENT")=""
IF $FIND(Y,",DA)=")
DO SAVE
QUIT
+15 IF XBCFXREF("PARENT")]""
SET S=",DA("_XBCFXREF("TOP DA")_"))="
IF $FIND(Y,S)
DO SAVE
QUIT
+16 QUIT
End DoDot:1
+17 KILL XBCFXRT
+18 QUIT
+19 ;
SAVE ; SAVE XREF TO CHECK
+1 SET XBCFXREF("C")=XBCFXREF("C")+1
+2 ; save it
SET XBCFXREF("TBL2",XBCFXREF("C"))=$PIECE(X,U,2)
+3 QUIT
+4 ;
+5 ;---------------------------------------------------------------------
+6 ; Check data global for xrefs previously gathered
+7 ;
CHECK ; CHECK DATA GLOBAL FOR XREFS
+1 WRITE !!," Checking the following xrefs:"
+2 NEW I
+3 FOR I=0:0
SET I=$ORDER(XBCFXREF("TBL2",I))
IF I=""
QUIT
IF $X>73
WRITE !
WRITE " ",XBCFXREF("TBL2",I)
+4 FOR XBCFXREF("C")=0:0
SET XBCFXREF("C")=$ORDER(XBCFXREF("TBL2",XBCFXREF("C")))
IF XBCFXREF("C")=""
QUIT
SET XBCFXREF("XREF")=XBCFXREF("TBL2",XBCFXREF("C"))
DO CHKXREF
+5 QUIT
+6 ;
CHKXREF ; CHECK ONE XREF
+1 WRITE !!," Checking the """,XBCFXREF("XREF"),""" xref."
+2 NEW G,L,R,V,X,Y
+3 SET X=XBCFXREF("XREF")
+4 SET G=^DIC(XBCFXREF("FILE"),0,"GL")
SET R=G_""""_X_""","
SET X=$EXTRACT(R,1,$LENGTH(R)-1)_")"
SET L=$LENGTH(R)
+5 FOR
SET X=$QUERY(@X)
IF $EXTRACT(X,1,L)'=R
QUIT
Begin DoDot:1
+6 ; quit if mnemonic xref
IF @X
QUIT
+7 SET Y=+$PIECE(X,",",$LENGTH(X,","))
+8 IF $DATA(@(G_Y_",0)"))
QUIT
+9 WRITE !?4,$$MSMZR^ZIBNSSV," does not exist.",!?6,"XREF node=",X
+10 IF XBCFXREF("DF")=2
KILL @X
WRITE " deleted."
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
+14 ;---------------------------------------------------------------------
EOJ ;
+1 KILL ^UTILITY("XBDSET",$JOB)
+2 KILL XBCFXREF,XBCFXRT
+3 KILL DIRUT,DUOUT,DTOUT
+4 WRITE !!,"All done",!
+5 QUIT
+6 ;
