source: IHS-VA_UTILITIES-XB/trunk/XBFLD.m@ 811

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

Modified directory structure; moved routines.
File size: 5.8 KB
RevLine 
[641]1XBFLD ; IHS/ADC/GTH - DICTIONARY LISTING ; [ 02/07/97 3:02 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4 ; This routine lists dictionaries which may be selected
5 ; individually or by a range of dictionary numbers.
6 ;
7 ; This routine requires the 89 MUMPS Standard, FileMan
8 ; Version 17.7 or greater, Kernel Version 6 or greater, and
9 ; the following routines must exist in the UCI in which this
10 ; routine is running:
11 ;
12 ; XBKVAR, XBSFGBL
13 ;
14START ;
15 D LOOP ; List files until user says stop
16 D EOJ ; Clean up
17 Q
18 ;
19LOOP ; LIST FILES UNTIL USER SAYS STOP
20 NEW XBQFLG
21 W !,"^XBFLD - This routine lists FileMan dictionaries."
22 F D INIT Q:XBQFLG D LIST W ! D ^%ZISC Q:XBQFLG
23 Q
24 ;
25LIST ; LIST RANGE OF FILES
26 S:'$D(XBFMT) XBFMT=""
27 NEW XBCOMP,XBFILE,XBFIELD,XBLNFEED,XBNAME,XBPIECE,XBPAGE,XBPSUB,XBPSUBOL,XBSUBFIL,XBSUB,XBTAB,XBTYPE,XBWPC,XBWPSUB
28 S XBQFLG=0
29 F XBFILE=0:0 S XBFILE=$O(^UTILITY("XBDSET",$J,XBFILE)) Q:XBFILE="" D FILE Q:XBQFLG
30 Q
31 ;
32FILE ; LIST ONE FILE
33 S (XBCOMP,XBLNFEED,XBPAGE,XBTAB)=0,XBSUB="D0,",XBPSUBOL=""
34 D HEADING
35 D FIELDS
36 Q:XBQFLG
37 D PAUSE
38 Q
39 ;
40FIELDS ; LIST ALL FIELDS IN ONE FILE/SUBFILE (CALLED RECURSIVELY)
41 F XBFIELD=0:0 S XBFIELD=$O(^DD(XBFILE,XBFIELD)) Q:XBFIELD'=+XBFIELD D FIELD Q:XBQFLG
42 Q
43 ;
44FIELD ; LIST ONE FIELD
45 S (XBNAME,XBPIECE,XBPSUB,XBTYPE)=""
46 S X=^DD(XBFILE,XBFIELD,0)
47 S XBNAME=$P(X,U,1)
48 S Y=$P(X,U,2)
49 S XBTYPE=$S(+Y:"",Y["C":"C",Y["F":"F",Y["N":"N",Y["P":"P",Y["S":"S",Y["V":"V",Y["K":"K",Y["W":"W",Y["D":"D",1:"?")
50 I XBTYPE="C" D COMPUTED Q
51 I XBCOMP S XBCOMP=0 D WRITELF ; Extra lf after computed fields
52 I XBTYPE="" D MULTIPLE Q
53 S Y=$P(X,U,4)
54 S XBPSUB=XBSUB_$S($P(Y,";",1)=+$P(Y,";",1):$P(Y,";",1),1:""""_$P(Y,";",1)_"""")
55 S XBPIECE=$S(XBTYPE="K":" ",1:$P(Y,";",2)) ; MUMPS field has no piece
56 D WRITE
57 Q
58 ;
59COMPUTED ; COMPUTED FIELD
60 ; The variable XBCOMP prevents multiple lfs between adjacent
61 ; computed fields.
62 ;
63 D:'XBCOMP WRITELF
64 S XBPSUB="COMPUTED",XBTYPE="",XBCOMP=1
65 S XBPSUB=XBPSUB_$S(Y["B":" (BOOLEAN)",Y["D":" (DATE)",1:"")
66 D WRITE
67 Q
68 ;
69MULTIPLE ; LIST MULTIPLE, THEN FIELDS IN SUBFILE
70 S XBNAME=XBNAME_" ("_+Y_")",XBSUBFIL=+Y
71 D WRITELF,WRITE
72 Q:XBQFLG
73 NEW XBFILE,XBFIELD,XBSUB
74 S XBFILE=XBSUBFIL
75 D ^XBSFGBL(XBFILE,.XBSUB,2)
76 S XBSUB="D0"_$P(XBSUB,"D0",2),XBSUB=$P(XBSUB,")",1)
77 S XBTAB=XBTAB+2
78 D FIELDS ; Recurse
79 S XBTAB=XBTAB-2
80 Q:XBQFLG
81 D WRITELF
82 Q
83 ;
84WRITE ; WRITE ONE LINE
85 S XBLNFEED=0
86 D PAGE:$Y>(IOSL-3)
87 Q:XBQFLG
88 S XBWPSUB=$S(XBFIELD=.001:"",XBPSUB]""&(XBPSUB=XBPSUBOL):" """,1:XBPSUB)
89 S XBWPC=$S(XBPIECE:$J(XBPIECE,5,0),1:XBPIECE)
90 I (XBPSUB'["COMPUTED") W !?XBTAB,XBFIELD,?13+XBTAB,$S(XBTYPE="":XBNAME,1:$E(XBNAME,1,31-XBTAB)),?46,$E(XBWPSUB,1,21),?68,XBWPC,?77,XBTYPE I 1
91 E W !?XBTAB,XBFIELD,?13+XBTAB,$S(XBTYPE="":XBNAME,1:$E(XBNAME,1,31-XBTAB)),?46,$E(XBWPSUB,1,21) W:XBFMT["C" ?56,^DD(XBFILE,XBFIELD,9.1)
92 I XBTYPE]"" I $L(XBNAME)>(31-XBTAB)!($L(XBWPSUB)>25) W !,?13+XBTAB,$E(XBNAME,32-XBTAB,$L(XBNAME)),?46,$E(XBWPSUB,22,$L(XBWPSUB))
93 I XBTYPE="S",XBFMT["S" W !,?16+XBTAB,"S: ",$P(^DD(XBFILE,XBFIELD,0),"^",3)
94 I XBTYPE="P",XBFMT["P" S XBFLDPT=$P(X,"^",2),XBFLDPT=+$P(XBFLDPT,"P",2) S:$D(^DIC(XBFLDPT,0)) XBFLDPT=$P(^DIC(XBFLDPT,0),"^") W !,?16+XBTAB,"P: ",XBFLDPT KILL XBFLDPT
95 I XBTYPE="V",XBFMT["V" S XBFLDPT=0 F S XBFLDPT=$O(^DD(XBFILE,XBFIELD,"V",XBFLDPT)) Q:'XBFLDPT W !,?16+XBTAB,"V: ",$P(^DD(XBFILE,XBFIELD,"V",XBFLDPT,0),"^",1,2)
96 S XBPSUBOL=XBPSUB
97 I $D(^DD(XBFILE,XBFIELD,1,1,0)),XBFMT["X" D ^XBFLD0
98 Q
99 ;
100WRITELF ; WRITE ONE LINE FEED
101 ; The variable XBLNFEED prevents multiple lfs when backing out of
102 ; deep recursion.
103 ;
104 Q:XBLNFEED
105 I $Y>2,$Y'>(IOSL-3) W ! S XBLNFEED=1
106 Q
107 ;
108HEADING ; DICTIONARY HEADERS
109 NEW XBHOUR,XBMINUT,XBTITLE,XBTIME
110 S XBPAGE=1
111 W @IOF
112 D HEADING2
113 W ?80-$L("FILE: "_$P(^DIC(XBFILE,0),"^",1))\2,"FILE: ",$P(^DIC(XBFILE,0),"^",1),!,?80-$L("GLOBAL: "_^DIC(XBFILE,0,"GL"))\2,"GLOBAL: ",^DIC(XBFILE,0,"GL"),!,?80-$L("FILE #: "_XBFILE)\2,"FILE #: ",XBFILE,!!
114 D PAGE
115 Q
116 ;
117HEADING2 ; HARD COPY HEADERS
118 I IO=IO(0),$E(IOST,1,2)="C-" Q
119 I $G(XBFLD("BROWSE")) W !!! Q
120 S XBTITLE="I.H.S. DICTIONARY FIELDS",XBTIME=$P($H,",",2),XBHOUR=XBTIME\3600,XBMINUT=XBTIME#3600\60
121 S:XBMINUT<10 XBMINUT="0"_XBMINUT
122 S XBTIME=XBHOUR_":"_XBMINUT
123 W XBTIME,?80-$L(XBTITLE)\2,XBTITLE,?72,"page ",XBPAGE,!,?80-$L(^DD("SITE"))\2,^DD("SITE"),!
124 X ^%ZOSF("UCI")
125 S Y="UCI: "_$P(Y,",",1)
126 W ?80-$L(Y)\2,Y
127 I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
128 S Y=DT
129 X ^DD("DD")
130 W !!,?80-$L("as of "_Y)\2,"as of ",Y,!!
131 Q
132 ;
133PAGE ;EP - PAGE HEADERS
134 NEW X
135 D:XBPAGE>1 PAUSE
136 Q:XBQFLG
137 I XBPAGE>1 W:$D(IOF) @IOF
138 S XBPAGE=XBPAGE+1
139 W "FIELD #",?13,"FIELD NAME",?46,"SUBSCRIPT",?69,"PIECE",?75,"TYPE",!,$$REPEAT^XLFSTR("=",79),!
140 S XBPSUBOL=""
141 Q
142 ;
143PAUSE ; GIVE USER A CHANCE TO SEE LAST PAGE AND QUIT
144 I IO=IO(0),$E(IOST,1,2)="C-" S %=$$DIR^XBDIR("E") S:$D(DIRUT)!($D(DUOUT)) XBQFLG=1 KILL DIRUT,DUOUT
145 Q
146 ;
147INIT ; INITIALIZATION
148 S XBFLDP=$S($D(XBFLDP):1,1:0)
149 S:XBFLDP XBDSND=1
150 D ^XBFLD2 ; Get device and files to list
151 Q
152 ;
153FORMAT ;EP - select format
154 NEW A,X
155 S A="Select Format Combination"
156 F %=1:1 S X=$P($T(TXT+%),";;",2) Q:X="END" S A(%)=X
157 S Y=$$DIR^XBDIR("FO^0:5",.A,"","","","",1)
158 I Y="A" S Y="VPSXC"
159 S XBFMT=Y
160 Q
161 ;
162TXT ;
163 ;;
164 ;;Addition resolution of fields is available
165 ;; V - VARIABLE POINTER
166 ;; P - POINTER
167 ;; S - SET OF CODES
168 ;; C - COMPUTED EXPRESSION
169 ;; X - CROSS-REFERENCES
170 ;; A - ALL
171 ;;
172 ;;END
173 ;
174EN ; EXTERNAL ENTRY POINT
175 ; To use this entry point ^UTILITY("XBDSET",$J, must contain
176 ; the list of dictionaries. All device variables must be set
177 ; and, if appropriate, the U IO executed prior to the call.
178 ; It is the callers responsibility to close the device.
179 ;
180 NEW XBQFLG
181 I $D(IO)#2,$D(IO(0))#2,$D(IOF)#2,$D(IOSL)#2 D LIST
182 D EOJ
183 Q
184 ;
185EOJ ; END OF JOB
186 KILL XBFLDP,XBFLDPT,XBFMT,XBFLD,XBIHS
187 KILL ^UTILITY("XBDSET",$J)
188 KILL DIR,DIRUT,DTOUT,DUOUT,POP,S,X,Y
189 I $D(ZTQUEUED) S ZTREQ="@" Q
190 Q
191 ;
Note: See TracBrowser for help on using the repository browser.