source: BMXNET_RPMS_dotNET_UTILITIES-BMX/trunk/m/BMXADOS.m@ 1181

Last change on this file since 1181 was 1087, checked in by Sam Habiel, 14 years ago

BMX updated to v2.3. No actual routine changes from 2.21
File size: 9.5 KB
Line 
1BMXADOS ; IHS/CIHA/GIS - UPDATE THE BMX ADO SCHEMA FILE ; 12/7/10 4:07pm
2 ;;2.3;BMX;;Jan 25, 2011
3 ; ENABLES NAVIGATION TO SUBFILES PRIOR TO UPDATING THE SCHEMA FILE ENTRY
4 ;
5 ; Change log:
6 ; Sam Habiel - 3101212 v2.21
7 ; - Changed the quit from the line in ASTG b/c it couldn't compile in GT.M
8 ; F PCE=1:1:LEV S FNO=+$P(STG,",",PCE) D I '$L(STG) Q "" **OLD**
9 ; F PCE=1:1:LEV S FNO=+$P(STG,",",PCE) D Q:'$L(STG) ; v 2.21 SMH
10 ;
11 ;
12 ;
13UPDATE ; UPDATE THE SCHEMA FILE
14 N DIC,X,Y,%,STOP,FIEN,FNAME,SNAME,SIEN
15UDIC S DIC("A")="Enter schema name: " ; EP FROM VENPCCTU
16 S DIC(0)="AEQLM",DIC="^BMXADO("
17 D ^DIC I Y=-1 G FIN
18SCHEMA S SNAME=$P(Y,U,2),SIEN=+Y
19 S FIEN=$$FILE(SIEN) I 'FIEN G FIN
20 I FIEN'=$P($G(^BMXADO(SIEN,0)),U,2) S DIE=DIC,DA=SIEN,DR=".02////^S X=FIEN" D ^DIE
21 F D FLD(FIEN,SIEN) I $G(STOP) Q ; GET FIELD INFO
22FIN D ^XBFMK
23 Q
24 ;
25FLD(FIEN,SIEN) ; GET THE FIELD
26 N DIC,X,Y,DIE,DA,DR,FLDIEN,FLDNAME,FLDTYPE,FDEF,TRANS
27 N %,%Y,HDR,DTYPE,LEN,FARR,I,TOT,PAUSE,PFLAG,IFLAG,IMSG,STG,READ
28 D FLIST(.FARR,FIEN,0)
29 S TOT=$O(FARR(9999),-1) I 'TOT S STOP=1 Q
30 W !,"Select a field from this "_$S($D(^DD(FIEN,0,"UP")):"sub-",1:"")_"file: "
31 S I=0 F S I=$O(FARR(I)) Q:'I S PAUSE=$$PAUSE(I) Q:PAUSE'="" W I,?3,FARR(I)
32 I $G(PAUSE)=U S STOP=1 Q
33 I $G(PAUSE) S Y=PAUSE G FLD1
34 S DIR(0)="NO^1:"_TOT_":",DIR("A")="Select a field from the list" K DA D ^DIR K DIR
35 I 'Y S STOP=1 Q
36FLD1 S %=FARR(+Y)
37 S FLDIEN=+$P(%," [",2),FLDNAME=$P(%," [")
38 I $$FDEL(SIEN,FLDIEN) Q ; FIELD DELETED
39 S X=$$FDEF(FIEN,FLDIEN) I '$L(X) W " ??" Q
40 S DTYPE=$E(X),LEN=+$E(X,2,6)
41 S DIR(0)="F^1:30",DIR("A")="Column header",DIR("B")=FLDNAME D ^DIR K DIR
42 S HDR=Y,TRANS=0
43 S %=$P($G(^DD(FIEN,FLDIEN,0)),U,2) ; CHECK FM DD TO SEE IF FIELD IS REQUIRED
44 I %["R" W !,"FileMan requires a non-null value for this field" S %=2
45 E W !,"Is null allowed" S %=$S(FLDIEN=.01:2,1:1) D YN^DICN I %Y?1."^" Q
46 I %=2 S TRANS=1 ; NON NULL VALUE REQUIRED TO COMPLETE THE TRANSACTION OR THERE WILL BE ROLLBACK
47 I $G(PFLAG) D ; IF POINTER, ASK IF USER WANTS TO AUTOMATICALLY INSERT THE LOOKUP VALUE FIELD IN THE SCHEMA
48 . W !,"This field is a pointer value (IEN)."
49 . W !,"Want to automatically insert the lookup value in the schema"
50 . S %=2 D YN^DICN W ! I %=1 S PFLAG=2
51 . Q
52IFLG I $G(IFLAG) D ; NON-POINTER .01 FIELD. ASK IF USER WANTS TO REFERENCE IDENTIFIER EP
53 . W !,"Want to display identifiers with this field"
54 . S %=2 D YN^DICN W ! I %'=1 Q
55 . S IMSG="Respond with a valid entry point in the format 'TAG^ROUTINE'."
56 . W !,"Entry Point to generate Identifiers: " R Y:$G(DTIME,60) E Q
57 . I Y?1."^" Q
58 . I Y?1."?" W !,IMSG S IFLAG(0)="!" Q
59 . I Y'?1U.7UN1"^"1U.7UN S IFLAG(0)="!" W " ??"
60 . I $L(Y)>2 S IFLAG(0)=Y,IFLAG=2
61 . Q
62 I $G(IFLAG(0))="!" W !,IMSG K IPFLAG(0),IMSG W !!! G IFLG
63 S DA(1)=SIEN,DIC="^BMXADO("_DA(1)_",1,"
64 S DIC("P")=90093.991,DIC(0)="L",X=FLDIEN
65 I '$D(^BMXADO(SIEN,1,0)) S ^BMXADO(SIEN,1,0)="^90093.991^^"
66 D ^DIC I Y=-1 Q
67 S READ=($P($G(^DD(FIEN,FLDIEN,0)),U,2)["C") ; COMPUTED FIELDS ARE READ ONLY!
68 S DIE=DIC,DA=+Y
69 S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)"
70 D ^DIE
71 I $G(IFLAG)=2 D ID
72 I $G(PFLAG)'=2 Q
73LKUP ; AUTOMATICALLY ADD A LOOKUP FIELD TO THE SCHEMA
74 S X=FLDIEN_"IEN"
75 D ^DIC I Y=-1 Q
76 W !,"The LOOKUP field '"_X_"' has been added to the schema",!
77 S HDR=HDR_"_IEN",DTYPE="I",LEN="00009"
78 S DIE=DIC,DA=+Y
79 S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)"
80 D ^DIE
81 Q
82 ;
83ID ; AUTOMATICALLY ADD AN IDENTIFIER REFERENCE
84 N X,Y,DIE,DR,DA,REF
85 S X=".01ID",DA(1)=SIEN
86 S REF=IFLAG(0) I '$L(REF) Q
87 D ^DIC I Y=-1 Q
88 W !,"The identifier field '"_X_"' has been added to the schema",!
89 S HDR=HDR_"_ID",DTYPE="T",LEN="00017"
90 S DIE=DIC,DA=+Y
91 S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS);1///^S X=REF"
92 D ^DIE
93 Q
94 ;
95FDEL(SIEN,FIELD) ; DELETE AN EXISTING ENTRY FROM THE 'FIELD' MULTIPLE. RETURN '1' IF THE RECORD WAS DELETED
96 N FIEN,DA,DIK
97 S FIEN=$O(^BMXADO(SIEN,1,"B",FIELD,0)) I 'FIEN Q 0 ; THIS IS A NEW ENTRY
98 W !,"This field already is attached to the schema. Want to delete it"
99 S %=2 D YN^DICN
100 I %'=1 Q 0
101 S DA(1)=SIEN,DIK="^BMXADO("_DA(1)_",1,",DA=FIEN
102 D ^DIK
103 S FIEN=$O(^BMXADO(SIEN,1,"B",(FIELD_"IEN"),0))
104 I FIEN S DA=FIEN D ^DIK ; DELETE LOOKUP VALUE FIELD AS WELL
105 W " Done!",!
106 Q 1
107 ;
108FDEF(FILE,FIELD) ;EP - GIVEN A FILEMAN FILE AND FIELD, RETURN THE DATA DEFINITION IN ADO FORMAT
109 N %,X,Y,Z,STG,I,DTYPE,FNAME,LEN,DNAME
110 I '$D(^DD(+$G(FILE),+$G(FIELD),0)) Q ""
111 S STG=$G(^DD(FILE,FIELD,0)) I '$L(STG) Q "" ; GET DATA DEF STRING
112DTYPE S %="DNSFWCPVM",X=$P(STG,U,2),DTYPE="" ; GET DATA TYPE
113 F I=1:1:$L(%) S Y=$E(%,I) I X[Y S DTYPE=Y Q
114 I DTYPE="" Q ""
115FNAME S DNAME=$P(STG,U) I '$L(DNAME) Q "" ; FIELD NAME
116DDA ; ADO FORMAT
117 I DTYPE="D" D Q "D"_LEN_DNAME
118 . S LEN="00021"
119 . I STG["S %DT=" S %=$P(STG,"S %DT=",2),%=$P(%,$C(34))
120 . I $G(FLDIEN)=.01 S IFLAG=1
121 . I %["S" S LEN="00019" Q
122 . I %["T" S LEN="00018" Q
123 . Q
124 I DTYPE="N",STG["1N.N" D Q:'LEN "" Q "I"_LEN_DNAME ; INTEGER
125 . S %=+$P(STG,"K:+X'=X!(X>",2)
126 . S Y=$L(%)
127 . S LEN=$E("00000",1,5-$L(Y))_Y
128 . Q
129 I DTYPE="N" D Q:'LEN "" Q "N"_LEN_DNAME ; NUMBER (COULD HAVE A DECIMAL VALUE)
130 . S %=+$P(STG,"!(X?.E1"".""",2)
131 . S X=+$P(STG,"K:+X'=X!(X>",2)
132 . S Y=%+($L(+X))
133 . S LEN=$E("00000",1,5-$L(Y))_Y
134 . Q
135 I DTYPE="F" D Q:'LEN "" Q "T"_LEN_DNAME
136 . S Y=+$P(STG,"K:$L(X)>",2)
137 . S LEN=$E("00000",1,5-$L(Y))_Y
138 . I 'LEN S LEN="00030"
139 . I $G(FLDIEN)=.01 S IFLAG=1
140 . Q
141 I DTYPE="S" D Q:'LEN "" Q "T"_LEN_DNAME
142 . S X=$P(STG,U,3),Y=0
143 . F I=1:1:$L(X,":") S Z=$P(X,":",2),Z=$P(Z,";"),%=$L(Z) I %>Y S Y=%
144 . S LEN=$E("00000",1,5-$L(Y))_Y
145 . Q
146 I DTYPE="P" S PFLAG=1 Q "T00030"_DNAME
147 I DTYPE="W" Q "T05000"_DNAME
148 I DTYPE="V" Q ""
149 Q "T00250"_DNAME
150 ;
151FILE(SIEN) ; GET THE FILE OR SUBFILE NUMBER
152 N FNO,FIEN,DIC,X,Y,%,FILE,NSTG,GBL,FNAME,SUB,FARR,TOT,I
153 S (FILE,FNO)=$P(^BMXADO(SIEN,0),U,2)
154OLD I FNO D I $G(FIEN) Q FIEN
155 . S NSTG=$O(^DD(FNO,0,"NM",""))
156 . F S FNO=$G(^DD(FNO,0,"UP")) Q:'FNO S NSTG=$O(^DD(FNO,0,"NM",""))_"/"_NSTG
157OLD1 . W !,$S(NSTG["/":"Sub-",1:""),"File #",FILE," (",NSTG,") is linked to this schema."
158 . W !,"Want to keep it" S %=1
159 . D YN^DICN I %'=2 W:%=1 " OK" S FIEN=FILE Q
160 . W !!,"If you change or delete this file number,",!,"all the information in this schema will be deleted."
161 . W !,"Are you sure you want to do this" S %=2 D YN^DICN
162 . I %'=1 W !! G OLD1
163 . S GBL="^BMXADO("_SIEN_")"
164 . K @GBL@(1),@GBL@(2)
165 . S $P(@GBL@(0),U,2)=""
166 . W !,"This schema definition has been deleted. You may redefine it now"
167 . Q
168NEW S DIC=1,DIC(0)="AEQM" D ^DIC I Y=-1 Q ""
169 S FNO=+Y,FNAME=$P(Y,U,2)
170NEW1 D SC(.FARR,FNO,1)
171 S TOT=$O(FARR(999999),-1) I 'TOT Q FNO ; NO SUBFILES FOUND
172 W !!,"The ",FNAME," file contains the following sub-file" I TOT>1 W "s"
173 W !
174 S I=0 F S I=$O(FARR(I)) Q:'I S PAUSE=$$PAUSE(I) Q:PAUSE'="" W I,?3,FARR(I)
175 I $G(PAUSE)=U Q ""
176 I $G(PAUSE) S Y=PAUSE G NEW2
177 W !!,"Is the schema linked to a sub-file in this list"
178 S %=2 D YN^DICN I %=2 Q FNO
179 S DIR(0)="NO^1:"_TOT_":",DIR("A")="Select a sub-file from the list" K DA D ^DIR K DIR
180 I 'Y Q ""
181NEW2 Q +$P(FARR(+Y)," (",2)
182 ;
183PAUSE(I) ; SCROLL CHECK
184 N %
185 W !
186 I (I#20) Q ""
187 W "Select a number from the list (1-",(I-1),") or press <ENTER> to continue: "
188 R %:$G(DTIME,60) E Q ""
189 I %?1."^" Q U
190 I $L(%),$D(FARR(I)) Q %
191 I $L(%) W " ??" H 2
192 W $C(13),?79,$C(13)
193 Q ""
194 ;
195SC(OUT,FILE,MODE) ;EP - SUB CRAWLER. GIVEN A FILE NUMBER RETURN ALL OF ITS DESCENDANT FILES IN AN ARRAY
196 I '$D(^DD(FILE,"SB")) Q ; NO DESCENDANTS
197 N TOT,FNO,FNAME,FIEN,LEVEL,NODE,SARR,STG,X,%,UP,ARR
198 S FIEN=FILE,TOT=0
199 D PASS1
200 I '$O(ARR(0)) Q
201SC2 ; SECOND PASS. BUILD THE INTERMEDIATE ARRAY
202 S FNO=0 F S FNO=$O(ARR(FNO)) Q:'FNO D
203 . I $P($G(^DD(FNO,.01,0)),U,2)["W" K ARR(FNO) Q ; WORD PROCESSING FIELDS DO NOT COUNT
204 . S STG=FNO,UP=FNO
205 . F S UP=$G(^DD(UP,0,"UP")) Q:'UP S STG=UP_","_STG ; BUILD DESCENDANT STRING
206 . I $G(MODE) S STG=$$ASTG(STG)
207 . S STG=$P(STG,",",2,99) ; DONT NEED TOP LEVEL FILE
208 . I '$L(STG) Q ; SOMETHING IS SCREWED UP
209 . S LEVEL=$L(STG,",")
210 . S FNAME=$O(^DD(FNO,0,"NM",""))
211 . S X="SARR("_STG_")"
212 . S @X=FNAME_U_LEVEL_U_FNO
213 . K ARR(FNO)
214 . Q
215SC3 ; 3RD PASS. BUILD OUTPUT ARAY
216 S NODE="SARR"
217 F S NODE=$Q(@NODE) Q:NODE="" D
218 . S X=@NODE
219 . S TOT=TOT+1
220 . S FNAME=$P(X,U)
221 . S LEVEL=$P(X,U,2)
222 . S FNO=$P(X,U,3)
223 . S OUT(TOT)=$E(" ",1,LEVEL)_FNAME_" ("_FNO_")"
224 . Q
225 Q
226 ;
227PASS1 ; PASS 1. BUILD THE ARRAY OF ALL SUBFILES
228 N FNO S FNO=0
229 F S FNO=$O(^DD(FIEN,"SB",FNO)) Q:'FNO D
230 . S ARR(FNO)=""
231 . I '$D(^DD(FNO,"SB")) Q
232 . N FIEN S FIEN=FNO
233 . D PASS1 ; RECURSION!!
234 . Q
235 Q
236 ;
237ASTG(STG) ; CONVERT STRING FROM FILE NUMBERS TO FILE NAMES
238 N PCE,LEV,FNO,NAME
239 S LEV=$L(STG,",")
240 F PCE=1:1:LEV S FNO=+$P(STG,",",PCE) D Q:'$L(STG) ; v 2.21 SMH
241 . S NAME=$O(^DD(FNO,0,"NM",""))
242 . I $E(NAME)="*" S NAME=$E(NAME,2,99)
243 . I '$L(NAME) S STG="" Q
244 . S $P(STG,",",PCE)=""""_NAME_""""
245 . Q
246 Q STG
247 ;
248FLIST(OUT,FILE,MODE) ;EP - GIVEN A FILE RETURN THE FILEDS IN AN ARRAY MODE=0: NUMERIC ORDER, MODE=1: ALPHA ORDER
249 ; ONLY NON MULTIPLES AND WORD PROCESSING FIELDS ARE LISTED
250 N FLD,TOT,NAME,ARR,SS,%,WP
251 S FLD=0,TOT=0
252F1 F S FLD=$O(^DD(FILE,FLD)) Q:'FLD D ; PASS 1
253 . S STG=$G(^DD(FILE,FLD,0)) I '$L(STG) Q
254 . S %=$P(STG,U,2)
255 . I %,$P($G(^DD(%,.01,0)),U,2)'["W" Q ; EXCLUDE ALL MULTIPLE FIELDS EXCEPT WORD PROCESSING FIELDS
256 . S WP=0 I % S WP=1
257 . S NAME=$P(STG,U)
258 . S SS=FLD
259 . I $G(MODE)=1 S %=NAME S:$E(%)="*" %=$E(%,2,99) S SS=%
260 . S ARR(SS)=FLD_U_NAME_U_WP
261 . Q
262F2 S SS=""
263 F S SS=$O(ARR(SS)) Q:SS="" D
264 . S TOT=TOT+1
265 . S %=ARR(SS)
266 . S OUT(TOT)=$P(%,U,2)_" ["_+%_"]"_$S($P(%,U,3):" (word processing)",1:"")
267 . K ARR(SS)
268 . Q
269 Q
270 ;
Note: See TracBrowser for help on using the repository browser.