XBSIC.m

XBSIC ;IHS/SET/GTH - LIST ID,SP,FD NODES ON SELECTED FILES ; [ 12/05/2002  4:28 PM ]

 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 ;IHS/SET/GTH XB*3*9 10/29/2002 New Routine.

 ; This routine lists the IDENTIFIERS, SPECIFIERS, and

 ; CONDITIONALS from selected files.

 ;

 ; Thanks to E. Don Enos for the original routine in Sep 1997.

 ;

START ;

 D INIT

 Q:XBQFLG

 D DBQUE

 Q

 ;

INIT ; INITIALIZATION

 D EN^XBVK("XB")

 S (XBBT)=$H,XBJOB=$J

 S XBQFLG=1

 I '$G(DUZ(2)) W !!,"Your DUZ(2) is not set!",!! Q

 I '$G(^AUTTLOC(DUZ(2),0)) W !!,"The site specified in your DUZ(2) does not exist!",!! Q

 KILL ^XTMP("XBSIC",XBJOB)

 D ^XBKVAR

 D ^XBDSET  ;                             get files to check

 I '$O(^UTILITY("XBDSET",XBJOB,0)) Q  ;  quit if no files selected

 S XBQFLG=0

 Q

 ;

DBQUE ; call to XBDBQUE

 W !

 S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P"

 KILL DA

 D ^DIR

 KILL DIR

 Q:$D(DIRUT)

 I Y="B" D BROWSE Q

 S XBRP="LIST^XBSIC",XBRC="FILES^XBSIC",XBRX="EOJ^XBSIC",XBNS="XB"

 D ^XBDBQUE

 Q

 ;

BROWSE ;

 S XBRP="VIEWR^XBLM(""LIST^XBSIC"")"

 S XBRC="FILES^XBSIC",XBRX="EOJ^XBSIC",XBIOP=0

 D ^XBDBQUE

 Q

 ;

FILES ; PROCESS ALL FILES

 S XBFILE=0

 F  S XBFILE=$O(^UTILITY("XBDSET",XBJOB,XBFILE)) Q:'XBFILE  D FILE(XBFILE)  Q:XBQFLG

 Q

 ;

FILE(XBFILE) ; PROCESS ONE FILE (CALLED RECURSIVELY)

 NEW L,V,W,X,Y

 I '$D(ZTQUEUED),'$D(IO("S")),$E(IOST,1,2)="C-" W "."

 S ^XTMP("XBSIC",XBJOB,XBFILE,"!")="" ;  file marker

 F X="FD","ID","SP" D

 .  I '$D(^DD(XBFILE,0,X)) Q  ;            quit if no node

 .  I X="ID",'$O(^DD(XBFILE,0,X,0)) Q  ;   quit if no real identifier

 .  S Y=0

 .  F  S Y=$O(^DD(XBFILE,0,X,Y)) Q:Y=""  I Y D

 ..  S V=$G(^DD(XBFILE,0,X,Y)) ;           get value & set $ZR

 ..  I X="SP" S W=$S(V'="":"="_V,1:"") D SET Q

 ..  I X="ID" S W="" D SET Q

 ..  S L=""

 ..  F  S L=$O(^DD(XBFILE,0,X,Y,L)) Q:L=""  D

 ...  S V=$G(^DD(XBFILE,0,X,Y,L)) ;        get value & set $ZR

 ...  S W="="_V D SET

 ...  Q

 ..  Q

 .  Q

 ;I $P($G(^DD(XBFILE,.01,0)),U,2)["P" S X=^(0) D RECURSE ;ptr chain

 I $P($G(^DD(XBFILE,.01,0)),U,2)["P" S X=^(0) I '(XBFILE=+$P($P(X,U,2),"P",2)) D FILE(+$P($P(X,U,2),"P",2))

 Q

 Q:$G(RECURSE)  ;                           quit if recursing

 S XBFLD=.01

 F  S XBFLD=$O(^DD(XBFILE,XBFLD)) Q:'XBFLD  I $D(^(XBFLD,0)) S X=^(0) D

 .  Q:$P(X,U,2)'["P"  ;                     quit if not pointer

 .  D RECURSE

 .  Q

 Q

 ;

SET ; SET ONE LINE

 S ^XTMP("XBSIC",XBJOB,XBFILE,$$LGR^%ZOSV_W)=""

 Q

 ;

RECURSE ; RECURSE FOR FILES BEING POINTED TO

 Q:XBFILE=+$P($P(X,U,2),"P",2)  ;          quit if self reference

 NEW XBFILE,RECURSE

 S RECURSE=1

 S XBFILE=+$P($P(X,U,2),"P",2)

 D FILE

 Q

 ;

LIST ; LIST OUTPUT

 U IO

 D HEAD

 S XBFILE=0

 F  S XBFILE=$O(^XTMP("XBSIC",XBJOB,XBFILE)) Q:'XBFILE  D  Q:XBQFLG

 .  D F Q:XBQFLG

 .  W !,?4,XBFILE_" ("_$P($G(^DIC(XBFILE,0)),U)_")",!

 .  S XBDEV=""

 .  F  S XBDEV=$O(^XTMP("XBSIC",XBJOB,XBFILE,XBDEV)) Q:XBDEV=""  D WRITE Q:XBQFLG

 .  Q

 Q

 ;

WRITE ; WRITE ONE LINE

 Q:XBDEV="!"  ;                               quit if file marker

 D F

 Q:XBQFLG

 W XBDEV,!

 Q

 ;

F ;Form feed

 I ($Y+4)>IOSL D

 . I '$D(ZTQUEUED),'$D(IO("S")),$E(IOST,1,2)'="P-" D PAUSE S:$D(DIRUT) XBQFLG=1

 . Q:XBQFLG

 . W @IOF

 . D HEAD

 . Q

 Q

 ;

PAUSE ; PAUSE FOR USER

 Q:$E(IOST)'="C"

 Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))

 S DIR(0)="E",DIR("A")="Press any key to continue"

 KILL DIRUT

 D ^DIR

 KILL DIR

 Q

 ;

HEAD ; WRITE HEADER

 I '$D(ZTQUEUED),'$D(IO("S")),$E(IOST,1,2)="C-" W @IOF

 S XBPG=$G(XBPG)+1

 W "     ID/SP/FD REPORT run at ",$P(^AUTTLOC(DUZ(2),0),U,2)," on ",$$FMTE^XLFDT(DT),?75,$J(XBPG,5),!

 W $$REPEAT^XLFSTR("=",80),!

 Q

 ;

Q Q

 ;

EOJ ;

 S XBET=$H,XBTS=(86400*($P(XBET,",")-$P(XBBT,",")))+($P(XBET,",",2)-$P(XBBT,",",2)),XBH=+$P(XBTS/3600,"."),XBTS=XBTS-(XBH*3600),XBM=+$P(XBTS/60,"."),XBTS=XBTS-(XBM*60),XBS=XBTS

 W !!,"RUN TIME (H.M.S): "_XBH_"."_XBM_"."_XBS,!

 KILL ^XTMP("XBSIC",XBJOB)

 KILL ^UTILITY("XBDSET",XBJOB)

 D EN^XBVK("XB")

 Q

 ;

XBSIC     ;IHS/SET/GTH - LIST ID,SP,FD NODES ON SELECTED FILES ; [ 12/05/2002  4:28 PM ]

 +1       ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 +2       ;IHS/SET/GTH XB*3*9 10/29/2002 New Routine.

 +3       ; This routine lists the IDENTIFIERS, SPECIFIERS, and

 +4       ; CONDITIONALS from selected files.

 +5       ;

 +6       ; Thanks to E. Don Enos for the original routine in Sep 1997.

 +7       ;

START     ;

 +1        DO INIT

 +2        IF XBQFLG

               QUIT 

 +3        DO DBQUE

 +4        QUIT 

 +5       ;

INIT      ; INITIALIZATION

 +1        DO EN^XBVK("XB")

 +2        SET (XBBT)=$HOROLOG

           SET XBJOB=$JOB

 +3        SET XBQFLG=1

 +4        IF '$GET(DUZ(2))

               WRITE !!,"Your DUZ(2) is not set!",!!

               QUIT 

 +5        IF '$GET(^AUTTLOC(DUZ(2),0))

               WRITE !!,"The site specified in your DUZ(2) does not exist!",!!

               QUIT 

 +6        KILL ^XTMP("XBSIC",XBJOB)

 +7        DO ^XBKVAR

 +8       ;                             get files to check

           DO ^XBDSET

 +9       ;  quit if no files selected

           IF '$ORDER(^UTILITY("XBDSET",XBJOB,0))

               QUIT 

 +10       SET XBQFLG=0

 +11       QUIT 

 +12      ;

DBQUE     ; call to XBDBQUE

 +1        WRITE !

 +2        SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"

           SET DIR("A")="Do you wish to"

           SET DIR("B")="P"

 +3        KILL DA

 +4        DO ^DIR

 +5        KILL DIR

 +6        IF $DATA(DIRUT)

               QUIT 

 +7        IF Y="B"

               DO BROWSE

               QUIT 

 +8        SET XBRP="LIST^XBSIC"

           SET XBRC="FILES^XBSIC"

           SET XBRX="EOJ^XBSIC"

           SET XBNS="XB"

 +9        DO ^XBDBQUE

 +10       QUIT 

 +11      ;

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""LIST^XBSIC"")"

 +2        SET XBRC="FILES^XBSIC"

           SET XBRX="EOJ^XBSIC"

           SET XBIOP=0

 +3        DO ^XBDBQUE

 +4        QUIT 

 +5       ;

FILES     ; PROCESS ALL FILES

 +1        SET XBFILE=0

 +2        FOR 

               SET XBFILE=$ORDER(^UTILITY("XBDSET",XBJOB,XBFILE))

               IF 'XBFILE

                   QUIT 

               DO FILE(XBFILE)

               IF XBQFLG

                   QUIT 

 +3        QUIT 

 +4       ;

FILE(XBFILE) ; PROCESS ONE FILE (CALLED RECURSIVELY)

 +1        NEW L,V,W,X,Y

 +2        IF '$DATA(ZTQUEUED)

               IF '$DATA(IO("S"))

                   IF $EXTRACT(IOST,1,2)="C-"

                       WRITE "."

 +3       ;  file marker

           SET ^XTMP("XBSIC",XBJOB,XBFILE,"!")=""

 +4        FOR X="FD","ID","SP"

               Begin DoDot:1

 +5       ;            quit if no node

                   IF '$DATA(^DD(XBFILE,0,X))

                       QUIT 

 +6       ;   quit if no real identifier

                   IF X="ID"

                       IF '$ORDER(^DD(XBFILE,0,X,0))

                           QUIT 

 +7                SET Y=0

 +8                FOR 

                       SET Y=$ORDER(^DD(XBFILE,0,X,Y))

                       IF Y=""

                           QUIT 

                       IF Y

                           Begin DoDot:2

 +9       ;           get value & set $ZR

                               SET V=$GET(^DD(XBFILE,0,X,Y))

 +10                           IF X="SP"

                                   SET W=$SELECT(V'="":"="_V,1:"")

                                   DO SET

                                   QUIT 

 +11                           IF X="ID"

                                   SET W=""

                                   DO SET

                                   QUIT 

 +12                           SET L=""

 +13                           FOR 

                                   SET L=$ORDER(^DD(XBFILE,0,X,Y,L))

                                   IF L=""

                                       QUIT 

                                   Begin DoDot:3

 +14      ;        get value & set $ZR

                                       SET V=$GET(^DD(XBFILE,0,X,Y,L))

 +15                                   SET W="="_V

                                       DO SET

 +16                                   QUIT 

                                   End DoDot:3

 +17                           QUIT 

                           End DoDot:2

 +18               QUIT 

               End DoDot:1

 +19      ;I $P($G(^DD(XBFILE,.01,0)),U,2)["P" S X=^(0) D RECURSE ;ptr chain

 +20       IF $PIECE($GET(^DD(XBFILE,.01,0)),U,2)["P"

               SET X=^(0)

               IF '(XBFILE=+$PIECE($PIECE(X,U,2),"P",2))

                   DO FILE(+$PIECE($PIECE(X,U,2),"P",2))

 +21       QUIT 

 +22      ;                           quit if recursing

           IF $GET(RECURSE)

               QUIT 

 +23       SET XBFLD=.01

 +24       FOR 

               SET XBFLD=$ORDER(^DD(XBFILE,XBFLD))

               IF 'XBFLD

                   QUIT 

               IF $DATA(^(XBFLD,0))

                   SET X=^(0)

                   Begin DoDot:1

 +25      ;                     quit if not pointer

                       IF $PIECE(X,U,2)'["P"

                           QUIT 

 +26                   DO RECURSE

 +27                   QUIT 

                   End DoDot:1

 +28       QUIT 

 +29      ;

SET       ; SET ONE LINE

 +1        SET ^XTMP("XBSIC",XBJOB,XBFILE,$$LGR^%ZOSV_W)=""

 +2        QUIT 

 +3       ;

RECURSE   ; RECURSE FOR FILES BEING POINTED TO

 +1       ;          quit if self reference

           IF XBFILE=+$PIECE($PIECE(X,U,2),"P",2)

               QUIT 

 +2        NEW XBFILE,RECURSE

 +3        SET RECURSE=1

 +4        SET XBFILE=+$PIECE($PIECE(X,U,2),"P",2)

 +5        DO FILE

 +6        QUIT 

 +7       ;

LIST      ; LIST OUTPUT

 +1        USE IO

 +2        DO HEAD

 +3        SET XBFILE=0

 +4        FOR 

               SET XBFILE=$ORDER(^XTMP("XBSIC",XBJOB,XBFILE))

               IF 'XBFILE

                   QUIT 

               Begin DoDot:1

 +5                DO F

                   IF XBQFLG

                       QUIT 

 +6                WRITE !,?4,XBFILE_" ("_$PIECE($GET(^DIC(XBFILE,0)),U)_")",!

 +7                SET XBDEV=""

 +8                FOR 

                       SET XBDEV=$ORDER(^XTMP("XBSIC",XBJOB,XBFILE,XBDEV))

                       IF XBDEV=""

                           QUIT 

                       DO WRITE

                       IF XBQFLG

                           QUIT 

 +9                QUIT 

               End DoDot:1

               IF XBQFLG

                   QUIT 

 +10       QUIT 

 +11      ;

WRITE     ; WRITE ONE LINE

 +1       ;                               quit if file marker

           IF XBDEV="!"

               QUIT 

 +2        DO F

 +3        IF XBQFLG

               QUIT 

 +4        WRITE XBDEV,!

 +5        QUIT 

 +6       ;

F         ;Form feed

 +1        IF ($Y+4)>IOSL

               Begin DoDot:1

 +2                IF '$DATA(ZTQUEUED)

                       IF '$DATA(IO("S"))

                           IF $EXTRACT(IOST,1,2)'="P-"

                               DO PAUSE

                               IF $DATA(DIRUT)

                                   SET XBQFLG=1

 +3                IF XBQFLG

                       QUIT 

 +4                WRITE @IOF

 +5                DO HEAD

 +6                QUIT 

               End DoDot:1

 +7        QUIT 

 +8       ;

PAUSE     ; PAUSE FOR USER

 +1        IF $EXTRACT(IOST)'="C"

               QUIT 

 +2        IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))

               QUIT 

 +3        SET DIR(0)="E"

           SET DIR("A")="Press any key to continue"

 +4        KILL DIRUT

 +5        DO ^DIR

 +6        KILL DIR

 +7        QUIT 

 +8       ;

HEAD      ; WRITE HEADER

 +1        IF '$DATA(ZTQUEUED)

               IF '$DATA(IO("S"))

                   IF $EXTRACT(IOST,1,2)="C-"

                       WRITE @IOF

 +2        SET XBPG=$GET(XBPG)+1

 +3        WRITE "     ID/SP/FD REPORT run at ",$PIECE(^AUTTLOC(DUZ(2),0),U,2)," on ",$$FMTE^XLFDT(DT),?75,$JUSTIFY(XBPG,5),!

 +4        WRITE $$REPEAT^XLFSTR("=",80),!

 +5        QUIT 

 +6       ;

Q          QUIT 

 +1       ;

EOJ       ;

 +1        SET XBET=$HOROLOG

           SET XBTS=(86400*($PIECE(XBET,",")-$PIECE(XBBT,",")))+($PIECE(XBET,",",2)-$PIECE(XBBT,",",2))

           SET XBH=+$PIECE(XBTS/3600,".")

           SET XBTS=XBTS-(XBH*3600)

           SET XBM=+$PIECE(XBTS/60,".")

           SET XBTS=XBTS-(XBM*60)

           SET XBS=XBTS

 +2        WRITE !!,"RUN TIME (H.M.S): "_XBH_"."_XBM_"."_XBS,!

 +3        KILL ^XTMP("XBSIC",XBJOB)

 +4        KILL ^UTILITY("XBDSET",XBJOB)

 +5        DO EN^XBVK("XB")

 +6        QUIT 

 +7       ;