DICE0.m

DICE0 ;SFISC/GFT,XAK-XREF'S ;5/24/94  2:21 PM

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 S ^DD(J(N),DA,1,0)="^.1",^(DQ,0)=J(N-DH)_U_DE,X=I(0)

 F Y=N:-1:DH+1 S X=X_"DA("_Y_"),"_I(N+1-Y)_","

 S X=X_""""_DE_""",",Y=",DA)" F %=1:1:DH S Y=",DA("_%_")"_Y

 D @DREF ;I DE'="B" K DICOMPX S DE(0)=Y(0) D COND^DICE4 S Y(0)=DE(0) I $D(DCOND) S ^(1)=X_" I X S X=DIV "_^DD(J(N),DA,1,DQ,1),^(2)=X_" I X S X=DIV "_^(2),^("CONDITION")=DCOND(0)

 S DIK="^DD(J(N),",DA(1)=J(N) D IX1^DIK

 I $D(^DD(J(0),0,"DIK")) S X=^("DIK"),Y=J(0),DMAX=^DD("ROU") D EN^DIKZ

 Q

 ;

1 S Y="$E(X,1,30)"_Y,^(2)="K "_X_Y

 S ^DD(J(N),DA,1,DQ,1)="S "_X_Y_"=""""" Q

 ;

2 S ^(0)=^(0)_"^KWIC",^(1)="S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I """_DIKWIC_"""[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2,^DD(""KWIC"")'[I S "_X_"I"_Y_"="""""

 S ^(2)="S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I """_DIKWIC_"""[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2 K "_X_"I"_Y K DIKWIC Q

 ;

3 D 1 S ^(1)="S:'$D("_X_Y_") ^(DA)=1",^(2)="I $D("_X_Y_"),^(DA) K ^(DA)",^(0)=^(0)_"^MNEMONIC" Q

 ;

4 S ^(0)=^(0)_"^MUMPS",^(1)=X(1),^(2)=X(2) K X Q

 ;

5 S ^(0)=^(0)_"^SOUNDEX",X=X_"X_I"_Y,Y="S I=$E(X,1,27) D SOU^DICM ",^(1)=Y_"S "_X_"=""""",^(2)=Y_"K "_X,(^DD(J(N),0,"LOOK"),^("QUES"))="SOUNDEX" Q

 ;

6 ;

 D ^DICE1 G Q:U[X S ^UTILITY("DICE",$J,0)="^^TRIGGER^"_DIN_U_DENEW,^("FIELD")=DCNEW

 F DIK=1,2 D ^DICE2 G M^DICATT:$D(DTOUT),Q:U=X

 I '$D(^DD(DIN,DENEW,9))!($G(^(9))="") S %=2 W !!,"WANT TO PROTECT THE '",DNEW,"' FIELD, SO THAT",!,"IT CAN'T BE CHANGED BY THE 'ENTER & EDIT' ROUTINE" D YN^DICN G QQ:%<0 S:%=1 ^(9)=U

 ;

X ;

 S DA=DL,%Y="^DD("_DI_","_DL_",1,"_DQ_",",%X="^UTILITY(""DICE"",$J," I @("$O("_%Y_"0))>0") W $C(7),!!,"HEY, WHILE WE WERE TALKING, SOMEONE ELSE CREATED CROSS-REFERENCE #"_DQ_"!!!" G Q

 D %XY^%RCR,DSC^DICE,DIEZ^DIU0 I $D(DDA) S DDA="N" D XA^DICATTA

 D:$D(^DD(J(0),0,"DIK")) D^DICD D QQ S DIK="^DD("_DI_","_DL_",1,",(DA,DREF)=DQ,DA(1)=DL,DA(2)=DI,@(DIK_"0)=U_.1") D IX1^DIK W !,"...CROSS-REFERENCE IS SET"

 S %=2 I @(DIK_DREF_",1)'=""Q"""),@("$O("_DIU_"0))>0") W !!,"DO YOU WANT TO RUN THE CROSS-REFERENCE FOR EXISTING ENTRIES NOW" D YN^DICN I %=1 S X=^DD(DI,DL,1,DQ,1) D DD^DICD

Q G Q^DICE

QQ G QQ^DICE

DICE0     ;SFISC/GFT,XAK-XREF'S ;5/24/94  2:21 PM

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        SET ^DD(J(N),DA,1,0)="^.1"

           SET ^(DQ,0)=J(N-DH)_U_DE

           SET X=I(0)

 +4        FOR Y=N:-1:DH+1

               SET X=X_"DA("_Y_"),"_I(N+1-Y)_","

 +5        SET X=X_""""_DE_""","

           SET Y=",DA)"

           FOR %=1:1:DH

               SET Y=",DA("_%_")"_Y

 +6       ;I DE'="B" K DICOMPX S DE(0)=Y(0) D COND^DICE4 S Y(0)=DE(0) I $D(DCOND) S ^(1)=X_" I X S X=DIV "_^DD(J(N),DA,1,DQ,1),^(2)=X_" I X S X=DIV "_^(2),^("CONDITION")=DCOND(0)

           DO @DREF

 +7        SET DIK="^DD(J(N),"

           SET DA(1)=J(N)

           DO IX1^DIK

 +8        IF $DATA(^DD(J(0),0,"DIK"))

               SET X=^("DIK")

               SET Y=J(0)

               SET DMAX=^DD("ROU")

               DO EN^DIKZ

 +9        QUIT 

 +10      ;

1          SET Y="$E(X,1,30)"_Y

           SET ^(2)="K "_X_Y

 +1        SET ^DD(J(N),DA,1,DQ,1)="S "_X_Y_"="""""

           QUIT 

 +2       ;

2          SET ^(0)=^(0)_"^KWIC"

           SET ^(1)="S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I """_DIKWIC_"""[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2,^DD(""KWIC"")'[I S "_X_"I"_Y_"="""""

 +1        SET ^(2)="S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I """_DIKWIC_"""[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2 K "_X_"I"_Y

           KILL DIKWIC

           QUIT 

 +2       ;

3          DO 1

           SET ^(1)="S:'$D("_X_Y_") ^(DA)=1"

           SET ^(2)="I $D("_X_Y_"),^(DA) K ^(DA)"

           SET ^(0)=^(0)_"^MNEMONIC"

           QUIT 

 +1       ;

4          SET ^(0)=^(0)_"^MUMPS"

           SET ^(1)=X(1)

           SET ^(2)=X(2)

           KILL X

           QUIT 

 +1       ;

5          SET ^(0)=^(0)_"^SOUNDEX"

           SET X=X_"X_I"_Y

           SET Y="S I=$E(X,1,27) D SOU^DICM "

           SET ^(1)=Y_"S "_X_"="""""

           SET ^(2)=Y_"K "_X

           SET (^DD(J(N),0,"LOOK"),^("QUES"))="SOUNDEX"

           QUIT 

 +1       ;

6         ;

 +1        DO ^DICE1

           IF U[X

               GOTO Q

           SET ^UTILITY("DICE",$JOB,0)="^^TRIGGER^"_DIN_U_DENEW

           SET ^("FIELD")=DCNEW

 +2        FOR DIK=1,2

               DO ^DICE2

               IF $DATA(DTOUT)

                   GOTO M^DICATT

               IF U=X

                   GOTO Q

 +3        IF '$DATA(^DD(DIN,DENEW,9))!($GET(^(9))="")

               SET %=2

               WRITE !!,"WANT TO PROTECT THE '",DNEW,"' FIELD, SO THAT",!,"IT CAN'T BE CHANGED BY THE 'ENTER & EDIT' ROUTINE"

               DO YN^DICN

               IF %<0

                   GOTO QQ

               IF %=1

                   SET ^(9)=U

 +4       ;

X         ;

 +1        SET DA=DL

           SET %Y="^DD("_DI_","_DL_",1,"_DQ_","

           SET %X="^UTILITY(""DICE"",$J,"

           IF @("$O("_%Y_"0))>0")

               WRITE $CHAR(7),!!,"HEY, WHILE WE WERE TALKING, SOMEONE ELSE CREATED CROSS-REFERENCE #"_DQ_"!!!"

               GOTO Q

 +2        DO %XY^%RCR

           DO DSC^DICE

           DO DIEZ^DIU0

           IF $DATA(DDA)

               SET DDA="N"

               DO XA^DICATTA

 +3        IF $DATA(^DD(J(0),0,"DIK"))

               DO D^DICD

           DO QQ

           SET DIK="^DD("_DI_","_DL_",1,"

           SET (DA,DREF)=DQ

           SET DA(1)=DL

           SET DA(2)=DI

           SET @(DIK_"0)=U_.1")

           DO IX1^DIK

           WRITE !,"...CROSS-REFERENCE IS SET"

 +4        SET %=2

           IF @(DIK_DREF_",1)'=""Q""")

               IF @("$O("_DIU_"0))>0")

                   WRITE !!,"DO YOU WANT TO RUN THE CROSS-REFERENCE FOR EXISTING ENTRIES NOW"

                   DO YN^DICN

                   IF %=1

                       SET X=^DD(DI,DL,1,DQ,1)

                       DO DD^DICD

Q          GOTO Q^DICE

QQ         GOTO QQ^DICE