- DDUCHK2 ;SFISC/RWF/SO-CHECK DD (FIELDS) ;11:46 AM 5 Mar 2004
- ;;22.0;VA FileMan;**100,130**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- CHK6 ;W !?5,"Checking FIELDs"
- F DDUCFE=0:0 S DDUCFE=+$O(^DD(DDUCFI,DDUCFE)) Q:DDUCFE'>0 D FIELD Q:$D(DIRUT) D FIVE,DXREF^DDUCHK3,XREF^DDUCHK3,COMP^DDUCHK3
- ;D CHKSB,CHKGL
- Q
- FIELD ;W "."
- I $D(^DD(DDUCFI,DDUCFE,0))[0 W !?5,"*Field: ",DDUCFE," is missing its zero node." Q ;22*100,22*130
- S DDUCX=^DD(DDUCFI,DDUCFE,0),DDUCX2=$P(DDUCX,U,2),DDUCX4=$P(DDUCX,U,4),DDUCXN=$P(DDUCX,U)
- I $P(DDUCX,U,5,999)["$N(",$P(DDUCX,U,5,999)'["$$N(" W !?5,"*Field: ",DDUCFE,"'s Input Transform contains $Next."
- ;I DDUCX2["F",DDUCX4[";E1",$S($D(^DD(DDUCFI,DDUCFE,9)):^(9),1:"")'="@" D WHO W "doesn't have the correct protection for a field with executable code." I DDUCFIX S ^DD(DDUCFI,DDUCFE,9)="@" W !?10,"^DD(",DDUCFI,",",DDUCFE,",9) = ""@"" was set."
- D @$S(+DDUCX2:"MULT",DDUCX2["P":"PT",DDUCX2["V":"VP",1:"Q") Q
- Q
- FIVE K DDUCXX F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,5,DDUCY)) Q:DDUCY'>0 S DDUCX=^(DDUCY,0) I $D(^DD(+DDUCX,+$P(DDUCX,U,2),1,+$P(DDUCX,U,3),0))#2 S DDUCXX(DDUCX)=""
- Q:'DDUCFIX
- K ^DD(DDUCFI,DDUCFE,5)
- S DDUCX="" F DDUCY=1:1 S DDUCX=$O(DDUCXX(DDUCX)) Q:DDUCX="" S ^DD(DDUCFI,DDUCFE,5,DDUCY,0)=DDUCX
- Q
- VP F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,"V",DDUCY)) Q:DDUCY'>0 S DDUCRFI=$S($D(^DD(DDUCFI,DDUCFE,"V",DDUCY,0)):^(0),1:"") I DDUCRFI D PT1
- Q
- PT N DDUERR S DDUCRFI=+$P(DDUCX2,"P",2),DDUERR=0 D Q:DDUERR
- . I $D(^DD(DDUCRFI,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to missing file: ",DDUCRFI S DDUERR=1 Q
- . N DDUCGL,DDUCNA,DDUCHDR
- . S DDUCGL=$G(^DIC(DDUCRFI,0,"GL"))
- . I DDUCGL="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", is missing file's ""GL"" (Global Location) node." S DDUERR=1 Q
- . S DDUCHDR=DDUCGL_"0)",DDUCHDR=$G(@DDUCHDR)
- . I DDUCHDR="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", missing File header node." S DDUERR=1
- . Q
- PT1 I $D(^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE))[0 D WHO W "is missing its 'PT' node in the pointed-to-file." I DDUCFIX S ^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE)="" W !?10,"^DD(",+DDUCRFI,",0,""PT"",",DDUCFI,",",DDUCFE,") = """" was set."
- Q Q ;QUIT TAG
- MULT ;Work subfile
- D PAGE^DDUCHK Q:$D(DIRUT)
- I $D(^DD(+DDUCX2,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") missing subfile: ",+DDUCX2 Q
- S DDUCUP=$S($D(^DD(+DDUCX2,0,"UP")):^("UP"),1:"") I DDUCUP'=DDUCFI D WHO W "Bad 'UP' pointer in subfile #",+DDUCX2 I DDUCFIX S ^DD(+DDUCX2,0,"UP")=DDUCFI W !?10,"^DD(",+DDUCX2,",0,""UP"") = ",DDUCFI," was set."
- D PUSH S DDUCFI=+DDUCX2 W !?3,"Checking subfile ",DDUCFI D CHK^DDUCHK,POP W !?3,"Returning to ",$S('DDUCSTK:"main ",1:"sub"),"file",$S('DDUCSTK:" "_DDUCFILE_".",1:" "_DDUCFI)
- Q
- PUSH S DDUCSTK=DDUCSTK+1,DDUCSTK(DDUCSTK,1)=DDUCFI,DDUCSTK(DDUCSTK,2)=DDUCFE Q
- POP S DDUCFI=DDUCSTK(DDUCSTK,1),DDUCFE=DDUCSTK(DDUCSTK,2),DDUCSTK=DDUCSTK-1 Q
- WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q
- ;
- CHKSB ;Check for duplicate "SB" x-refs ;22*130
- N DDUCSB
- S DDUCSB=0
- F S DDUCSB=+$O(^DD(DDUCFI,"SB",DDUCSB)) Q:'DDUCSB D
- . N DDUCFE,DDUCSAV,DDUNFE
- . S DDUCFE=0
- . F S DDUCFE=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) Q:'DDUCFE D CHKSBA I '$D(DDUNFE),$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) D
- .. N DDUCFE1,DDUCX
- .. ;Is the TYPE "WP"?
- .. S DDUCX=$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) I $D(^DD(DDUCFI,DDUCX,0)),$P(^DD(DDUCFI,DDUCX,0),U,4)["WP" Q
- .. S DDUCSAV(DDUCFE)=""
- .. S DDUCFE1=DDUCFE
- .. F S DDUCFE1=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE1)) Q:'DDUCFE1 S DDUCSAV(DDUCFE1)=""
- . N X1,X2
- . S X1=0
- . F S X1=$O(DDUCSAV(X1)) Q:'X1 D
- .. I '$D(X2) W !?5,"*Duplicate Fields represent Sub-file: "_DDUCSB,!?7 S X2=1
- .. W "field: "_X1_"; "
- Q
- ;
- CHKSBA ;Check if Feidl exists
- I '$D(^DD(DDUCFI,DDUCFE,0))#2 W !?7,"*Field: "_DDUCFE_", File: "_DDUCFI_", ""SB"" subscript for subfile: "_DDUCSB_" is missing." S DDUNFE=1 Q
- Q
- ;
- CHKGL ;Check for duplicate "GL" nodes ;22*130
- N DDUCN
- S DDUCN=""
- F S DDUCN=$O(^DD(DDUCFI,"GL",DDUCN)) Q:DDUCN="" D
- . N DDUCP
- . S DDUCP=0
- . F S DDUCP=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP)) Q:'DDUCP D
- .. N DDUCFE2,DDUCSAV
- .. S DDUCFE2=0
- .. F S DDUCFE2=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'DDUCFE2 I $O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) D
- ... S DDUCSAV(DDUCN_";"_DDUCP,DDUCFE2)=""
- ... N X
- ... S X=0
- ... S X=$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'X S DDUCSAV(DDUCN_";"_DDUCP,X)=""
- .. N X1,X2
- .. S X1="" ;Global Location
- .. F S X1=$O(DDUCSAV(X1)) Q:X1="" D
- ... I '$D(X2) W !?5,"*Duplication at global location subscript: "_$P(X1,";")_", piece: "_$P(X1,";",2),!?9 S X2=1
- ... N X3
- ... S X3=0 ;Field #
- ... F S X3=$O(DDUCSAV(X1,X3)) Q:'X3 W "field: "_X3_"; "
- Q
- DDUCHK2 ;SFISC/RWF/SO-CHECK DD (FIELDS) ;11:46 AM 5 Mar 2004
- +1 ;;22.0;VA FileMan;**100,130**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- CHK6 ;W !?5,"Checking FIELDs"
- +1 FOR DDUCFE=0:0
- SET DDUCFE=+$ORDER(^DD(DDUCFI,DDUCFE))
- IF DDUCFE'>0
- QUIT
- DO FIELD
- IF $DATA(DIRUT)
- QUIT
- DO FIVE
- DO DXREF^DDUCHK3
- DO XREF^DDUCHK3
- DO COMP^DDUCHK3
- +2 ;D CHKSB,CHKGL
- +3 QUIT
- FIELD ;W "."
- +1 ;22*100,22*130
- IF $DATA(^DD(DDUCFI,DDUCFE,0))[0
- WRITE !?5,"*Field: ",DDUCFE," is missing its zero node."
- QUIT
- +2 SET DDUCX=^DD(DDUCFI,DDUCFE,0)
- SET DDUCX2=$PIECE(DDUCX,U,2)
- SET DDUCX4=$PIECE(DDUCX,U,4)
- SET DDUCXN=$PIECE(DDUCX,U)
- +3 IF $PIECE(DDUCX,U,5,999)["$N("
- IF $PIECE(DDUCX,U,5,999)'["$$N("
- WRITE !?5,"*Field: ",DDUCFE,"'s Input Transform contains $Next."
- +4 ;I DDUCX2["F",DDUCX4[";E1",$S($D(^DD(DDUCFI,DDUCFE,9)):^(9),1:"")'="@" D WHO W "doesn't have the correct protection for a field with executable code." I DDUCFIX S ^DD(DDUCFI,DDUCFE,9)="@" W !?10,"^DD(",DDUCFI,",",DDUCFE,",9) = ""@"" was set."
- +5 DO @$SELECT(+DDUCX2:"MULT",DDUCX2["P":"PT",DDUCX2["V":"VP",1:"Q")
- QUIT
- +6 QUIT
- FIVE KILL DDUCXX
- FOR DDUCY=0:0
- SET DDUCY=$ORDER(^DD(DDUCFI,DDUCFE,5,DDUCY))
- IF DDUCY'>0
- QUIT
- SET DDUCX=^(DDUCY,0)
- IF $DATA(^DD(+DDUCX,+$PIECE(DDUCX,U,2),1,+$PIECE(DDUCX,U,3),0))#2
- SET DDUCXX(DDUCX)=""
- +1 IF 'DDUCFIX
- QUIT
- +2 KILL ^DD(DDUCFI,DDUCFE,5)
- +3 SET DDUCX=""
- FOR DDUCY=1:1
- SET DDUCX=$ORDER(DDUCXX(DDUCX))
- IF DDUCX=""
- QUIT
- SET ^DD(DDUCFI,DDUCFE,5,DDUCY,0)=DDUCX
- +4 QUIT
- VP FOR DDUCY=0:0
- SET DDUCY=$ORDER(^DD(DDUCFI,DDUCFE,"V",DDUCY))
- IF DDUCY'>0
- QUIT
- SET DDUCRFI=$SELECT($DATA(^DD(DDUCFI,DDUCFE,"V",DDUCY,0)):^(0),1:"")
- IF DDUCRFI
- DO PT1
- +1 QUIT
- PT NEW DDUERR
- SET DDUCRFI=+$PIECE(DDUCX2,"P",2)
- SET DDUERR=0
- Begin DoDot:1
- +1 IF $DATA(^DD(DDUCRFI,0))[0
- WRITE !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to missing file: ",DDUCRFI
- SET DDUERR=1
- QUIT
- +2 NEW DDUCGL,DDUCNA,DDUCHDR
- +3 SET DDUCGL=$GET(^DIC(DDUCRFI,0,"GL"))
- +4 IF DDUCGL=""
- WRITE !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", is missing file's ""GL"" (Global Location) node."
- SET DDUERR=1
- QUIT
- +5 SET DDUCHDR=DDUCGL_"0)"
- SET DDUCHDR=$GET(@DDUCHDR)
- +6 IF DDUCHDR=""
- WRITE !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", missing File header node."
- SET DDUERR=1
- +7 QUIT
- End DoDot:1
- IF DDUERR
- QUIT
- PT1 IF $DATA(^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE))[0
- DO WHO
- WRITE "is missing its 'PT' node in the pointed-to-file."
- IF DDUCFIX
- SET ^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE)=""
- WRITE !?10,"^DD(",+DDUCRFI,",0,""PT"",",DDUCFI,",",DDUCFE,") = """" was set."
- Q ;QUIT TAG
- QUIT
- MULT ;Work subfile
- +1 DO PAGE^DDUCHK
- IF $DATA(DIRUT)
- QUIT
- +2 IF $DATA(^DD(+DDUCX2,0))[0
- WRITE !?5,"*Field: ",DDUCFE," (",DDUCXN,") missing subfile: ",+DDUCX2
- QUIT
- +3 SET DDUCUP=$SELECT($DATA(^DD(+DDUCX2,0,"UP")):^("UP"),1:"")
- IF DDUCUP'=DDUCFI
- DO WHO
- WRITE "Bad 'UP' pointer in subfile #",+DDUCX2
- IF DDUCFIX
- SET ^DD(+DDUCX2,0,"UP")=DDUCFI
- WRITE !?10,"^DD(",+DDUCX2,",0,""UP"") = ",DDUCFI," was set."
- +4 DO PUSH
- SET DDUCFI=+DDUCX2
- WRITE !?3,"Checking subfile ",DDUCFI
- DO CHK^DDUCHK
- DO POP
- WRITE !?3,"Returning to ",$SELECT('DDUCSTK:"main ",1:"sub"),"file",$SELECT('DDUCSTK:" "_DDUCFILE_".",1:" "_DDUCFI)
- +5 QUIT
- PUSH SET DDUCSTK=DDUCSTK+1
- SET DDUCSTK(DDUCSTK,1)=DDUCFI
- SET DDUCSTK(DDUCSTK,2)=DDUCFE
- QUIT
- POP SET DDUCFI=DDUCSTK(DDUCSTK,1)
- SET DDUCFE=DDUCSTK(DDUCSTK,2)
- SET DDUCSTK=DDUCSTK-1
- QUIT
- WHO WRITE !?8,"Field: ",DDUCFE," (",DDUCXN,") "
- QUIT
- +1 ;
- CHKSB ;Check for duplicate "SB" x-refs ;22*130
- +1 NEW DDUCSB
- +2 SET DDUCSB=0
- +3 FOR
- SET DDUCSB=+$ORDER(^DD(DDUCFI,"SB",DDUCSB))
- IF 'DDUCSB
- QUIT
- Begin DoDot:1
- +4 NEW DDUCFE,DDUCSAV,DDUNFE
- +5 SET DDUCFE=0
- +6 FOR
- SET DDUCFE=+$ORDER(^DD(DDUCFI,"SB",DDUCSB,DDUCFE))
- IF 'DDUCFE
- QUIT
- DO CHKSBA
- IF '$DATA(DDUNFE)
- IF $ORDER(^DD(DDUCFI,"SB",DDUCSB,DDUCFE))
- Begin DoDot:2
- +7 NEW DDUCFE1,DDUCX
- +8 ;Is the TYPE "WP"?
- +9 SET DDUCX=$ORDER(^DD(DDUCFI,"SB",DDUCSB,DDUCFE))
- IF $DATA(^DD(DDUCFI,DDUCX,0))
- IF $PIECE(^DD(DDUCFI,DDUCX,0),U,4)["WP"
- QUIT
- +10 SET DDUCSAV(DDUCFE)=""
- +11 SET DDUCFE1=DDUCFE
- +12 FOR
- SET DDUCFE1=+$ORDER(^DD(DDUCFI,"SB",DDUCSB,DDUCFE1))
- IF 'DDUCFE1
- QUIT
- SET DDUCSAV(DDUCFE1)=""
- End DoDot:2
- +13 NEW X1,X2
- +14 SET X1=0
- +15 FOR
- SET X1=$ORDER(DDUCSAV(X1))
- IF 'X1
- QUIT
- Begin DoDot:2
- +16 IF '$DATA(X2)
- WRITE !?5,"*Duplicate Fields represent Sub-file: "_DDUCSB,!?7
- SET X2=1
- +17 WRITE "field: "_X1_"; "
- End DoDot:2
- End DoDot:1
- +18 QUIT
- +19 ;
- CHKSBA ;Check if Feidl exists
- +1 IF '$DATA(^DD(DDUCFI,DDUCFE,0))#2
- WRITE !?7,"*Field: "_DDUCFE_", File: "_DDUCFI_", ""SB"" subscript for subfile: "_DDUCSB_" is missing."
- SET DDUNFE=1
- QUIT
- +2 QUIT
- +3 ;
- CHKGL ;Check for duplicate "GL" nodes ;22*130
- +1 NEW DDUCN
- +2 SET DDUCN=""
- +3 FOR
- SET DDUCN=$ORDER(^DD(DDUCFI,"GL",DDUCN))
- IF DDUCN=""
- QUIT
- Begin DoDot:1
- +4 NEW DDUCP
- +5 SET DDUCP=0
- +6 FOR
- SET DDUCP=+$ORDER(^DD(DDUCFI,"GL",DDUCN,DDUCP))
- IF 'DDUCP
- QUIT
- Begin DoDot:2
- +7 NEW DDUCFE2,DDUCSAV
- +8 SET DDUCFE2=0
- +9 FOR
- SET DDUCFE2=+$ORDER(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2))
- IF 'DDUCFE2
- QUIT
- IF $ORDER(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2))
- Begin DoDot:3
- +10 SET DDUCSAV(DDUCN_";"_DDUCP,DDUCFE2)=""
- +11 NEW X
- +12 SET X=0
- +13 SET X=$ORDER(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2))
- IF 'X
- QUIT
- SET DDUCSAV(DDUCN_";"_DDUCP,X)=""
- End DoDot:3
- +14 NEW X1,X2
- +15 ;Global Location
- SET X1=""
- +16 FOR
- SET X1=$ORDER(DDUCSAV(X1))
- IF X1=""
- QUIT
- Begin DoDot:3
- +17 IF '$DATA(X2)
- WRITE !?5,"*Duplication at global location subscript: "_$PIECE(X1,";")_", piece: "_$PIECE(X1,";",2),!?9
- SET X2=1
- +18 NEW X3
- +19 ;Field #
- SET X3=0
- +20 FOR
- SET X3=$ORDER(DDUCSAV(X1,X3))
- IF 'X3
- QUIT
- WRITE "field: "_X3_"; "
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 QUIT
