VistA-IHS-VA_UTILITIES-XB/XBFLDO.m

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