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 ;
