source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDUCHK2.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.6 KB
RevLine 
[613]1DDUCHK2 ;SFISC/RWF/SO-CHECK DD (FIELDS) ;11:46 AM 5 Mar 2004
2 ;;22.0;VA FileMan;**100,130**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4CHK6 ;W !?5,"Checking FIELDs"
5 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
6 ;D CHKSB,CHKGL
7 Q
8FIELD ;W "."
9 I $D(^DD(DDUCFI,DDUCFE,0))[0 W !?5,"*Field: ",DDUCFE," is missing its zero node." Q ;22*100,22*130
10 S DDUCX=^DD(DDUCFI,DDUCFE,0),DDUCX2=$P(DDUCX,U,2),DDUCX4=$P(DDUCX,U,4),DDUCXN=$P(DDUCX,U)
11 I $P(DDUCX,U,5,999)["$N(",$P(DDUCX,U,5,999)'["$$N(" W !?5,"*Field: ",DDUCFE,"'s Input Transform contains $Next."
12 ;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."
13 D @$S(+DDUCX2:"MULT",DDUCX2["P":"PT",DDUCX2["V":"VP",1:"Q") Q
14 Q
15FIVE 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)=""
16 Q:'DDUCFIX
17 K ^DD(DDUCFI,DDUCFE,5)
18 S DDUCX="" F DDUCY=1:1 S DDUCX=$O(DDUCXX(DDUCX)) Q:DDUCX="" S ^DD(DDUCFI,DDUCFE,5,DDUCY,0)=DDUCX
19 Q
20VP 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
21 Q
22PT N DDUERR S DDUCRFI=+$P(DDUCX2,"P",2),DDUERR=0 D Q:DDUERR
23 . I $D(^DD(DDUCRFI,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to missing file: ",DDUCRFI S DDUERR=1 Q
24 . N DDUCGL,DDUCNA,DDUCHDR
25 . S DDUCGL=$G(^DIC(DDUCRFI,0,"GL"))
26 . I DDUCGL="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", is missing file's ""GL"" (Global Location) node." S DDUERR=1 Q
27 . S DDUCHDR=DDUCGL_"0)",DDUCHDR=$G(@DDUCHDR)
28 . I DDUCHDR="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", missing File header node." S DDUERR=1
29 . Q
30PT1 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."
31Q Q ;QUIT TAG
32MULT ;Work subfile
33 D PAGE^DDUCHK Q:$D(DIRUT)
34 I $D(^DD(+DDUCX2,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") missing subfile: ",+DDUCX2 Q
35 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."
36 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)
37 Q
38PUSH S DDUCSTK=DDUCSTK+1,DDUCSTK(DDUCSTK,1)=DDUCFI,DDUCSTK(DDUCSTK,2)=DDUCFE Q
39POP S DDUCFI=DDUCSTK(DDUCSTK,1),DDUCFE=DDUCSTK(DDUCSTK,2),DDUCSTK=DDUCSTK-1 Q
40WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q
41 ;
42CHKSB ;Check for duplicate "SB" x-refs ;22*130
43 N DDUCSB
44 S DDUCSB=0
45 F S DDUCSB=+$O(^DD(DDUCFI,"SB",DDUCSB)) Q:'DDUCSB D
46 . N DDUCFE,DDUCSAV,DDUNFE
47 . S DDUCFE=0
48 . F S DDUCFE=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) Q:'DDUCFE D CHKSBA I '$D(DDUNFE),$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) D
49 .. N DDUCFE1,DDUCX
50 .. ;Is the TYPE "WP"?
51 .. S DDUCX=$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) I $D(^DD(DDUCFI,DDUCX,0)),$P(^DD(DDUCFI,DDUCX,0),U,4)["WP" Q
52 .. S DDUCSAV(DDUCFE)=""
53 .. S DDUCFE1=DDUCFE
54 .. F S DDUCFE1=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE1)) Q:'DDUCFE1 S DDUCSAV(DDUCFE1)=""
55 . N X1,X2
56 . S X1=0
57 . F S X1=$O(DDUCSAV(X1)) Q:'X1 D
58 .. I '$D(X2) W !?5,"*Duplicate Fields represent Sub-file: "_DDUCSB,!?7 S X2=1
59 .. W "field: "_X1_"; "
60 Q
61 ;
62CHKSBA ;Check if Feidl exists
63 I '$D(^DD(DDUCFI,DDUCFE,0))#2 W !?7,"*Field: "_DDUCFE_", File: "_DDUCFI_", ""SB"" subscript for subfile: "_DDUCSB_" is missing." S DDUNFE=1 Q
64 Q
65 ;
66CHKGL ;Check for duplicate "GL" nodes ;22*130
67 N DDUCN
68 S DDUCN=""
69 F S DDUCN=$O(^DD(DDUCFI,"GL",DDUCN)) Q:DDUCN="" D
70 . N DDUCP
71 . S DDUCP=0
72 . F S DDUCP=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP)) Q:'DDUCP D
73 .. N DDUCFE2,DDUCSAV
74 .. S DDUCFE2=0
75 .. F S DDUCFE2=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'DDUCFE2 I $O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) D
76 ... S DDUCSAV(DDUCN_";"_DDUCP,DDUCFE2)=""
77 ... N X
78 ... S X=0
79 ... S X=$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'X S DDUCSAV(DDUCN_";"_DDUCP,X)=""
80 .. N X1,X2
81 .. S X1="" ;Global Location
82 .. F S X1=$O(DDUCSAV(X1)) Q:X1="" D
83 ... I '$D(X2) W !?5,"*Duplication at global location subscript: "_$P(X1,";")_", piece: "_$P(X1,";",2),!?9 S X2=1
84 ... N X3
85 ... S X3=0 ;Field #
86 ... F S X3=$O(DDUCSAV(X1,X3)) Q:'X3 W "field: "_X3_"; "
87 Q
Note: See TracBrowser for help on using the repository browser.