- DDUCHK1 ;SFISC/RWF-CHECK DD part 2 ;3JUNE2011
- ;;22.0;VA FileMan;**130,168**;Mar 30, 1999;Build 27
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ID S DDUCRFE="" F DDUCZ=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"ID",DDUCRFE)) Q:DDUCRFE="" S DDUCX=$S($D(^DD(DDUCFI,0,"ID",DDUCRFE))#2:^(DDUCRFE),1:"") I DDUCX="Q" W !?5,"'ID' node for field ",DDUCRFE," = 'Q'" D:DDUCFIX ID1
- Q
- ID1 K ^DD(DDUCFI,0,"ID",DDUCRFE) D M1 W """ID"",",DDUCRFE D M2
- Q
- IX S DDUCXREF="" F DDUCZ=0:0 S DDUCXREF=$O(^DD(DDUCFI,0,"IX",DDUCXREF)) Q:DDUCXREF="" F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI)) Q:DDUCRFI'>0 D IX1
- Q
- IX1 D IXDUP ;22*130
- F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D
- . I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """IX"" Subscript: "_DDUCXREF_" " D WFE,WMS D:DDUCFIX IX2 Q
- . I $D(^DD(DDUCRFI,DDUCRFE,1,0))=0,$D(^DD(DDUCRFI,DDUCRFE,1))=10 S:DDUCFIX ^DD(DDUCRFI,DDUCRFE,1,0)="^.1"
- . S DDUCRFE1=0,DDUCRFEX="" F S DDUCRFE1=$O(^DD(DDUCRFI,DDUCRFE,1,DDUCRFE1)) Q:DDUCRFE1'>0 S DDUCRFEX=$G(^(DDUCRFE1,0)) I $P(DDUCRFEX,U,2)=DDUCXREF K DDUCRFEX Q
- . I $D(DDUCRFEX) W !?5,"Cross-reference logic is missing for """,DDUCXREF,""" x-ref" D:DDUCFIX IX2 Q
- K DDUCRFE1 Q
- IX2 K ^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE) D M1 W """IX"",",DDUCXREF_","_DDUCRFI_","_DDUCRFE D M2
- Q
- PT F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"PT",DDUCRFI)) Q:DDUCRFI'>0 F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D PT1
- Q
- PT1 I $D(^DD(DDUCRFI,0))[0 D WFI,WMS I DDUCFIX K ^DD(DDUCFI,0,"PT",DDUCRFI) D M1 W """PT"",",DDUCRFI D M2 Q
- I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """PT"" Subscript " D WFE,WMS D:DDUCFIX PTM Q
- I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D WFI,WFE W "is not a pointer." D:DDUCFIX PTM Q
- I $P(^(0),U,2)["P",+$P($P(^(0),U,2),"P",2)'=DDUCFI D WFI,WFE W "is not a pointer to file ",DDUCFI D:DDUCFIX PTM
- Q
- PTM K ^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)
- D M1 W """PT"",",DDUCRFI,",",DDUCRFE D M2
- Q
- AC F DDUCFE=0:0 S DDUCFE=$O(^DD("ACOMP",DDUCFI,DDUCFE)) Q:DDUCFE'>0 D AC1
- Q
- AC1 F DDUCRFI=0:0 S DDUCRFI=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI)) Q:DDUCRFI'>0 F DDUCRFE=0:0 S DDUCRFE=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D AC2
- Q
- AC2 I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D:DDUCFIX ACM Q
- S DDUCX=^(0) I $P(DDUCX,U,2)'["C" D:DDUCFIX ACM Q
- I $P(DDUCX,U,2)["C" S DDUCX1=$S($D(^(9.01)):^(9.01),1:""),DDUCF=0 D AC3
- Q
- AC3 F DDUCZ=1:1 S DDUCX2=$P(DDUCX1,";",DDUCZ) Q:DDUCX2="" I DDUCX2=DDUCFI_U_DDUCFE S DDUCF=1 Q
- I 'DDUCF D:DDUCFIX ACM
- Q
- ACM K ^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)
- Q
- NM S DDUCRFI(1)=$S($D(^DIC(DDUCFI,0))#2:$P(^(0),U),1:$P(^DD(DDUCFI,0)," SUB-FIELD"))
- Q:DDUCRFI(1)']"" K ^DD(DDUCFI,0,"NM") S ^DD(DDUCFI,0,"NM",DDUCRFI(1))="" W !?10,"Duplicate ""NM"" node was deleted."
- Q
- WHO W !?5,"Field: ",DDUCFE," (",$P(DDUCX,U),") " Q
- WFI W !?5,"File: ",DDUCRFI," " Q
- WFE W ?5,"Field: ",DDUCRFE," " Q
- WMS W "is missing." Q
- M1 W !?10,"^DD(",DDUCFI,",0," Q
- M2 W ") was killed." Q
- Q
- ;
- IXDUP ;Check for duplicate fields for same xref ;22*130
- N DDUCRFE,DDUCRFEP
- S (DDUCRFE,DDUCRFEP)=0
- S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCRFI,DDUCRFE)) ;HUH??
- D
- . F S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:'DDUCRFE D
- .. I 'DDUCRFEP S DDUCRFEP=DDUCRFE Q
- .. I DDUCRFE'=DDUCRFEP D
- MN ...N I F I=0:0 S I=$O(^DD(DDUCRFI,DDUCRFE,1,I)) Q:'I I +$G(^(I,0))=DDUCFI,$P(^(0),U,2)=DDUCXREF,$P(^(0),U,3)="MNEMONIC" K I Q
- ...Q:'$D(I)
- ... W !?5,"*File: ",DDUCRFI," Index: """_DDUCXREF_""" has duplicate Fields."
- ... W !?21,"Field: ",DDUCRFEP," Field: ",DDUCRFE
- .. S DDUCRFEP=DDUCRFE
- .. Q
- . S DDUCRFEP=0
- . Q
- DDUCHK1 ;SFISC/RWF-CHECK DD part 2 ;3JUNE2011
- +1 ;;22.0;VA FileMan;**130,168**;Mar 30, 1999;Build 27
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- ID SET DDUCRFE=""
- FOR DDUCZ=0:0
- SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"ID",DDUCRFE))
- IF DDUCRFE=""
- QUIT
- SET DDUCX=$SELECT($DATA(^DD(DDUCFI,0,"ID",DDUCRFE))#2:^(DDUCRFE),1:"")
- IF DDUCX="Q"
- WRITE !?5,"'ID' node for field ",DDUCRFE," = 'Q'"
- IF DDUCFIX
- DO ID1
- +1 QUIT
- ID1 KILL ^DD(DDUCFI,0,"ID",DDUCRFE)
- DO M1
- WRITE """ID"",",DDUCRFE
- DO M2
- +1 QUIT
- IX SET DDUCXREF=""
- FOR DDUCZ=0:0
- SET DDUCXREF=$ORDER(^DD(DDUCFI,0,"IX",DDUCXREF))
- IF DDUCXREF=""
- QUIT
- FOR DDUCRFI=0:0
- SET DDUCRFI=$ORDER(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI))
- IF DDUCRFI'>0
- QUIT
- DO IX1
- +1 QUIT
- IX1 ;22*130
- DO IXDUP
- +1 FOR DDUCRFE=0:0
- SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE))
- IF DDUCRFE'>0
- QUIT
- Begin DoDot:1
- +2 IF $DATA(^DD(DDUCRFI,DDUCRFE,0))[0
- DO WFI
- WRITE """IX"" Subscript: "_DDUCXREF_" "
- DO WFE
- DO WMS
- IF DDUCFIX
- DO IX2
- QUIT
- +3 IF $DATA(^DD(DDUCRFI,DDUCRFE,1,0))=0
- IF $DATA(^DD(DDUCRFI,DDUCRFE,1))=10
- IF DDUCFIX
- SET ^DD(DDUCRFI,DDUCRFE,1,0)="^.1"
- +4 SET DDUCRFE1=0
- SET DDUCRFEX=""
- FOR
- SET DDUCRFE1=$ORDER(^DD(DDUCRFI,DDUCRFE,1,DDUCRFE1))
- IF DDUCRFE1'>0
- QUIT
- SET DDUCRFEX=$GET(^(DDUCRFE1,0))
- IF $PIECE(DDUCRFEX,U,2)=DDUCXREF
- KILL DDUCRFEX
- QUIT
- +5 IF $DATA(DDUCRFEX)
- WRITE !?5,"Cross-reference logic is missing for """,DDUCXREF,""" x-ref"
- IF DDUCFIX
- DO IX2
- QUIT
- End DoDot:1
- +6 KILL DDUCRFE1
- QUIT
- IX2 KILL ^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)
- DO M1
- WRITE """IX"",",DDUCXREF_","_DDUCRFI_","_DDUCRFE
- DO M2
- +1 QUIT
- PT FOR DDUCRFI=0:0
- SET DDUCRFI=$ORDER(^DD(DDUCFI,0,"PT",DDUCRFI))
- IF DDUCRFI'>0
- QUIT
- FOR DDUCRFE=0:0
- SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE))
- IF DDUCRFE'>0
- QUIT
- DO PT1
- +1 QUIT
- PT1 IF $DATA(^DD(DDUCRFI,0))[0
- DO WFI
- DO WMS
- IF DDUCFIX
- KILL ^DD(DDUCFI,0,"PT",DDUCRFI)
- DO M1
- WRITE """PT"",",DDUCRFI
- DO M2
- QUIT
- +1 IF $DATA(^DD(DDUCRFI,DDUCRFE,0))[0
- DO WFI
- WRITE """PT"" Subscript "
- DO WFE
- DO WMS
- IF DDUCFIX
- DO PTM
- QUIT
- +2 IF ($PIECE(^(0),U,2)'["P")&($PIECE(^(0),U,2)'["V")
- DO WFI
- DO WFE
- WRITE "is not a pointer."
- IF DDUCFIX
- DO PTM
- QUIT
- +3 IF $PIECE(^(0),U,2)["P"
- IF +$PIECE($PIECE(^(0),U,2),"P",2)'=DDUCFI
- DO WFI
- DO WFE
- WRITE "is not a pointer to file ",DDUCFI
- IF DDUCFIX
- DO PTM
- +4 QUIT
- PTM KILL ^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)
- +1 DO M1
- WRITE """PT"",",DDUCRFI,",",DDUCRFE
- DO M2
- +2 QUIT
- AC FOR DDUCFE=0:0
- SET DDUCFE=$ORDER(^DD("ACOMP",DDUCFI,DDUCFE))
- IF DDUCFE'>0
- QUIT
- DO AC1
- +1 QUIT
- AC1 FOR DDUCRFI=0:0
- SET DDUCRFI=$ORDER(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI))
- IF DDUCRFI'>0
- QUIT
- FOR DDUCRFE=0:0
- SET DDUCRFE=$ORDER(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE))
- IF DDUCRFE'>0
- QUIT
- DO AC2
- +1 QUIT
- AC2 IF $DATA(^DD(DDUCRFI,DDUCRFE,0))[0
- IF DDUCFIX
- DO ACM
- QUIT
- +1 SET DDUCX=^(0)
- IF $PIECE(DDUCX,U,2)'["C"
- IF DDUCFIX
- DO ACM
- QUIT
- +2 IF $PIECE(DDUCX,U,2)["C"
- SET DDUCX1=$SELECT($DATA(^(9.01)):^(9.01),1:"")
- SET DDUCF=0
- DO AC3
- +3 QUIT
- AC3 FOR DDUCZ=1:1
- SET DDUCX2=$PIECE(DDUCX1,";",DDUCZ)
- IF DDUCX2=""
- QUIT
- IF DDUCX2=DDUCFI_U_DDUCFE
- SET DDUCF=1
- QUIT
- +1 IF 'DDUCF
- IF DDUCFIX
- DO ACM
- +2 QUIT
- ACM KILL ^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)
- +1 QUIT
- NM SET DDUCRFI(1)=$SELECT($DATA(^DIC(DDUCFI,0))#2:$PIECE(^(0),U),1:$PIECE(^DD(DDUCFI,0)," SUB-FIELD"))
- +1 IF DDUCRFI(1)']""
- QUIT
- KILL ^DD(DDUCFI,0,"NM")
- SET ^DD(DDUCFI,0,"NM",DDUCRFI(1))=""
- WRITE !?10,"Duplicate ""NM"" node was deleted."
- +2 QUIT
- WHO WRITE !?5,"Field: ",DDUCFE," (",$PIECE(DDUCX,U),") "
- QUIT
- WFI WRITE !?5,"File: ",DDUCRFI," "
- QUIT
- WFE WRITE ?5,"Field: ",DDUCRFE," "
- QUIT
- WMS WRITE "is missing."
- QUIT
- M1 WRITE !?10,"^DD(",DDUCFI,",0,"
- QUIT
- M2 WRITE ") was killed."
- QUIT
- +1 QUIT
- +2 ;
- IXDUP ;Check for duplicate fields for same xref ;22*130
- +1 NEW DDUCRFE,DDUCRFEP
- +2 SET (DDUCRFE,DDUCRFEP)=0
- +3 ;HUH??
- SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"IX",DDUCRFI,DDUCRFE))
- +4 Begin DoDot:1
- +5 FOR
- SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE))
- IF 'DDUCRFE
- QUIT
- Begin DoDot:2
- +6 IF 'DDUCRFEP
- SET DDUCRFEP=DDUCRFE
- QUIT
- +7 IF DDUCRFE'=DDUCRFEP
- Begin DoDot:3
- MN NEW I
- FOR I=0:0
- SET I=$ORDER(^DD(DDUCRFI,DDUCRFE,1,I))
- IF 'I
- QUIT
- IF +$GET(^(I,0))=DDUCFI
- IF $PIECE(^(0),U,2)=DDUCXREF
- IF $PIECE(^(0),U,3)="MNEMONIC"
- KILL I
- QUIT
- +1 IF '$DATA(I)
- QUIT
- +2 WRITE !?5,"*File: ",DDUCRFI," Index: """_DDUCXREF_""" has duplicate Fields."
- +3 WRITE !?21,"Field: ",DDUCRFEP," Field: ",DDUCRFE
- End DoDot:3
- +4 SET DDUCRFEP=DDUCRFE
- +5 QUIT
- End DoDot:2
- +6 SET DDUCRFEP=0
- +7 QUIT
- End DoDot:1
