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

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

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1DDFIX ;SFCIOFO/S0/MKO VARIOUS DD AND DIC FIXES ;9:17 AM 15 Mar 1999
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5FIXPT ; ==> Fix Bad "PT" Nodes <==
6 ;
7 N EP,ESC
8 I '$D(XPDNM) S EP="PT" D DEVICE
9 I $D(ESC) G EXIT
10DEQPT N DICFILE,DDFILE,DDFIELD,PGLEN,PG,RPTDT,X
11 U IO
12 D RPTDT
13 S PGLEN=IOSL-5,PG=0
14 I '$D(XPDNM) D PTHDR
15 ; Loop thru DIC(<file #>,
16 S DICFILE=1.99999
17 F S DICFILE=$O(^DIC(DICFILE)) Q:DICFILE'>1.99999!$D(ESC) D
18 . ; Loop thru DD(DICFILE,0,"PT",<file #>
19 . S DDFILE=1.99999
20 . F S DDFILE=$O(^DD(DICFILE,0,"PT",DDFILE)) Q:DDFILE'>1.99999!$D(ESC) D
21 .. I $D(^DD(DDFILE,0))#2 D Q ; File Exists
22 ... ; Check Fields Exists
23 ... S DDFIELD=0
24 ... F S DDFIELD=$O(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) Q:'DDFIELD!$D(ESC) D
25 .... I $D(^DD(DDFILE,DDFIELD,0))#2 D Q ; Field is still in DD
26 ..... I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D Q ; Field Still A Pointer?
27 ...... S X="*File: "_DDFILE_" Field: "_DDFIELD_" is Not a Pointer Type." D RPTOUT
28 ...... S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q
29 ..... I $P(^(0),U,2)["P",+$P($P(^(0),U,2),"P",2)'=DICFILE D Q ; Field Still Point To Same File?
30 ...... S X="*File: "_DDFILE_" Field: "_DDFIELD_" Does Not Point To File: "_DICFILE_"." D RPTOUT
31 ...... S X=" Deleting ""PT"" Node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q
32 .... ; **Field No Longer Exists
33 .... S X="*Field: "_DDFIELD_" in File: "_DDFILE_" does Not Exist." D RPTOUT
34 .... S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q
35 .. ; **File No Longer Exists
36 .. S X="*File: "_DDFILE_" Does Not Exist." D RPTOUT
37 .. S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE)) D RPTOUT
38 .. K ^DD(DICFILE,0,"PT",DDFILE)
39 G EXIT ; GoTo Common Exit
40K1 ; Kill at Field Level
41 K ^DD(DICFILE,0,"PT",DDFILE,DDFIELD)
42 Q
43PTHDR ; Fix "PT" nodes Report Header
44 I $E(IOST,1,2)="C-" D Q:$D(ESC)
45 . I PG D PAUSE Q:$D(ESC)
46 . W @IOF
47 I PG W @IOF
48 S PG=PG+1
49 W "Fix ""PT"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,!
50 N X
51 S X="",$P(X,"-",(IOM-1))="" W X,!
52 Q
53 ;
54FIXNM ; ==> Fix Duplicate 'NM' Nodes <==
55 ; From patch DI*21*50, routine DIPR50
56 ;
57 N EP,ESC
58 I '$D(XPDNM) S EP="NM" D DEVICE
59 I $D(ESC) G EXIT
60DEQNM N DDFILE,DDNAME,DDNEW,PGLEN,PG,RPTDT,X
61 U IO
62 D RPTDT
63 S PGLEN=IOSL-5,PG=0
64 I '$D(XPDNM) D NMHDR
65 S DDFILE=1.99999
66 F S DDFILE=$O(^DD(DDFILE)) Q:'DDFILE!$D(ESC) D
67 . ; Check and repair duplicate "NM" nodes
68 . S DDNAME=$O(^DD(DDFILE,0,"NM","")) Q:DDNAME=""
69 . I $O(^DD(DDFILE,0,"NM",DDNAME))="" Q
70 . S X="*File/Subfile: "_DDFILE_" has duplicate 'NM' nodes."
71 . D RPTOUT
72 . S DDNEW=$S($D(^DIC(DDFILE,0))#2:$P(^(0),U),1:$P(^DD(DDFILE,0)," SUB-FIELD"))
73 . Q:DDNEW=""
74 . K ^DD(DDFILE,0,"NM")
75 . S ^DD(DDFILE,0,"NM",DDNEW)=""
76 . S X=" ""NM"" node will be set to: "_DDNEW
77 . D RPTOUT
78 G EXIT ; GoTo Common Exit Point
79NMHDR ; Fix "NM" nodes Report Header
80 I $E(IOST,1,2)="C-" D Q:$D(ESC)
81 . I PG D PAUSE Q:$D(ESC)
82 . W @IOF
83 I PG W @IOF
84 S PG=PG+1
85 W "Fix Duplicate ""NM"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,!
86 N X
87 S X="",$P(X,"-",(IOM-1))="" W X,!
88 Q
89 ;
90FIXAG ; ==> Application Group Multiple Bad Xrefs <==
91 ; From patch DI*21*58, routine DIPR58
92 ;
93 N EP,ESC
94 I '$D(XPDNM) S EP="AG" D DEVICE
95 I $D(ESC) G EXIT
96DEQAG N DDAGPKG,DDFILE,IEN,PGLEN,PG,RPTDT,X
97 U IO
98 D RPTDT
99 S PGLEN=IOSL-5,PG=0
100 I '$D(XPDNM) D AGHDR
101 S DDFILE=1.99999
102 F S DDFILE=$O(^DIC(DDFILE)) Q:DDFILE<1.99999 D
103 . I '$D(^DIC(DDFILE,"%")) Q ; No App. Group Multiple
104 . S DDAGPKG=""
105 . F S DDAGPKG=$O(^DIC(DDFILE,"%","B",DDAGPKG)) Q:DDAGPKG="" D
106 .. S IEN=0
107 .. F S IEN=$O(^DIC(DDFILE,"%","B",DDAGPKG,IEN)) Q:'IEN D
108 ... I $P($G(^DIC(DDFILE,"%",IEN,0)),U)=DDAGPKG Q
109 ... S X="Deleting App. Group "_DDAGPKG_" ""B"" xref: "_$NA(^DIC(DDFILE,"%","B",DDAGPKG,IEN))
110 ... D RPTOUT
111 ... K ^DIC(DDFILE,"%","B",DDAGPKG,IEN)
112AC ; Loop Thru "AC" xref and Remove Any Entries That Point to
113 ; Files That Do Not Exist
114 S DDAGPKG=""
115 F S DDAGPKG=$O(^DIC("AC",DDAGPKG)) Q:DDAGPKG="" D
116 . S DDFILE=1.99999
117 . F S DDFILE=$O(^DIC("AC",DDAGPKG,DDFILE)) Q:DDFILE<1.99999 D
118 .. I $D(^DIC(DDFILE,0))[0 D Q
119 ... S X="Deleting ""AC"" xref: "_$NA(^DIC("AC",DDAGPKG,DDFILE))
120 ... D RPTOUT
121 ... K ^DIC("AC",DDAGPKG,DDFILE)
122 .. S IEN=0
123 .. F S IEN=$O(^DIC("AC",DDAGPKG,DDFILE,IEN)) Q:'IEN D
124 ... I $P($G(^DIC(DDFILE,"%",IEN,0)),U)'=DDAGPKG D
125 .... S X="Deleting ""AC"" xref: "_$NA(^DIC("AC",DDAGPKG,DDFILE,IEN))
126 .... D RPTOUT
127 .... K ^DIC("AC",DDAGPKG,DDFILE,IEN)
128 G EXIT ; GoTo Common Exit Point
129AGHDR ; Fix Application Group Xrefs Report Header
130 I $E(IOST,1,2)="C-" D Q:$D(ESC)
131 . I PG D PAUSE Q:$D(ESC)
132 . W @IOF
133 I PG W @IOF
134 S PG=PG+1
135 W "Fix Application Group Xrefs Report "_RPTDT,?(IOM-10),"Page: "_PG,!
136 N X
137 S X="",$P(X,"-",(IOM-1))="" W X,!
138 Q
139 ;
140 ; Common For All Entry Points
141 ;
142DEVICE ; Output Device Selection
143 S %ZIS="MQ"
144 D ^%ZIS
145 I POP S ESC=1 Q ;User Escaped Device Selection
146 I $D(IO("Q")) D
147 . S ZTDESC=$S(EP="PT":"FIX PT NODES",EP="NM":"FIX DUPLICATE 'NM' NODES",EP="AG":"FIX APPLICATION GROUP XREFS",1:"")
148 . S ZTRTN=$S(EP="PT":"DEQPT",EP="NM":"DEQNM",EP="AG":"DEQAG",1:"")_"^DDFIX"
149 . S ZTSAVE("EP")=""
150 . D ^%ZTLOAD
151 . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
152 . S ESC=1
153 . K ZTSK,ZTDESC,ZTRTN,ZTSAVE
154 . D HOME^%ZIS
155 Q
156RPTDT ; Get Report Date/Time
157 N %,%H,X,Y
158 S %H=$H
159 D YX^%DTC
160 S RPTDT=$P(Y,"@")_"@"_$E($P(Y,"@",2),1,5)
161 Q
162RPTOUT ; Print Messages
163 I $D(XPDNM) D MES^XPDUTL(X) Q ; KIDS install being used
164 W X,! ; KIDS install not being used
165 I $Y'>PGLEN Q
166 I EP="PT" D PTHDR Q
167 I EP="NM" D NMHDR Q
168 I EP="AG" D AGHDR Q
169 Q
170PAUSE ; End of Page Pause
171 N DIR,Y
172 S DIR(0)="E"
173 D ^DIR
174 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) K DTOUT,DUOUT,DIRUT,DIROUT S ESC=1 Q
175 Q
176EXIT ; Common Exit Point
177 I $E(IOST,1,2)="P-" D ^%ZISC
178 I $D(ZTQUEUED) S ZTREQ="@"
179 K EP
180 Q
Note: See TracBrowser for help on using the repository browser.