DDUCHK3 ;SFISC/RWF-CHECK DD (XREF,COMPUTED) ;12:40 PM 4 Mar 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.
;
XREF F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,1,DDUCY)) Q:DDUCY'>0 S DDUCX=^(DDUCY,0),DDUCRFI=+DDUCX,DDUCX1=$P(DDUCX,U,2) D XREF1
Q
XREF1 ;
I DDUCRFI,$D(^DD(DDUCRFI,0)),$D(^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE))[0 D WHO,WFI W "missing 'IX' node." D:DDUCFIX XREFM Q
I DDUCX["TRIGGER" S DDUCRFI=+$P(DDUCX,U,4),DDUCRFE=+$P(DDUCX,U,5),DDUC5=DDUCFI_U_DDUCFE_U_DDUCY D TRIG
Q
XREFM S ^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE)="" W !?10,"^DD(",DDUCRFI,",0,""IX"",""",DDUCX1,""",",DDUCFI,",",DDUCFE,") = """" was set."
Q
TRIG I $D(^DD(DDUCRFI,0))[0 W !?5,"Field: ",DDUCFE," (",DDUCXN,") triggers missing file ",DDUCRFI Q
I $D(^DD(DDUCRFI,DDUCRFE,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") triggers missing field ",DDUCRFE," in file ",DDUCRFI Q
I '$D(^DD(DDUCRFI,DDUCRFE,5)) D WHO,WFI,WFE W " 5 node is missing." I DDUCFIX S ^DD(DDUCRFI,DDUCRFE,5,1,0)=DDUC5 W !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,1,0) = ",DDUC5," was set." Q
Q:'DDUCFIX S (DDUCYY1,DDUCOK)=0
F DDUCYY=0:0 S DDUCYY=$O(^DD(DDUCRFI,DDUCRFE,5,DDUCYY)) Q:DDUCYY'>0 S DDUCYY1=DDUCYY,DDUCYYX=^(DDUCYY,0) I DDUCYYX=DDUC5 S DDUCOK=1 Q
I 'DDUCOK D WHO,WFI,WFE W " 5 node is missing." D:DDUCFIX TRIGM Q
Q
TRIGM S ^DD(DDUCRFI,DDUCRFE,5,(DDUCYY1+1),0)=DDUC5
I DDUCRFI'=DDUCFE W !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,",DDUCYY1+1,",0) = ",DDUC5," was set."
Q
COMP Q:DDUCX2'["C" S DDUCX=$S($D(^DD(DDUCFI,DDUCFE,9.01)):^(9.01),1:"")
F DDUCX1=1:1 Q:$P(DDUCX,";",DDUCX1)="" S DDUCRFI=+$P(DDUCX,";",DDUCX1),DDUCRFE=+$P($P(DDUCX,";",DDUCX1),U,2) I $D(^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE))[0 S:DDUCFIX ^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE)=""
Q
WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q
WFI W !?8,"File: ",DDUCRFI," " Q
WFE W ?8,"Field: ",DDUCRFE," " Q
;
DXREF ; Check for $Next usage; 22*130
; DDUCFI = File #
; DDUCFE = Field #
; XRN = Cross Reference #
N XRN S XRN=0
F S XRN=$O(^DD(DDUCFI,DDUCFE,1,XRN)) Q:'XRN D
. ; XRN1 = Cross Reference Node Data
. N XRN1 S XRN1=""
. ; XRNW = 0 Have Not written warning, 1 have written warning
. N XRNW S XRNW=0
. F S XRN1=$O(^DD(DDUCFI,DDUCFE,1,XRN,XRN1)) Q:XRN1="" D
.. N GMSG S GMSG=0 ;1 equals use general message
.. I XRN1="%D" Q
.. I XRN1="DT" Q
.. ; Check for $Next any cross reference code
.. I ^DD(DDUCFI,DDUCFE,1,XRN,XRN1)["$N(",^DD(DDUCFI,DDUCFE,1,XRN,XRN1)'["$$N(" D I GMSG W !?5,"*Field: ",DDUCFE,", Cross Reference #: ",XRN,", Sub-Script: ",XRN1,", contains $Next."
... I $P(^DD(DDUCFI,DDUCFE,1,XRN,0),U,3)'="TRIGGER" S GMSG=1 Q
... ; Display/Fix known old FileMan TRIGGER Code:
... ; "D ^DICR:$N(^DD(DIH,DIG,1,0))>0"
... N DICRVAL
... S DICRVAL=$G(^DD(DDUCFI,DDUCFE,1,XRN,XRN1))
... I DICRVAL'["D ^DICR:$N(^DD(DIH,DIG,1,0))>0" S GMSG=1 Q
... I 'XRNW D
.... W !?5,"*File: "_DDUCFI_", Field: "_DDUCFE_", XREF: "_XRN_" contains $Next in TRIGGER code."
.... S ^TMP("DDUCHK",$J,DDUCFI,DDUCFE,XRN)=""
.... S XRNW=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDUCHK3 3297 printed Nov 22, 2024@17:53:44 Page 2
DDUCHK3 ;SFISC/RWF-CHECK DD (XREF,COMPUTED) ;12:40 PM 4 Mar 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 ;
XREF FOR DDUCY=0:0
SET DDUCY=$ORDER(^DD(DDUCFI,DDUCFE,1,DDUCY))
if DDUCY'>0
QUIT
SET DDUCX=^(DDUCY,0)
SET DDUCRFI=+DDUCX
SET DDUCX1=$PIECE(DDUCX,U,2)
DO XREF1
+1 QUIT
XREF1 ;
+1 IF DDUCRFI
IF $DATA(^DD(DDUCRFI,0))
IF $DATA(^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE))[0
DO WHO
DO WFI
WRITE "missing 'IX' node."
if DDUCFIX
DO XREFM
QUIT
+2 IF DDUCX["TRIGGER"
SET DDUCRFI=+$PIECE(DDUCX,U,4)
SET DDUCRFE=+$PIECE(DDUCX,U,5)
SET DDUC5=DDUCFI_U_DDUCFE_U_DDUCY
DO TRIG
+3 QUIT
XREFM SET ^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE)=""
WRITE !?10,"^DD(",DDUCRFI,",0,""IX"",""",DDUCX1,""",",DDUCFI,",",DDUCFE,") = """" was set."
+1 QUIT
TRIG IF $DATA(^DD(DDUCRFI,0))[0
WRITE !?5,"Field: ",DDUCFE," (",DDUCXN,") triggers missing file ",DDUCRFI
QUIT
+1 IF $DATA(^DD(DDUCRFI,DDUCRFE,0))[0
WRITE !?5,"*Field: ",DDUCFE," (",DDUCXN,") triggers missing field ",DDUCRFE," in file ",DDUCRFI
QUIT
+2 IF '$DATA(^DD(DDUCRFI,DDUCRFE,5))
DO WHO
DO WFI
DO WFE
WRITE " 5 node is missing."
IF DDUCFIX
SET ^DD(DDUCRFI,DDUCRFE,5,1,0)=DDUC5
WRITE !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,1,0) = ",DDUC5," was set."
QUIT
+3 if 'DDUCFIX
QUIT
SET (DDUCYY1,DDUCOK)=0
+4 FOR DDUCYY=0:0
SET DDUCYY=$ORDER(^DD(DDUCRFI,DDUCRFE,5,DDUCYY))
if DDUCYY'>0
QUIT
SET DDUCYY1=DDUCYY
SET DDUCYYX=^(DDUCYY,0)
IF DDUCYYX=DDUC5
SET DDUCOK=1
QUIT
+5 IF 'DDUCOK
DO WHO
DO WFI
DO WFE
WRITE " 5 node is missing."
if DDUCFIX
DO TRIGM
QUIT
+6 QUIT
TRIGM SET ^DD(DDUCRFI,DDUCRFE,5,(DDUCYY1+1),0)=DDUC5
+1 IF DDUCRFI'=DDUCFE
WRITE !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,",DDUCYY1+1,",0) = ",DDUC5," was set."
+2 QUIT
COMP if DDUCX2'["C"
QUIT
SET DDUCX=$SELECT($DATA(^DD(DDUCFI,DDUCFE,9.01)):^(9.01),1:"")
+1 FOR DDUCX1=1:1
if $PIECE(DDUCX,";",DDUCX1)=""
QUIT
SET DDUCRFI=+$PIECE(DDUCX,";",DDUCX1)
SET DDUCRFE=+$PIECE($PIECE(DDUCX,";",DDUCX1),U,2)
IF $DATA(^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE))[0
if DDUCFIX
SET ^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE)=""
+2 QUIT
WHO WRITE !?8,"Field: ",DDUCFE," (",DDUCXN,") "
QUIT
WFI WRITE !?8,"File: ",DDUCRFI," "
QUIT
WFE WRITE ?8,"Field: ",DDUCRFE," "
QUIT
+1 ;
DXREF ; Check for $Next usage; 22*130
+1 ; DDUCFI = File #
+2 ; DDUCFE = Field #
+3 ; XRN = Cross Reference #
+4 NEW XRN
SET XRN=0
+5 FOR
SET XRN=$ORDER(^DD(DDUCFI,DDUCFE,1,XRN))
if 'XRN
QUIT
Begin DoDot:1
+6 ; XRN1 = Cross Reference Node Data
+7 NEW XRN1
SET XRN1=""
+8 ; XRNW = 0 Have Not written warning, 1 have written warning
+9 NEW XRNW
SET XRNW=0
+10 FOR
SET XRN1=$ORDER(^DD(DDUCFI,DDUCFE,1,XRN,XRN1))
if XRN1=""
QUIT
Begin DoDot:2
+11 ;1 equals use general message
NEW GMSG
SET GMSG=0
+12 IF XRN1="%D"
QUIT
+13 IF XRN1="DT"
QUIT
+14 ; Check for $Next any cross reference code
+15 IF ^DD(DDUCFI,DDUCFE,1,XRN,XRN1)["$N("
IF ^DD(DDUCFI,DDUCFE,1,XRN,XRN1)'["$$N("
Begin DoDot:3
+16 IF $PIECE(^DD(DDUCFI,DDUCFE,1,XRN,0),U,3)'="TRIGGER"
SET GMSG=1
QUIT
+17 ; Display/Fix known old FileMan TRIGGER Code:
+18 ; "D ^DICR:$N(^DD(DIH,DIG,1,0))>0"
+19 NEW DICRVAL
+20 SET DICRVAL=$GET(^DD(DDUCFI,DDUCFE,1,XRN,XRN1))
+21 IF DICRVAL'["D ^DICR:$N(^DD(DIH,DIG,1,0))>0"
SET GMSG=1
QUIT
+22 IF 'XRNW
Begin DoDot:4
+23 WRITE !?5,"*File: "_DDUCFI_", Field: "_DDUCFE_", XREF: "_XRN_" contains $Next in TRIGGER code."
+24 SET ^TMP("DDUCHK",$JOB,DDUCFI,DDUCFE,XRN)=""
+25 SET XRNW=1
End DoDot:4
End DoDot:3
IF GMSG
WRITE !?5,"*Field: ",DDUCFE,", Cross Reference #: ",XRN,", Sub-Script: ",XRN1,", contains $Next."
End DoDot:2
End DoDot:1
+26 QUIT
