source: IHS-VA_UTILITIES-XB/trunk/XBFLDO.m@ 830

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

Modified directory structure; moved routines.

File size: 4.5 KB
Line 
1XBFLD ; DICTIONARY LISTING [ 02/15/95 12:25 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4 ; This routine lists dictionaries which may be selected individually
5 ; or by a range of dictionary numbers.
6 ;
7 ; This routine requires the 89 MUMPS Standard, FileMan Version 17.7
8 ; or greater, Kernel Version 6 or greater, and the following routines
9 ; must exist in the UCI in which this routine is running:
10 ;
11 ; XBKVAR, XBSFGBL
12 ;
13START ;
14 D LOOP ; List files until user says stop
15 D EOJ ; Clean up
16 Q
17 ;
18LOOP ; LIST FILES UNTIL USER SAYS STOP
19 NEW QFLG
20 W !,"^XBFLD - This routine lists FileMan dictionaries."
21 F D INIT Q:QFLG D LIST W ! X ^%ZIS("C") Q:QFLG
22 Q
23 ;
24LIST ; LIST RANGE OF FILES
25 NEW COMP,FILE,FLD,LF,NAME,PC,PG,PSUB,PSUBOLD,SUBFILE,SUB,TAB,TYPE,WPC,WPSUB
26 S QFLG=0
27 F FILE=0:0 S FILE=$O(^UTILITY("XBDSET",$J,FILE)) Q:FILE="" D FILE Q:QFLG
28 Q
29 ;
30FILE ; LIST ONE FILE
31 S (COMP,LF,PG,TAB)=0,SUB="D0,",PSUBOLD=""
32 D HEADING
33 D FIELDS
34 Q:QFLG
35 D PAUSE
36 Q
37 ;
38FIELDS ; LIST ALL FIELDS IN ONE FILE/SUBFILE (CALLED RECURSIVELY)
39 F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:FLD'=+FLD D FIELD Q:QFLG
40 Q
41 ;
42FIELD ; LIST ONE FIELD
43 S (NAME,PC,PSUB,TYPE)=""
44 S X=^DD(FILE,FLD,0)
45 S NAME=$P(X,U,1)
46 S Y=$P(X,U,2)
47 S TYPE=$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:"?")
48 I TYPE="C" D COMPUTED Q
49 I COMP S COMP=0 D WRITELF ; Extra lf after computed fields
50 I TYPE="" D MULTIPLE Q
51 S Y=$P(X,U,4)
52 S PSUB=SUB_$S($P(Y,";",1)=+$P(Y,";",1):$P(Y,";",1),1:""""_$P(Y,";",1)_"""")
53 S PC=$S(TYPE="K":" ",1:$P(Y,";",2)) ; MUMPS field has no piece
54 D WRITE
55 Q
56 ;
57COMPUTED ; COMPUTED FIELD
58 ; The variable COMP prevents multiple lfs between adjacent
59 ; computed fields.
60 ;
61 D:'COMP WRITELF
62 S PSUB="COMPUTED",TYPE="",COMP=1
63 S PSUB=PSUB_$S(Y["B":" (BOOLEAN)",Y["D":" (DATE)",1:"")
64 D WRITE
65 Q
66 ;
67MULTIPLE ; LIST MULTIPLE, THEN FIELDS IN SUBFILE
68 S NAME=NAME_" ("_+Y_")",SUBFILE=+Y
69 D WRITELF,WRITE
70 Q:QFLG
71 NEW FILE,FLD,SUB
72 S FILE=SUBFILE
73 D ^XBSFGBL(FILE,.SUB,2) S SUB="D0"_$P(SUB,"D0",2),SUB=$P(SUB,")",1)
74 S TAB=TAB+2
75 D FIELDS ; Recurse
76 S TAB=TAB-2
77 Q:QFLG
78 D WRITELF
79 Q
80 ;
81WRITE ; WRITE ONE LINE
82 S LF=0
83 D PAGE:$Y>(IOSL-3)
84 Q:QFLG
85 S WPSUB=$S(FLD=.001:"",PSUB]""&(PSUB=PSUBOLD):" """,1:PSUB)
86 S WPC=$S(PC:$J(PC,5,0),1:PC) ;S:$E(WPC)="E" WPC=$E(" ",1,7-$L(WPC))_WPC
87 W !,?TAB,FLD,?13+TAB,$S(TYPE="":NAME,1:$E(NAME,1,31-TAB)),?46,$E(WPSUB,1,21),?68,WPC,?77,TYPE
88 I TYPE'="" I $L(NAME)>(31-TAB)!($L(WPSUB)>25) W !,?13+TAB,$E(NAME,32-TAB,$L(NAME)),?46,$E(WPSUB,22,$L(WPSUB))
89 ;S S="" S:TAB $P(S," ",TAB)=" "
90 ;W !,S_FLD,?13,S_NAME,?42,$S(FLD=.001:"",PSUB]""&(PSUB=PSUBOLD):" """,1:PSUB),?70,$S(PC:$J(PC,2,0),1:""),?77,TYPE
91 S PSUBOLD=PSUB
92 Q
93 ;
94WRITELF ; WRITE ONE LINE FEED
95 ; The variable LF prevents multiple lfs when backing out of
96 ; deep recursion.
97 ;
98 Q:LF
99 I $Y>2,$Y'>(IOSL-3) W ! S LF=1
100 Q
101 ;
102HEADING ; DICTIONARY HEADERS
103 NEW HR,MIN,TITLE,TM,TME,UCI
104 S PG=1
105 W @IOF
106 D HEADING2
107 W ?80-$L("FILE: "_$P(^DIC(FILE,0),"^",1))\2,"FILE: ",$P(^DIC(FILE,0),"^",1),!,?80-$L("GLOBAL: "_^DIC(FILE,0,"GL"))\2,"GLOBAL: ",^DIC(FILE,0,"GL"),!,?80-$L("FILE #: "_FILE)\2,"FILE #: ",FILE,!!
108 D PAGE
109 Q
110 ;
111HEADING2 ; HARD COPY HEADERS
112 I IO=IO(0),$E(IOST,1,2)="C-" Q
113 S TITLE="I.H.S. DICTIONARY FIELDS",TM=$P($H,",",2),HR=TM\3600,MIN=TM#3600\60 S:MIN<10 MIN="0"_MIN S TME=HR_":"_MIN
114 W TME,?80-$L(TITLE)\2,TITLE,?72,"page ",PG,!,?80-$L(^DD("SITE"))\2,^DD("SITE"),!
115 X ^%ZOSF("UCI") S UCI="UCI: "_$P(Y,",",1) W ?80-$L(UCI)\2,UCI
116 I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
117 S Y=DT X ^DD("DD") W !!,?80-$L("as of "_Y)\2,"as of ",Y,!!
118 Q
119 ;
120PAGE ; PAGE HEADERS
121 D:PG>1 PAUSE
122 Q:QFLG
123 I PG>1 W:$D(IOF) @IOF
124 S PG=PG+1
125 S X="",$P(X,"=",79)="=" W "FIELD #",?13,"FIELD NAME",?46,"SUBSCRIPT",?69,"PIECE",?75,"TYPE",!,X,! S X=""
126 S PSUBOLD=""
127 Q
128 ;
129PAUSE ; GIVE USER A CHANCE TO SEE LAST PAGE AND QUIT
130 I IO=IO(0),$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:$D(DIRUT)!($D(DUOUT)) QFLG=1 K DIRUT,DUOUT
131 Q
132 ;
133INIT ; INITIALIZATION
134 S XBFLDP=$S($D(XBFLDP):1,1:0)
135 S:XBFLDP XBDSND=1
136 D ^XBFLD2 ; Get device and files to list
137 Q
138 ;
139EN ; EXTERNAL ENTRY POINT
140 ; To use this entry point ^UTILITY("XBDSET",$J, must contain
141 ; the list of dictionaries. All device variables must be set
142 ; and, if appropriate, the U IO executed prior to the call.
143 ; It is the callers responsibility to close the device.
144 ;
145 NEW QFLG
146 I $D(IO)#2,$D(IO(0))#2,$D(IOF)#2,$D(IOSL)#2 D LIST
147 D EOJ
148 Q
149 ;
150EOJ ; END OF JOB
151 K XBFLDP
152 K ^UTILITY("XBDSET",$J)
153 K DIR,DIRUT,DTOUT,DUOUT,POP,S,X,Y
154 I $D(ZTQUEUED) S ZTREQ="@" Q
155 I $D(ZTSK),ZTSK K ^%ZTSK(ZTSK) ; ***** For old Kernel *****
156 Q
Note: See TracBrowser for help on using the repository browser.