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

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

initial load of WorldVistAEHR

File size: 3.4 KB
RevLine 
[613]1DDUCHK1 ;SFISC/RWF-CHECK DD part 2 ;7:08 AM 1 Oct 2003
2 ;;22.0;VA FileMan;**130**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4ID 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
5 Q
6ID1 K ^DD(DDUCFI,0,"ID",DDUCRFE) D M1 W """ID"",",DDUCRFE D M2
7 Q
8IX 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
9 Q
10IX1 D IXDUP ;22*130
11 F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D
12 . I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """IX"" Subscript: "_DDUCXREF_" " D WFE,WMS D:DDUCFIX IX2 Q
13 . I $D(^DD(DDUCRFI,DDUCRFE,1,0))=0,$D(^DD(DDUCRFI,DDUCRFE,1))=10 S:DDUCFIX ^DD(DDUCRFI,DDUCRFE,1,0)="^.1"
14 . 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
15 . I $D(DDUCRFEX) W !?5,"Cross-reference logic is missing for """,DDUCXREF,""" x-ref" D:DDUCFIX IX2 Q
16 K DDUCRFE1 Q
17IX2 K ^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE) D M1 W """IX"",",DDUCXREF_","_DDUCRFI_","_DDUCRFE D M2
18 Q
19PT 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
20 Q
21PT1 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
22 I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """PT"" Subscript " D WFE,WMS D:DDUCFIX PTM Q
23 I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D WFI,WFE W "is not a pointer." D:DDUCFIX PTM Q
24 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
25 Q
26PTM K ^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)
27 D M1 W """PT"",",DDUCRFI,",",DDUCRFE D M2
28 Q
29AC F DDUCFE=0:0 S DDUCFE=$O(^DD("ACOMP",DDUCFI,DDUCFE)) Q:DDUCFE'>0 D AC1
30 Q
31AC1 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
32 Q
33AC2 I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D:DDUCFIX ACM Q
34 S DDUCX=^(0) I $P(DDUCX,U,2)'["C" D:DDUCFIX ACM Q
35 I $P(DDUCX,U,2)["C" S DDUCX1=$S($D(^(9.01)):^(9.01),1:""),DDUCF=0 D AC3
36 Q
37AC3 F DDUCZ=1:1 S DDUCX2=$P(DDUCX1,";",DDUCZ) Q:DDUCX2="" I DDUCX2=DDUCFI_U_DDUCFE S DDUCF=1 Q
38 I 'DDUCF D:DDUCFIX ACM
39 Q
40ACM K ^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)
41 Q
42NM S DDUCRFI(1)=$S($D(^DIC(DDUCFI,0))#2:$P(^(0),U),1:$P(^DD(DDUCFI,0)," SUB-FIELD"))
43 Q:DDUCRFI(1)']"" K ^DD(DDUCFI,0,"NM") S ^DD(DDUCFI,0,"NM",DDUCRFI(1))="" W !?10,"Duplicate ""NM"" node was deleted."
44 Q
45WHO W !?5,"Field: ",DDUCFE," (",$P(DDUCX,U),") " Q
46WFI W !?5,"File: ",DDUCRFI," " Q
47WFE W ?5,"Field: ",DDUCRFE," " Q
48WMS W "is missing." Q
49M1 W !?10,"^DD(",DDUCFI,",0," Q
50M2 W ") was killed." Q
51 Q
52 ;
53IXDUP ;Check for duplicate fields for same xref ;22*130
54 N DDUCRFE,DDUCRFEP
55 S (DDUCRFE,DDUCRFEP)=0
56 S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCRFI,DDUCRFE))
57 D
58 . F S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:'DDUCRFE D
59 .. I 'DDUCRFEP S DDUCRFEP=DDUCRFE Q
60 .. I DDUCRFE'=DDUCRFEP D
61 ... W !?5,"*File: ",DDUCRFI," Index: """_DDUCXREF_""" has duplicate Fields."
62 ... W !?21,"Field: ",DDUCRFEP," Field: ",DDUCRFE
63 .. S DDUCRFEP=DDUCRFE
64 .. Q
65 . S DDUCRFEP=0
66 . Q
Note: See TracBrowser for help on using the repository browser.