XBFLD.m

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       ;