XBRXREF2 ; IHS/ADC/GTH - INITIALIZATION ROUTINES FOR DRIVER ; [ 02/07/97 3:02 PM ]
;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
;
; Part of XBRXREF
;
START ;
W !!,"Invalid entry point!",!
S XBRXREF("QFLG")=99
Q
;
INIT ;EP - INITIALIZATION
S U="^"
W !!,"RE-INDEX selected cross-references.",!
S XBRXREF("QFLG")=0
KILL ^TMP("XBRXREF",$J)
Q
;
GETFILE ;EP - GET FILE TO BE RE-XREFED
S DIC="^DIC(",DIC(0)="AEMQ"
D ^DIC
KILL DIC
I Y<0 S XBRXREF("QFLG")=1 Q
S XBRXREF("FILE")=+Y
S XBRXREF("GBL")=^DIC(XBRXREF("FILE"),0,"GL")
Q
;
BLDXRT ;EP - BUILD XREF TABLE
F XBRXREF("L")=0:0 D GETFIELD Q:XBRXREF("FIELD")=""
S:'$O(^TMP("XBRXREF",$J,"")) XBRXREF("QFLG")=1
Q
;
GETFIELD ; GET FIELD TO XREF
W !
S XBRXREF("FIELD")=""
S DIC="^DD("_XBRXREF("FILE")_",",DIC(0)="AEMQ"
D ^DIC
KILL DIC
Q:Y<0
S XBRXREF("FIELD")=+Y
S X=$P(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),0),U,4)
S XBRXREF("NODE")=$P(X,";",1)
S XBRXREF("PIECE")=$P(X,";",2)
I XBRXREF("PIECE")=0 D GFRCR Q
I XBRXREF("NODE")=" " W !!,"Computed fields do not have xrefs." Q
I $D(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1)),$O(^(1,0)) D XREFS Q
W !!,"This field has no xrefs!"
Q
;
GFRCR ; GET FIELD RECURSION
S XBRXREF("SAVE FILE")=XBRXREF("FILE"),XBRXREF("SAVE FIELD")=XBRXREF("FIELD")
F Y="XBRXREF" S %RCR(Y)=""
S XBRXREF("FILE")=+$P(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),0),U,2)
S %RCR="RECURSE^XBRXREF2"
D STORLIST^%RCR
S XBRXREF("FILE")=XBRXREF("SAVE FILE"),XBRXREF("FIELD")=XBRXREF("SAVE FIELD")
Q
;
RECURSE ;
F XBRXREF("L")=0:0 D GETFIELD Q:XBRXREF("FIELD")=""
Q
;
XREFS ; DISPLAY XREFS FOR FIELD
W !,"This field has the following xrefs. Select by number:"
S XBRXREF("XREF")=0
F XBRXREF("L")=0:0 S XBRXREF("XREF")=$O(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"))) Q:XBRXREF("XREF")="" D XREFS2
F XBRXREF("L")=0:0 D GETXREF Q:XBRXREF("XREF")=""
Q
;
XREFS2 ; DISPLAY XREFS
S X=$P(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),0),U,2)
S Y=""
S:X="" Y="TRIGGER"
I Y="",'$F(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),1),"("""_X_"""") S Y="SUB-FILE LEVEL"
W !,XBRXREF("XREF"),?10,X,?20,Y
Q
;
GETXREF ; GET XREFS FROM FIELD
W !
S XBRXREF("XREF")=""
S DIC="^DD("_XBRXREF("FILE")_","_XBRXREF("FIELD")_",1,",DIC(0)="AEMQ"
D ^DIC
Q:Y<0
S XBRXREF("XREF")=+Y
D INFOSAVE
Q
;
INFOSAVE ; GET XREF/NODE/PIECE INFO AND SAVE
S X=$P(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),0),U,2)
I X="" W !!,*7,"Sorry, I don't do TRIGGERS!" Q
I '$F(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),1),"("""_X_"""") W !!,*7,"Sorry, I only do xrefs at the file level!" Q
S ^TMP("XBRXREF",$J,XBRXREF("FILE"),XBRXREF("FIELD"),XBRXREF("XREF"))=X
Q
;
CONFIRM ;EP - GET USER CONFIRMATION
W !!,"The ",$P(^DIC(XBRXREF("FILE"),0),U,1)," file contains ",$P(@(XBRXREF("GBL")_"0)"),U,4)," entries. The following xrefs will be",!,"killed and reset by the specified file or sub-file, and field:",!
S XBRXREF("FILE")=""
F XBRXREF("L")=0:0 S XBRXREF("FILE")=$O(^TMP("XBRXREF",$J,XBRXREF("FILE"))) Q:XBRXREF("FILE")="" D CONFIRM2
R !!,"Do you want to continue (Y/N) Y//",X:$G(DTIME,999)
S:"Yy"'[$E(X) XBRXREF("QFLG")=1
Q
;
CONFIRM2 ;
S XBRXREF("FIELD")=""
F XBRXREF("L")=0:0 S XBRXREF("FIELD")=$O(^TMP("XBRXREF",$J,XBRXREF("FILE"),XBRXREF("FIELD"))) Q:XBRXREF("FIELD")="" D CONFIRM3
Q
;
CONFIRM3 ;
S XBRXREF("XREF")=""
F XBRXREF("L")=0:0 S XBRXREF("XREF")=$O(^TMP("XBRXREF",$J,XBRXREF("FILE"),XBRXREF("FIELD"),XBRXREF("XREF"))) Q:XBRXREF("XREF")="" W !,XBRXREF("FILE"),?15,XBRXREF("FIELD"),?25,^(XBRXREF("XREF"))
Q
;
XBRXREF2 ; IHS/ADC/GTH - INITIALIZATION ROUTINES FOR DRIVER ; [ 02/07/97 3:02 PM ]
+1 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
+2 ;
+3 ; Part of XBRXREF
+4 ;
START ;
+1 WRITE !!,"Invalid entry point!",!
+2 SET XBRXREF("QFLG")=99
+3 QUIT
+4 ;
INIT ;EP - INITIALIZATION
+1 SET U="^"
+2 WRITE !!,"RE-INDEX selected cross-references.",!
+3 SET XBRXREF("QFLG")=0
+4 KILL ^TMP("XBRXREF",$JOB)
+5 QUIT
+6 ;
GETFILE ;EP - GET FILE TO BE RE-XREFED
+1 SET DIC="^DIC("
SET DIC(0)="AEMQ"
+2 DO ^DIC
+3 KILL DIC
+4 IF Y<0
SET XBRXREF("QFLG")=1
QUIT
+5 SET XBRXREF("FILE")=+Y
+6 SET XBRXREF("GBL")=^DIC(XBRXREF("FILE"),0,"GL")
+7 QUIT
+8 ;
BLDXRT ;EP - BUILD XREF TABLE
+1 FOR XBRXREF("L")=0:0
DO GETFIELD
IF XBRXREF("FIELD")=""
QUIT
+2 IF '$ORDER(^TMP("XBRXREF",$JOB,""))
SET XBRXREF("QFLG")=1
+3 QUIT
+4 ;
GETFIELD ; GET FIELD TO XREF
+1 WRITE !
+2 SET XBRXREF("FIELD")=""
+3 SET DIC="^DD("_XBRXREF("FILE")_","
SET DIC(0)="AEMQ"
+4 DO ^DIC
+5 KILL DIC
+6 IF Y<0
QUIT
+7 SET XBRXREF("FIELD")=+Y
+8 SET X=$PIECE(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),0),U,4)
+9 SET XBRXREF("NODE")=$PIECE(X,";",1)
+10 SET XBRXREF("PIECE")=$PIECE(X,";",2)
+11 IF XBRXREF("PIECE")=0
DO GFRCR
QUIT
+12 IF XBRXREF("NODE")=" "
WRITE !!,"Computed fields do not have xrefs."
QUIT
+13 IF $DATA(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1))
IF $ORDER(^(1,0))
DO XREFS
QUIT
+14 WRITE !!,"This field has no xrefs!"
+15 QUIT
+16 ;
GFRCR ; GET FIELD RECURSION
+1 SET XBRXREF("SAVE FILE")=XBRXREF("FILE")
SET XBRXREF("SAVE FIELD")=XBRXREF("FIELD")
+2 FOR Y="XBRXREF"
SET %RCR(Y)=""
+3 SET XBRXREF("FILE")=+$PIECE(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),0),U,2)
+4 SET %RCR="RECURSE^XBRXREF2"
+5 DO STORLIST^%RCR
+6 SET XBRXREF("FILE")=XBRXREF("SAVE FILE")
SET XBRXREF("FIELD")=XBRXREF("SAVE FIELD")
+7 QUIT
+8 ;
RECURSE ;
+1 FOR XBRXREF("L")=0:0
DO GETFIELD
IF XBRXREF("FIELD")=""
QUIT
+2 QUIT
+3 ;
XREFS ; DISPLAY XREFS FOR FIELD
+1 WRITE !,"This field has the following xrefs. Select by number:"
+2 SET XBRXREF("XREF")=0
+3 FOR XBRXREF("L")=0:0
SET XBRXREF("XREF")=$ORDER(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF")))
IF XBRXREF("XREF")=""
QUIT
DO XREFS2
+4 FOR XBRXREF("L")=0:0
DO GETXREF
IF XBRXREF("XREF")=""
QUIT
+5 QUIT
+6 ;
XREFS2 ; DISPLAY XREFS
+1 SET X=$PIECE(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),0),U,2)
+2 SET Y=""
+3 IF X=""
SET Y="TRIGGER"
+4 IF Y=""
IF '$FIND(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),1),"("""_X_"""")
SET Y="SUB-FILE LEVEL"
+5 WRITE !,XBRXREF("XREF"),?10,X,?20,Y
+6 QUIT
+7 ;
GETXREF ; GET XREFS FROM FIELD
+1 WRITE !
+2 SET XBRXREF("XREF")=""
+3 SET DIC="^DD("_XBRXREF("FILE")_","_XBRXREF("FIELD")_",1,"
SET DIC(0)="AEMQ"
+4 DO ^DIC
+5 IF Y<0
QUIT
+6 SET XBRXREF("XREF")=+Y
+7 DO INFOSAVE
+8 QUIT
+9 ;
INFOSAVE ; GET XREF/NODE/PIECE INFO AND SAVE
+1 SET X=$PIECE(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),0),U,2)
+2 IF X=""
WRITE !!,*7,"Sorry, I don't do TRIGGERS!"
QUIT
+3 IF '$FIND(^DD(XBRXREF("FILE"),XBRXREF("FIELD"),1,XBRXREF("XREF"),1),"("""_X_"""")
WRITE !!,*7,"Sorry, I only do xrefs at the file level!"
QUIT
+4 SET ^TMP("XBRXREF",$JOB,XBRXREF("FILE"),XBRXREF("FIELD"),XBRXREF("XREF"))=X
+5 QUIT
+6 ;
CONFIRM ;EP - GET USER CONFIRMATION
+1 WRITE !!,"The ",$PIECE(^DIC(XBRXREF("FILE"),0),U,1)," file contains ",$PIECE(@(XBRXREF("GBL")_"0)"),U,4)," entries. The following xrefs will be",!,"killed and reset by the specified file or sub-file, and field:",!
+2 SET XBRXREF("FILE")=""
+3 FOR XBRXREF("L")=0:0
SET XBRXREF("FILE")=$ORDER(^TMP("XBRXREF",$JOB,XBRXREF("FILE")))
IF XBRXREF("FILE")=""
QUIT
DO CONFIRM2
+4 READ !!,"Do you want to continue (Y/N) Y//",X:$GET(DTIME,999)
+5 IF "Yy"'[$EXTRACT(X)
SET XBRXREF("QFLG")=1
+6 QUIT
+7 ;
CONFIRM2 ;
+1 SET XBRXREF("FIELD")=""
+2 FOR XBRXREF("L")=0:0
SET XBRXREF("FIELD")=$ORDER(^TMP("XBRXREF",$JOB,XBRXREF("FILE"),XBRXREF("FIELD")))
IF XBRXREF("FIELD")=""
QUIT
DO CONFIRM3
+3 QUIT
+4 ;
CONFIRM3 ;
+1 SET XBRXREF("XREF")=""
+2 FOR XBRXREF("L")=0:0
SET XBRXREF("XREF")=$ORDER(^TMP("XBRXREF",$JOB,XBRXREF("FILE"),XBRXREF("FIELD"),XBRXREF("XREF")))
IF XBRXREF("XREF")=""
QUIT
WRITE !,XBRXREF("FILE"),?15,XBRXREF("FIELD"),?25,^(XBRXREF("XREF"))
+3 QUIT
+4 ;
