| 1 | XBFLD ; 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 | ;
|
|---|
| 14 | START ;
|
|---|
| 15 | D LOOP ; List files until user says stop
|
|---|
| 16 | D EOJ ; Clean up
|
|---|
| 17 | Q
|
|---|
| 18 | ;
|
|---|
| 19 | LOOP ; 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 | ;
|
|---|
| 25 | LIST ; 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 | ;
|
|---|
| 32 | FILE ; 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 | ;
|
|---|
| 40 | FIELDS ; 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 | ;
|
|---|
| 44 | FIELD ; 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 | ;
|
|---|
| 59 | COMPUTED ; 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 | ;
|
|---|
| 69 | MULTIPLE ; 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 | ;
|
|---|
| 84 | WRITE ; 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 | ;
|
|---|
| 100 | WRITELF ; 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 | ;
|
|---|
| 108 | HEADING ; 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 | ;
|
|---|
| 117 | HEADING2 ; 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 | ;
|
|---|
| 133 | PAGE ;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 | ;
|
|---|
| 143 | PAUSE ; 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 | ;
|
|---|
| 147 | INIT ; 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 | ;
|
|---|
| 153 | FORMAT ;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 | ;
|
|---|
| 162 | TXT ;
|
|---|
| 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 | ;
|
|---|
| 174 | EN ; 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 | ;
|
|---|
| 185 | EOJ ; 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 | ;
|
|---|
