XBRXREF2.m

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       ;