VistA-IHS-VA_UTILITIES-XB/XBSIC.m

147 lines
3.8 KiB
Mathematica

XBSIC ;IHS/SET/GTH - LIST ID,SP,FD NODES ON SELECTED FILES ; [ 12/05/2002 4:28 PM ]
;;4.0;XB;;Jul 20, 2009;Build 2
;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
;