source: IHS-VA_UTILITIES-XB/XBCDIC.m@ 641

Last change on this file since 641 was 641, checked in by Sam Habiel, 15 years ago

Initial commit of XB, move away from sf.net.
Includes kids file and documentation.
File size: 6.8 KB
Line 
1XBCDIC ; IHS/ADC/GTH - CLEAN UP ^DIC AND ^DD ; [ 02/07/97 3:02 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4 ; PROGRAMMERS NOTE:
5 ; THIS FUNCTIONALITY HAS BEEN INCLUDED IN THE FILEMAN
6 ; DD UTILITIES, BEGINNING WITH V 19.0. WE RECOMMEND
7 ; IT'S USE AS IT IS MORE LIKELY TO BE CURRENT.
8 ; 3-20-96
9 ;
10 ; This routine cleans up ^DIC and ^DD by a range of
11 ; dictionary numbers. All files in ^DIC within the range
12 ; of dictionary numbers are checked for the following:
13 ;
14 ; They must have a NAME in ^DIC.
15 ; The NAME in ^DIC must match the NAME in ^DD.
16 ; The NAME must exist in ^DIC("B" with the correct number,
17 ; and that number cannot occur more than once in ^DIC("B".
18 ; They must have a data global specified in ^DIC.
19 ; The data global must be in the correct form.
20 ; The data global must exist.
21 ; The data global must have a 0th node.
22 ; The NAME and NUMBER in the data global must match ^DIC.
23 ; The data globals 0th node must be consistent with
24 ; the data (Exact count not checked).
25 ;
26 ; They must have valid entries in ^DD as follows:
27 ; The ^DD entry must have a .01 field.
28 ; All "SB" pointers must point to existing sub-files.
29 ; All sub-files must point back to correct parent.
30 ; All "TRB" entries must exist.
31 ; All "PT" entries must exist.
32 ; All "ACOMP" entries must exist.
33 ;
34 ; When discrepancies are found the entries are corrected
35 ; automatically where ever possible. If this is not possible
36 ; operator interaction occurs to make the corrections. If
37 ; the file cannot be corrected, it will be deleted.
38 ;
39 ; After all dictionaries within the range of dictionary
40 ; numbers are checked, all other entries within the range
41 ; will be deleted.
42 ;
43 ; The last step is to set the 0th node of the FILE OF FILES
44 ; to the correct high DFN and the correct count of entries.
45 ;
46BEGIN ;
47 S U="^"
48 W !!,"THIS FUNCTIONALITY HAS BEEN INCLUDED IN THE FILEMAN"
49 W !,"DD UTILITIES, BEGINNING WITH V 19.0. WE RECOMMEND"
50 W !,"IT'S USE AS IT IS MORE LIKELY TO BE CURRENT."
51 W !," 3-20-96",!!
52 Q:'$$DIR^XBDIR("E")
53 W !!,"This routine cleans up ^DIC and ^DD by a range of dictionary numbers."
54LO ;
55 R !!,"Enter low number of range: ",XBCDLO:$G(DTIME,999)
56 G:XBCDLO'=+XBCDLO EOJ
57HI ;
58 R !,"Enter high number of range: ",XBCDHI:$G(DTIME,999)
59 S:XBCDHI="" XBCDHI=XBCDLO
60 G:XBCDHI'=+XBCDHI!(XBCDHI<XBCDLO) EOJ
61 I XBCDLO<2 W !!,"*** Don't mess with files less than 2!! ***",*7 G EOJ
62 S XBDSLO=XBCDLO,XBDSHI=XBCDHI
63 D EN1^XBDSET
64 I '$D(^UTILITY("XBDSET",$J)) W !!,"No dictionaries were selected!" G EOJ
65 D ^XBCDIC2 ; Check names and data globals *****
66 D ^XBCDICD ; Delete bad files found by ^XBCDIC2 *****
67 S XBDSLO=XBCDLO,XBDSHI=XBCDHI
68 D EN1^XBDSET ; Get list again *****
69 D ^XBCDIC3 ; Check ^DD entries *****
70 S XBRLO=XBCDLO,XBRHI=XBCDHI
71 D EN1^XBRESID ; Check dangling ^DD entries *****
72 W !!,"Now confirming ^DIC(""B"")"
73 S XBCDX=""
74 F XBCDL=0:0 S XBCDX=$O(^DIC("B",XBCDX)) Q:XBCDX="" S XBCDFILE="" F XBCDL=0:0 S XBCDFILE=$O(^DIC("B",XBCDX,XBCDFILE)) Q:XBCDFILE="" I XBCDFILE'<XBCDLO,XBCDFILE'>XBCDHI W "." D BCHK
75 S XBCDFILE=XBCDLO-.00000001
76 F XBCDL=0:0 S XBCDFILE=$O(^DIC(XBCDFILE)) Q:XBCDFILE'=+XBCDFILE I XBCDFILE'>XBCDHI W "." S XBCDNDIC=$P(^DIC(XBCDFILE,0),U,1) I XBCDNDIC]"",'$D(^DIC("B",XBCDNDIC,XBCDFILE)) S ^(XBCDFILE)="" W "|"
77 G EOJ
78 ;
79BCHK ;
80 I '$D(^DIC(XBCDFILE,0))#2 KILL ^DIC("B",XBCDX,XBCDFILE) W "|" Q
81 I XBCDX'=$P(^DIC(XBCDFILE,0),U,1) KILL ^DIC("B",XBCDX,XBCDFILE) W "|"
82 Q
83EOJ ;
84 KILL XBCDLO,XBCDHI,XBCDUCI,XBCDL,XBCDFILE,XBCDX,XBCDNDIC
85 KILL ^UTILITY("XBDSET",$J)
86 Q
87 ;
88 W !,"Package ",XBBPPRFX," has no pre-initialization routine entry!",!
89 Q
90 ;
91EOJ3 ;
92 KILL ^UTILITY("XBBPI",$J),^UTILITY("XBBPPGM",$J),^UTILITY("XBBPI EXEC",$J)
93 KILL %,%DT,DIE,XCN
94 KILL XBBPDFN,XBBPFLE,XBBPFLG,XBBPI,XBBPL,XBBPP,XBBPPGM,XBBPPRFX,XBBPX,XBBPY
95 Q
96 ;
97DTA ;
98 ;; K ^UTILITY("XBDSET",$J) F XBBPI=1:1 S XBBPIX=$P($T(Q+XBBPI),";;",2) Q:XBBPIX="" S XBBPIY=$P(XBBPIX,"=",2,99),XBBPIX=$P(XBBPIX,"=",1) S @XBBPIX=XBBPIY
99 ;; K XBBPI,XBBPIX,XBBPIY D EN2^XBKD
100 ;;Q Q
101 ; ex: D to denote DUZ
102 ; '|' Separator
103 ;
104 ; variable1 User's choice of the local variable
105 ; ex: DUZ
106 ; '*' Repetative marker if more than one
107 ; mnemonic is indicated
108 ;
109 ; USE The mnemonic reference can be used any where
110 ; in the WP form.
111 ; Format ~mnemonic|variable subscript~
112 ;
113 ; '~' Beginning marker for the variable
114 ;
115 ; mnemonic1 User's mnemonic
116 ;
117 ; '|' Separator
118 ;
119 ; subscript The subscript of the variable to be used
120 ;
121 ; '~' Ending marker for the variable
122 ;
123 ; ex: ~D|~ for DUZ
124 ; ~D|0~ for DUZ(0)
125 ; ~I|.01~ for BARIPT(.01)
126 ;
127 ; MUMPS OUTPUT A simple mumps output transform is also
128 ; TRANSFORM provided to aid in form design. A variable or
129 ; mnemonic indicated will have its output
130 ; transformed prior to being put into the form.
131 ;
132 ; SETUP
133 ;
134 ; *var1!mumps code1*var2!mumps code2
135 ; *mnemonic3!mumps code3*mnemonic4!mumps code4
136 ;
137 ; Ex: *DUZ(2)!$J(X,10,2) will output $J(DUZ(2),10,2)
138 ; *D|2!$J(X,10,2) mnemonic notation of same
139 ;
140 ; '*' Output Transform marker in column one. At TOF
141 ;
142 ; Variable/ Variable or mnemonic as it would appear in the
143 ; Mneumonic form between '~'s.
144 ;
145 ; '!' Separator
146 ;
147 ; mumps code Mumps code expression as a function of x.
148 ; Do not state 'S X=f(x)'
149 ; Enter the function only, f(x).
150 ;
151 ; '*' Separator if more than one is put on one line.
152 ;
153 ; SPECIAL OUTPUT TRANSFORMS provided by XBARRAY
154 ;
155 ; xxx!$$MDY(X) a literal ~"NOW"~ or variable ~IT|9~
156 ; ex: *"NOW"!$$MDY(X) or *IT|9!$$MDY(X)
157 ; returns mm/dd/yy
158 ;
159 ; xxx!$$WP("X") for a word processing field
160 ; NOTE: "X" IS ABSOLUTELY NECESSARY
161 ; The variable array must have the form
162 ; VAR(subcript,n) where n = 1:1
163 ;
164DOCE ;
165 ;
166TEST ; If you have A/R installed, uncomment the following lines for a
167 ; demonstration.
168 ; D INIT^BARUTL
169 ; D ENP^XBDIQ1(200,DUZ,".01:.116","BARU(")
170 ; S BARFORM="PW TEST"
171 ; D EDIT^XBARRAY(.BARFORM,90053.01,1000)
172 ; S Y=$$GEN^XBARRAY(.BARFORM,90053.01,1000,"BARFM",0,10)
173 ; K BARFORM(BARFORM)
174 ; Q
175 ;
176 NEW I,W
177 S XBLWP=$G(XBLLINE),W=$P(X,")")
178 F I=0:1 S X=$Q(@X) Q:X="" Q:(W'=$P(X,",")) D
179 . S T=@X,XBLLINE=XBLWP+I
180 . S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
181 . S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
182 Q ""
183 ;
Note: See TracBrowser for help on using the repository browser.