XBFLD ; IHS/ADC/GTH - DICTIONARY LISTING ; [ 02/07/97 3:02 PM ]
;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
;
; 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 XBQFLG
W !,"^XBFLD - This routine lists FileMan dictionaries."
F D INIT Q:XBQFLG D LIST W ! D ^%ZISC Q:XBQFLG
Q
;
LIST ; LIST RANGE OF FILES
S:'$D(XBFMT) XBFMT=""
NEW XBCOMP,XBFILE,XBFIELD,XBLNFEED,XBNAME,XBPIECE,XBPAGE,XBPSUB,XBPSUBOL,XBSUBFIL,XBSUB,XBTAB,XBTYPE,XBWPC,XBWPSUB
S XBQFLG=0
F XBFILE=0:0 S XBFILE=$O(^UTILITY("XBDSET",$J,XBFILE)) Q:XBFILE="" D FILE Q:XBQFLG
Q
;
FILE ; LIST ONE FILE
S (XBCOMP,XBLNFEED,XBPAGE,XBTAB)=0,XBSUB="D0,",XBPSUBOL=""
D HEADING
D FIELDS
Q:XBQFLG
D PAUSE
Q
;
FIELDS ; LIST ALL FIELDS IN ONE FILE/SUBFILE (CALLED RECURSIVELY)
F XBFIELD=0:0 S XBFIELD=$O(^DD(XBFILE,XBFIELD)) Q:XBFIELD'=+XBFIELD D FIELD Q:XBQFLG
Q
;
FIELD ; LIST ONE FIELD
S (XBNAME,XBPIECE,XBPSUB,XBTYPE)=""
S X=^DD(XBFILE,XBFIELD,0)
S XBNAME=$P(X,U,1)
S Y=$P(X,U,2)
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:"?")
I XBTYPE="C" D COMPUTED Q
I XBCOMP S XBCOMP=0 D WRITELF ; Extra lf after computed fields
I XBTYPE="" D MULTIPLE Q
S Y=$P(X,U,4)
S XBPSUB=XBSUB_$S($P(Y,";",1)=+$P(Y,";",1):$P(Y,";",1),1:""""_$P(Y,";",1)_"""")
S XBPIECE=$S(XBTYPE="K":" ",1:$P(Y,";",2)) ; MUMPS field has no piece
D WRITE
Q
;
COMPUTED ; COMPUTED FIELD
; The variable XBCOMP prevents multiple lfs between adjacent
; computed fields.
;
D:'XBCOMP WRITELF
S XBPSUB="COMPUTED",XBTYPE="",XBCOMP=1
S XBPSUB=XBPSUB_$S(Y["B":" (BOOLEAN)",Y["D":" (DATE)",1:"")
D WRITE
Q
;
MULTIPLE ; LIST MULTIPLE, THEN FIELDS IN SUBFILE
S XBNAME=XBNAME_" ("_+Y_")",XBSUBFIL=+Y
D WRITELF,WRITE
Q:XBQFLG
NEW XBFILE,XBFIELD,XBSUB
S XBFILE=XBSUBFIL
D ^XBSFGBL(XBFILE,.XBSUB,2)
S XBSUB="D0"_$P(XBSUB,"D0",2),XBSUB=$P(XBSUB,")",1)
S XBTAB=XBTAB+2
D FIELDS ; Recurse
S XBTAB=XBTAB-2
Q:XBQFLG
D WRITELF
Q
;
WRITE ; WRITE ONE LINE
S XBLNFEED=0
D PAGE:$Y>(IOSL-3)
Q:XBQFLG
S XBWPSUB=$S(XBFIELD=.001:"",XBPSUB]""&(XBPSUB=XBPSUBOL):" """,1:XBPSUB)
S XBWPC=$S(XBPIECE:$J(XBPIECE,5,0),1:XBPIECE)
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
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)
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))
I XBTYPE="S",XBFMT["S" W !,?16+XBTAB,"S: ",$P(^DD(XBFILE,XBFIELD,0),"^",3)
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
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)
S XBPSUBOL=XBPSUB
I $D(^DD(XBFILE,XBFIELD,1,1,0)),XBFMT["X" D ^XBFLD0
Q
;
WRITELF ; WRITE ONE LINE FEED
; The variable XBLNFEED prevents multiple lfs when backing out of
; deep recursion.
;
Q:XBLNFEED
I $Y>2,$Y'>(IOSL-3) W ! S XBLNFEED=1
Q
;
HEADING ; DICTIONARY HEADERS
NEW XBHOUR,XBMINUT,XBTITLE,XBTIME
S XBPAGE=1
W @IOF
D HEADING2
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,!!
D PAGE
Q
;
HEADING2 ; HARD COPY HEADERS
I IO=IO(0),$E(IOST,1,2)="C-" Q
I $G(XBFLD("BROWSE")) W !!! Q
S XBTITLE="I.H.S. DICTIONARY FIELDS",XBTIME=$P($H,",",2),XBHOUR=XBTIME\3600,XBMINUT=XBTIME#3600\60
S:XBMINUT<10 XBMINUT="0"_XBMINUT
S XBTIME=XBHOUR_":"_XBMINUT
W XBTIME,?80-$L(XBTITLE)\2,XBTITLE,?72,"page ",XBPAGE,!,?80-$L(^DD("SITE"))\2,^DD("SITE"),!
X ^%ZOSF("UCI")
S Y="UCI: "_$P(Y,",",1)
W ?80-$L(Y)\2,Y
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 ;EP - PAGE HEADERS
NEW X
D:XBPAGE>1 PAUSE
Q:XBQFLG
I XBPAGE>1 W:$D(IOF) @IOF
S XBPAGE=XBPAGE+1
W "FIELD #",?13,"FIELD NAME",?46,"SUBSCRIPT",?69,"PIECE",?75,"TYPE",!,$$REPEAT^XLFSTR("=",79),!
S XBPSUBOL=""
Q
;
PAUSE ; GIVE USER A CHANCE TO SEE LAST PAGE AND QUIT
I IO=IO(0),$E(IOST,1,2)="C-" S %=$$DIR^XBDIR("E") S:$D(DIRUT)!($D(DUOUT)) XBQFLG=1 KILL 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
;
FORMAT ;EP - select format
NEW A,X
S A="Select Format Combination"
F %=1:1 S X=$P($T(TXT+%),";;",2) Q:X="END" S A(%)=X
S Y=$$DIR^XBDIR("FO^0:5",.A,"","","","",1)
I Y="A" S Y="VPSXC"
S XBFMT=Y
Q
;
TXT ;
;;
;;Addition resolution of fields is available
;; V - VARIABLE POINTER
;; P - POINTER
;; S - SET OF CODES
;; C - COMPUTED EXPRESSION
;; X - CROSS-REFERENCES
;; A - ALL
;;
;;END
;
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 XBQFLG
I $D(IO)#2,$D(IO(0))#2,$D(IOF)#2,$D(IOSL)#2 D LIST
D EOJ
Q
;
EOJ ; END OF JOB
KILL XBFLDP,XBFLDPT,XBFMT,XBFLD,XBIHS
KILL ^UTILITY("XBDSET",$J)
KILL DIR,DIRUT,DTOUT,DUOUT,POP,S,X,Y
I $D(ZTQUEUED) S ZTREQ="@" Q
Q
;
XBFLD ; IHS/ADC/GTH - DICTIONARY LISTING ; [ 02/07/97 3:02 PM ]
+1 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
+2 ;
+3 ; This routine lists dictionaries which may be selected
+4 ; individually or by a range of dictionary numbers.
+5 ;
+6 ; This routine requires the 89 MUMPS Standard, FileMan
+7 ; Version 17.7 or greater, Kernel Version 6 or greater, and
+8 ; the following routines must exist in the UCI in which this
+9 ; routine is running:
+10 ;
+11 ; XBKVAR, XBSFGBL
+12 ;
START ;
+1 ; List files until user says stop
DO LOOP
+2 ; Clean up
DO EOJ
+3 QUIT
+4 ;
LOOP ; LIST FILES UNTIL USER SAYS STOP
+1 NEW XBQFLG
+2 WRITE !,"^XBFLD - This routine lists FileMan dictionaries."
+3 FOR
DO INIT
IF XBQFLG
QUIT
DO LIST
WRITE !
DO ^%ZISC
IF XBQFLG
QUIT
+4 QUIT
+5 ;
LIST ; LIST RANGE OF FILES
+1 IF '$DATA(XBFMT)
SET XBFMT=""
+2 NEW XBCOMP,XBFILE,XBFIELD,XBLNFEED,XBNAME,XBPIECE,XBPAGE,XBPSUB,XBPSUBOL,XBSUBFIL,XBSUB,XBTAB,XBTYPE,XBWPC,XBWPSUB
+3 SET XBQFLG=0
+4 FOR XBFILE=0:0
SET XBFILE=$ORDER(^UTILITY("XBDSET",$JOB,XBFILE))
IF XBFILE=""
QUIT
DO FILE
IF XBQFLG
QUIT
+5 QUIT
+6 ;
FILE ; LIST ONE FILE
+1 SET (XBCOMP,XBLNFEED,XBPAGE,XBTAB)=0
SET XBSUB="D0,"
SET XBPSUBOL=""
+2 DO HEADING
+3 DO FIELDS
+4 IF XBQFLG
QUIT
+5 DO PAUSE
+6 QUIT
+7 ;
FIELDS ; LIST ALL FIELDS IN ONE FILE/SUBFILE (CALLED RECURSIVELY)
+1 FOR XBFIELD=0:0
SET XBFIELD=$ORDER(^DD(XBFILE,XBFIELD))
IF XBFIELD'=+XBFIELD
QUIT
DO FIELD
IF XBQFLG
QUIT
+2 QUIT
+3 ;
FIELD ; LIST ONE FIELD
+1 SET (XBNAME,XBPIECE,XBPSUB,XBTYPE)=""
+2 SET X=^DD(XBFILE,XBFIELD,0)
+3 SET XBNAME=$PIECE(X,U,1)
+4 SET Y=$PIECE(X,U,2)
+5 SET XBTYPE=$SELECT(+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:"?")
+6 IF XBTYPE="C"
DO COMPUTED
QUIT
+7 ; Extra lf after computed fields
IF XBCOMP
SET XBCOMP=0
DO WRITELF
+8 IF XBTYPE=""
DO MULTIPLE
QUIT
+9 SET Y=$PIECE(X,U,4)
+10 SET XBPSUB=XBSUB_$SELECT($PIECE(Y,";",1)=+$PIECE(Y,";",1):$PIECE(Y,";",1),1:""""_$PIECE(Y,";",1)_"""")
+11 ; MUMPS field has no piece
SET XBPIECE=$SELECT(XBTYPE="K":" ",1:$PIECE(Y,";",2))
+12 DO WRITE
+13 QUIT
+14 ;
COMPUTED ; COMPUTED FIELD
+1 ; The variable XBCOMP prevents multiple lfs between adjacent
+2 ; computed fields.
+3 ;
+4 IF 'XBCOMP
DO WRITELF
+5 SET XBPSUB="COMPUTED"
SET XBTYPE=""
SET XBCOMP=1
+6 SET XBPSUB=XBPSUB_$SELECT(Y["B":" (BOOLEAN)",Y["D":" (DATE)",1:"")
+7 DO WRITE
+8 QUIT
+9 ;
MULTIPLE ; LIST MULTIPLE, THEN FIELDS IN SUBFILE
+1 SET XBNAME=XBNAME_" ("_+Y_")"
SET XBSUBFIL=+Y
+2 DO WRITELF
DO WRITE
+3 IF XBQFLG
QUIT
+4 NEW XBFILE,XBFIELD,XBSUB
+5 SET XBFILE=XBSUBFIL
+6 DO ^XBSFGBL(XBFILE,.XBSUB,2)
+7 SET XBSUB="D0"_$PIECE(XBSUB,"D0",2)
SET XBSUB=$PIECE(XBSUB,")",1)
+8 SET XBTAB=XBTAB+2
+9 ; Recurse
DO FIELDS
+10 SET XBTAB=XBTAB-2
+11 IF XBQFLG
QUIT
+12 DO WRITELF
+13 QUIT
+14 ;
WRITE ; WRITE ONE LINE
+1 SET XBLNFEED=0
+2 IF $Y>(IOSL-3)
DO PAGE
+3 IF XBQFLG
QUIT
+4 SET XBWPSUB=$SELECT(XBFIELD=.001:"",XBPSUB]""&(XBPSUB=XBPSUBOL):" """,1:XBPSUB)
+5 SET XBWPC=$SELECT(XBPIECE:$JUSTIFY(XBPIECE,5,0),1:XBPIECE)
+6 IF (XBPSUB'["COMPUTED")
WRITE !?XBTAB,XBFIELD,?13+XBTAB,$SELECT(XBTYPE="":XBNAME,1:$EXTRACT(XBNAME,1,31-XBTAB)),?46,$EXTRACT(XBWPSUB,1,21),?68,XBWPC,?77,XBTYPE
IF 1
+7 IF '$TEST
WRITE !?XBTAB,XBFIELD,?13+XBTAB,$SELECT(XBTYPE="":XBNAME,1:$EXTRACT(XBNAME,1,31-XBTAB)),?46,$EXTRACT(XBWPSUB,1,21)
IF XBFMT["C"
WRITE ?56,^DD(XBFILE,XBFIELD,9.1)
+8 IF XBTYPE]""
IF $LENGTH(XBNAME)>(31-XBTAB)!($LENGTH(XBWPSUB)>25)
WRITE !,?13+XBTAB,$EXTRACT(XBNAME,32-XBTAB,$LENGTH(XBNAME)),?46,$EXTRACT(XBWPSUB,22,$LENGTH(XBWPSUB))
+9 IF XBTYPE="S"
IF XBFMT["S"
WRITE !,?16+XBTAB,"S: ",$PIECE(^DD(XBFILE,XBFIELD,0),"^",3)
+10 IF XBTYPE="P"
IF XBFMT["P"
SET XBFLDPT=$PIECE(X,"^",2)
SET XBFLDPT=+$PIECE(XBFLDPT,"P",2)
IF $DATA(^DIC(XBFLDPT,0))
SET XBFLDPT=$PIECE(^DIC(XBFLDPT,0),"^")
WRITE !,?16+XBTAB,"P: ",XBFLDPT
KILL XBFLDPT
+11 IF XBTYPE="V"
IF XBFMT["V"
SET XBFLDPT=0
FOR
SET XBFLDPT=$ORDER(^DD(XBFILE,XBFIELD,"V",XBFLDPT))
IF 'XBFLDPT
QUIT
WRITE !,?16+XBTAB,"V: ",$PIECE(^DD(XBFILE,XBFIELD,"V",XBFLDPT,0),"^",1,2)
+12 SET XBPSUBOL=XBPSUB
+13 IF $DATA(^DD(XBFILE,XBFIELD,1,1,0))
IF XBFMT["X"
DO ^XBFLD0
+14 QUIT
+15 ;
WRITELF ; WRITE ONE LINE FEED
+1 ; The variable XBLNFEED prevents multiple lfs when backing out of
+2 ; deep recursion.
+3 ;
+4 IF XBLNFEED
QUIT
+5 IF $Y>2
IF $Y'>(IOSL-3)
WRITE !
SET XBLNFEED=1
+6 QUIT
+7 ;
HEADING ; DICTIONARY HEADERS
+1 NEW XBHOUR,XBMINUT,XBTITLE,XBTIME
+2 SET XBPAGE=1
+3 WRITE @IOF
+4 DO HEADING2
+5 WRITE ?80-$LENGTH("FILE: "_$PIECE(^DIC(XBFILE,0),"^",1))\2,"FILE: ",$PIECE(^DIC(XBFILE,0),"^",1),!,?80-$LENGTH("GLOBAL: "_^DIC(XBFILE,0,"GL"))\2,"GLOBAL: ",^DIC(XBFILE,0,"GL"),!,?80-$LENGTH("FILE #: "_XBFILE)\2,"FILE #: ",XBFILE,!!
+6 DO PAGE
+7 QUIT
+8 ;
HEADING2 ; HARD COPY HEADERS
+1 IF IO=IO(0)
IF $EXTRACT(IOST,1,2)="C-"
QUIT
+2 IF $GET(XBFLD("BROWSE"))
WRITE !!!
QUIT
+3 SET XBTITLE="I.H.S. DICTIONARY FIELDS"
SET XBTIME=$PIECE($HOROLOG,",",2)
SET XBHOUR=XBTIME\3600
SET XBMINUT=XBTIME#3600\60
+4 IF XBMINUT<10
SET XBMINUT="0"_XBMINUT
+5 SET XBTIME=XBHOUR_":"_XBMINUT
+6 WRITE XBTIME,?80-$LENGTH(XBTITLE)\2,XBTITLE,?72,"page ",XBPAGE,!,?80-$LENGTH(^DD("SITE"))\2,^DD("SITE"),!
+7 XECUTE ^%ZOSF("UCI")
+8 SET Y="UCI: "_$PIECE(Y,",",1)
+9 WRITE ?80-$LENGTH(Y)\2,Y
+10 IF '$DATA(DT)
SET %DT=""
SET X="T"
DO ^%DT
SET DT=Y
+11 SET Y=DT
+12 XECUTE ^DD("DD")
+13 WRITE !!,?80-$LENGTH("as of "_Y)\2,"as of ",Y,!!
+14 QUIT
+15 ;
PAGE ;EP - PAGE HEADERS
+1 NEW X
+2 IF XBPAGE>1
DO PAUSE
+3 IF XBQFLG
QUIT
+4 IF XBPAGE>1
IF $DATA(IOF)
WRITE @IOF
+5 SET XBPAGE=XBPAGE+1
+6 WRITE "FIELD #",?13,"FIELD NAME",?46,"SUBSCRIPT",?69,"PIECE",?75,"TYPE",!,$$REPEAT^XLFSTR("=",79),!
+7 SET XBPSUBOL=""
+8 QUIT
+9 ;
PAUSE ; GIVE USER A CHANCE TO SEE LAST PAGE AND QUIT
+1 IF IO=IO(0)
IF $EXTRACT(IOST,1,2)="C-"
SET %=$$DIR^XBDIR("E")
IF $DATA(DIRUT)!($DATA(DUOUT))
SET XBQFLG=1
KILL DIRUT,DUOUT
+2 QUIT
+3 ;
INIT ; INITIALIZATION
+1 SET XBFLDP=$SELECT($DATA(XBFLDP):1,1:0)
+2 IF XBFLDP
SET XBDSND=1
+3 ; Get device and files to list
DO ^XBFLD2
+4 QUIT
+5 ;
FORMAT ;EP - select format
+1 NEW A,X
+2 SET A="Select Format Combination"
+3 FOR %=1:1
SET X=$PIECE($TEXT(TXT+%),";;",2)
IF X="END"
QUIT
SET A(%)=X
+4 SET Y=$$DIR^XBDIR("FO^0:5",.A,"","","","",1)
+5 IF Y="A"
SET Y="VPSXC"
+6 SET XBFMT=Y
+7 QUIT
+8 ;
TXT ;
+1 ;;
+2 ;;Addition resolution of fields is available
+3 ;; V - VARIABLE POINTER
+4 ;; P - POINTER
+5 ;; S - SET OF CODES
+6 ;; C - COMPUTED EXPRESSION
+7 ;; X - CROSS-REFERENCES
+8 ;; A - ALL
+9 ;;
+10 ;;END
+11 ;
EN ; EXTERNAL ENTRY POINT
+1 ; To use this entry point ^UTILITY("XBDSET",$J, must contain
+2 ; the list of dictionaries. All device variables must be set
+3 ; and, if appropriate, the U IO executed prior to the call.
+4 ; It is the callers responsibility to close the device.
+5 ;
+6 NEW XBQFLG
+7 IF $DATA(IO)#2
IF $DATA(IO(0))#2
IF $DATA(IOF)#2
IF $DATA(IOSL)#2
DO LIST
+8 DO EOJ
+9 QUIT
+10 ;
EOJ ; END OF JOB
+1 KILL XBFLDP,XBFLDPT,XBFMT,XBFLD,XBIHS
+2 KILL ^UTILITY("XBDSET",$JOB)
+3 KILL DIR,DIRUT,DTOUT,DUOUT,POP,S,X,Y
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+5 QUIT
+6 ;
