157 lines
4.5 KiB
Mathematica
157 lines
4.5 KiB
Mathematica
XBFLD ; DICTIONARY LISTING [ 02/15/95 12:25 PM ]
|
|
;;4.0;XB;;Jul 20, 2009;Build 2
|
|
;
|
|
; This routine lists dictionaries which may be selected individually
|
|
; or by a range of dictionary numbers.
|
|
;
|
|
; This routine requires the 89 MUMPS Standard, FileMan Version 17.7
|
|
; or greater, Kernel Version 6 or greater, and the following routines
|
|
; must exist in the UCI in which this routine is running:
|
|
;
|
|
; XBKVAR, XBSFGBL
|
|
;
|
|
START ;
|
|
D LOOP ; List files until user says stop
|
|
D EOJ ; Clean up
|
|
Q
|
|
;
|
|
LOOP ; LIST FILES UNTIL USER SAYS STOP
|
|
NEW QFLG
|
|
W !,"^XBFLD - This routine lists FileMan dictionaries."
|
|
F D INIT Q:QFLG D LIST W ! X ^%ZIS("C") Q:QFLG
|
|
Q
|
|
;
|
|
LIST ; LIST RANGE OF FILES
|
|
NEW COMP,FILE,FLD,LF,NAME,PC,PG,PSUB,PSUBOLD,SUBFILE,SUB,TAB,TYPE,WPC,WPSUB
|
|
S QFLG=0
|
|
F FILE=0:0 S FILE=$O(^UTILITY("XBDSET",$J,FILE)) Q:FILE="" D FILE Q:QFLG
|
|
Q
|
|
;
|
|
FILE ; LIST ONE FILE
|
|
S (COMP,LF,PG,TAB)=0,SUB="D0,",PSUBOLD=""
|
|
D HEADING
|
|
D FIELDS
|
|
Q:QFLG
|
|
D PAUSE
|
|
Q
|
|
;
|
|
FIELDS ; LIST ALL FIELDS IN ONE FILE/SUBFILE (CALLED RECURSIVELY)
|
|
F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:FLD'=+FLD D FIELD Q:QFLG
|
|
Q
|
|
;
|
|
FIELD ; LIST ONE FIELD
|
|
S (NAME,PC,PSUB,TYPE)=""
|
|
S X=^DD(FILE,FLD,0)
|
|
S NAME=$P(X,U,1)
|
|
S Y=$P(X,U,2)
|
|
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:"?")
|
|
I TYPE="C" D COMPUTED Q
|
|
I COMP S COMP=0 D WRITELF ; Extra lf after computed fields
|
|
I TYPE="" D MULTIPLE Q
|
|
S Y=$P(X,U,4)
|
|
S PSUB=SUB_$S($P(Y,";",1)=+$P(Y,";",1):$P(Y,";",1),1:""""_$P(Y,";",1)_"""")
|
|
S PC=$S(TYPE="K":" ",1:$P(Y,";",2)) ; MUMPS field has no piece
|
|
D WRITE
|
|
Q
|
|
;
|
|
COMPUTED ; COMPUTED FIELD
|
|
; The variable COMP prevents multiple lfs between adjacent
|
|
; computed fields.
|
|
;
|
|
D:'COMP WRITELF
|
|
S PSUB="COMPUTED",TYPE="",COMP=1
|
|
S PSUB=PSUB_$S(Y["B":" (BOOLEAN)",Y["D":" (DATE)",1:"")
|
|
D WRITE
|
|
Q
|
|
;
|
|
MULTIPLE ; LIST MULTIPLE, THEN FIELDS IN SUBFILE
|
|
S NAME=NAME_" ("_+Y_")",SUBFILE=+Y
|
|
D WRITELF,WRITE
|
|
Q:QFLG
|
|
NEW FILE,FLD,SUB
|
|
S FILE=SUBFILE
|
|
D ^XBSFGBL(FILE,.SUB,2) S SUB="D0"_$P(SUB,"D0",2),SUB=$P(SUB,")",1)
|
|
S TAB=TAB+2
|
|
D FIELDS ; Recurse
|
|
S TAB=TAB-2
|
|
Q:QFLG
|
|
D WRITELF
|
|
Q
|
|
;
|
|
WRITE ; WRITE ONE LINE
|
|
S LF=0
|
|
D PAGE:$Y>(IOSL-3)
|
|
Q:QFLG
|
|
S WPSUB=$S(FLD=.001:"",PSUB]""&(PSUB=PSUBOLD):" """,1:PSUB)
|
|
S WPC=$S(PC:$J(PC,5,0),1:PC) ;S:$E(WPC)="E" WPC=$E(" ",1,7-$L(WPC))_WPC
|
|
W !,?TAB,FLD,?13+TAB,$S(TYPE="":NAME,1:$E(NAME,1,31-TAB)),?46,$E(WPSUB,1,21),?68,WPC,?77,TYPE
|
|
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))
|
|
;S S="" S:TAB $P(S," ",TAB)=" "
|
|
;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
|
|
S PSUBOLD=PSUB
|
|
Q
|
|
;
|
|
WRITELF ; WRITE ONE LINE FEED
|
|
; The variable LF prevents multiple lfs when backing out of
|
|
; deep recursion.
|
|
;
|
|
Q:LF
|
|
I $Y>2,$Y'>(IOSL-3) W ! S LF=1
|
|
Q
|
|
;
|
|
HEADING ; DICTIONARY HEADERS
|
|
NEW HR,MIN,TITLE,TM,TME,UCI
|
|
S PG=1
|
|
W @IOF
|
|
D HEADING2
|
|
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,!!
|
|
D PAGE
|
|
Q
|
|
;
|
|
HEADING2 ; HARD COPY HEADERS
|
|
I IO=IO(0),$E(IOST,1,2)="C-" Q
|
|
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
|
|
W TME,?80-$L(TITLE)\2,TITLE,?72,"page ",PG,!,?80-$L(^DD("SITE"))\2,^DD("SITE"),!
|
|
X ^%ZOSF("UCI") S UCI="UCI: "_$P(Y,",",1) W ?80-$L(UCI)\2,UCI
|
|
I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
|
|
S Y=DT X ^DD("DD") W !!,?80-$L("as of "_Y)\2,"as of ",Y,!!
|
|
Q
|
|
;
|
|
PAGE ; PAGE HEADERS
|
|
D:PG>1 PAUSE
|
|
Q:QFLG
|
|
I PG>1 W:$D(IOF) @IOF
|
|
S PG=PG+1
|
|
S X="",$P(X,"=",79)="=" W "FIELD #",?13,"FIELD NAME",?46,"SUBSCRIPT",?69,"PIECE",?75,"TYPE",!,X,! S X=""
|
|
S PSUBOLD=""
|
|
Q
|
|
;
|
|
PAUSE ; GIVE USER A CHANCE TO SEE LAST PAGE AND QUIT
|
|
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
|
|
Q
|
|
;
|
|
INIT ; INITIALIZATION
|
|
S XBFLDP=$S($D(XBFLDP):1,1:0)
|
|
S:XBFLDP XBDSND=1
|
|
D ^XBFLD2 ; Get device and files to list
|
|
Q
|
|
;
|
|
EN ; EXTERNAL ENTRY POINT
|
|
; To use this entry point ^UTILITY("XBDSET",$J, must contain
|
|
; the list of dictionaries. All device variables must be set
|
|
; and, if appropriate, the U IO executed prior to the call.
|
|
; It is the callers responsibility to close the device.
|
|
;
|
|
NEW QFLG
|
|
I $D(IO)#2,$D(IO(0))#2,$D(IOF)#2,$D(IOSL)#2 D LIST
|
|
D EOJ
|
|
Q
|
|
;
|
|
EOJ ; END OF JOB
|
|
K XBFLDP
|
|
K ^UTILITY("XBDSET",$J)
|
|
K DIR,DIRUT,DTOUT,DUOUT,POP,S,X,Y
|
|
I $D(ZTQUEUED) S ZTREQ="@" Q
|
|
I $D(ZTSK),ZTSK K ^%ZTSK(ZTSK) ; ***** For old Kernel *****
|
|
Q
|