- DICD ;SFISC/XAK-DISP,SELECT,DELETE,EDIT XREF ;11:26 AM 18 Aug 2000 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**58**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- K DICD S (DA,DL)=+Y D CHIX I 'DQ D ^DICE G Q
- D RD G:$D(DIRUT) Q I Y["C" D ^DICE G Q
- I Y["E" D EDT^DICE G Q
- D DEL G Q
- ;
- DEL I DH(DQ,4) D R Q:'$D(DICD) S DQ=DICD
- I $D(DH(DQ,3)) W !?5,$C(7),"This cross-reference cannot be deleted.",! Q
- ASK S %=2 W !,"Are you sure that you want to delete the CROSS-REFERENCE " D YN^DICN Q:(%<0)!(%=2)
- I %=0 W !?7,"Answer YES if you want to delete the Cross-Reference." G ASK
- W !," ...OK",! K:I["SOUNDEX" ^DD(DI,0,"LOOK"),^("QUES")
- S ^DD(J(N),DL,1,0)="^.1",X=^(DQ,2),Y=$P(I,U,2) I Y?1A.E,+I=J(0),I'["MNEM",I'["MUM" K @(I(0)_"Y)") G DDD
- G DDD:X="Q"!$F(I,"BUL") I $P(I,U,3)]"",I'["MUM",I'["TRIG" D DD G DDD
- S %=1 W "DO YOU WANT THE INDIVIDUAL CROSS-REFERENCE VALUES DELETED" D YN^DICN Q:%<1
- D DD:%=1
- DDD I $D(DDA) S DDA="D" D XA^DICATTA
- S DIK="^DD(J(N),DL,1,",DA(1)=DL,DA(2)=J(N),DA=DQ D ^DIK K DIK,DA
- S DA=DL D DIEZ^DIU0
- D I $D(^DD(J(0),0,"DIK")) S X=^("DIK"),Y=J(0),DMAX=^DD("ROU") D EN^DIKZ
- Q
- ;
- CHIX ;
- K DH S DQ=0,X="CURRENT CROSS-REFERENCE"
- F Y=0:1 S DQ=$O(^DD(DI,DA,1,DQ)) Q:DQ'>0 S DH(DQ)=^(DQ,0),DH(DQ,4)=Y S:$D(^(3)) DH(DQ,3)=^(3)
- W !! I 'Y S DQ=0 W "NO ",X Q
- I Y=1 W X_" IS " S DQ=$O(DH(0)) D L Q:'$D(DICD) S %=2 W !,"WANT TO "_DICD_" IT" D YN^DICN S:%=-1 DICDF=1 S:%=1 DICD=DQ Q
- D M Q:'$D(DICD) S %=2 W !,"WANT TO "_DICD_" ONE OF THEM" D YN^DICN Q:%-1
- R R !,"WHICH NUMBER: ",X:DTIME Q:U[X I X\1'=X!'$D(DH(X)) D M G R
- S DICD=X,I=DH(X) Q
- M W !,"CURRENT CROSS-REFERENCES:" F J=0:0 S J=$O(DH(J)) Q:J'>0 W !?8,J,?14 S DQ=J D L
- Q
- ;
- L S I=DH(DQ),X=$P(I,U,3) S:X="" X="REGULAR" W X
- G E:X["BULL" I X["TRIGGER" S %=+$P(I,U,4),(%F,Y)=+$P(I,U,5) W " OF " D WR^DIDH:$D(^DD(%,Y,0)),N Q
- W " '",$P(I,U,2),"' INDEX OF " I +I=J(0) W "FILE"
- W:'$T $P(^DD(+I,0),U)
- N W:$D(DH(DQ,3)) !?14,"("_DH(DQ,3)_")" Q
- ;
- E F %="CREA","DELE" S %=%_"TE VALUE" I $D(^DD(DI,DA,1,DQ,%)),^(%)'="NO EFFECT" W " ("_^(%)_")"
- D N Q
- ;
- DD ;
- N DIKJ,DA,DV,DH,Y,DCNT,DIK S DIKJ=$J
- K ^UTILITY("DIK",$J) S J=J(N),^($J)=$H,^($J,J,DL,1)=X,Y=$P(^DD(DI,DL,0),U,4),^UTILITY("DIK",$J,J,DL)=$P(Y,";",1),Y=$P(Y,";",2),^(DL,0)="S X=$"_$S(Y:"P(^(X),U,"_Y_")",1:"E(^(X),"_+$E(Y,2,9)_","_$P(Y,",",2)_")")
- I $D(^DD(J,DL,1,DQ,"DIK")) S ^UTILITY("DIK",$J,J,DL,1)="D RCR",^(1,0)=X
- K Y,DA,DV,DH S DH(1)=J(0) F Y=1:1:N S DV(J(Y-1),1)=I(Y),DV(J(Y-1),1,0)=J(Y)
- D WAIT S DIK=DIU,DA=0,DCNT=0 G CNT^DIK1
- ;
- KOLD K DIR S DIR(0)="Y",DIR("A")="DO YOU WANT TO EXECUTE THE OLD KILL LOGIC NOW",DIR("?",1)="Enter 'YES' to execute the original kill logic now.",DIR("?")="Otherwise, enter 'NO'."
- D ^DIR K DIR I 'Y!$D(DIRUT) K DTOUT,DUOUT,DIRUT,DIROUT Q
- N DA W !!,"Executing old kill logic...",! S X=A1(2) D DD Q
- WAIT ;
- W !,"..."
- W $P("HMMM^EXCUSE ME^SORRY","^",$R(3)+1),", ",$P("THIS MAY TAKE A FEW MOMENTS^LET ME PUT YOU ON 'HOLD' FOR A SECOND^HOLD ON^JUST A MOMENT PLEASE^I'M WORKING AS FAST AS I CAN^LET ME THINK ABOUT THAT A MOMENT","^",$R(6)+1)_"..."
- Q
- ;
- RD ;
- N DQ,DH W ! S DIR(0)="SAO^E:EDIT;D:DELETE;C:CREATE",DIR("A")="Choose E (Edit)/D (Delete)/C (Create): "
- S DIR("?",1)="Enter 'E' to edit an existing X-reference",DIR("?",2)=" 'D' to delete it",DIR("?")=" 'C' to create a new X-reference."
- D ^DIR K DIR Q
- ;
- Q D Q^DICE K DICD,DDA Q
- DICD ;SFISC/XAK-DISP,SELECT,DELETE,EDIT XREF ;11:26 AM 18 Aug 2000 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**58**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +4 KILL DICD
- SET (DA,DL)=+Y
- DO CHIX
- IF 'DQ
- DO ^DICE
- GOTO Q
- +5 DO RD
- IF $DATA(DIRUT)
- GOTO Q
- IF Y["C"
- DO ^DICE
- GOTO Q
- +6 IF Y["E"
- DO EDT^DICE
- GOTO Q
- +7 DO DEL
- GOTO Q
- +8 ;
- DEL IF DH(DQ,4)
- DO R
- IF '$DATA(DICD)
- QUIT
- SET DQ=DICD
- +1 IF $DATA(DH(DQ,3))
- WRITE !?5,$CHAR(7),"This cross-reference cannot be deleted.",!
- QUIT
- ASK SET %=2
- WRITE !,"Are you sure that you want to delete the CROSS-REFERENCE "
- DO YN^DICN
- IF (%<0)!(%=2)
- QUIT
- +1 IF %=0
- WRITE !?7,"Answer YES if you want to delete the Cross-Reference."
- GOTO ASK
- +2 WRITE !," ...OK",!
- IF I["SOUNDEX"
- KILL ^DD(DI,0,"LOOK"),^("QUES")
- +3 SET ^DD(J(N),DL,1,0)="^.1"
- SET X=^(DQ,2)
- SET Y=$PIECE(I,U,2)
- IF Y?1A.E
- IF +I=J(0)
- IF I'["MNEM"
- IF I'["MUM"
- KILL @(I(0)_"Y)")
- GOTO DDD
- +4 IF X="Q"!$FIND(I,"BUL")
- GOTO DDD
- IF $PIECE(I,U,3)]""
- IF I'["MUM"
- IF I'["TRIG"
- DO DD
- GOTO DDD
- +5 SET %=1
- WRITE "DO YOU WANT THE INDIVIDUAL CROSS-REFERENCE VALUES DELETED"
- DO YN^DICN
- IF %<1
- QUIT
- +6 IF %=1
- DO DD
- DDD IF $DATA(DDA)
- SET DDA="D"
- DO XA^DICATTA
- +1 SET DIK="^DD(J(N),DL,1,"
- SET DA(1)=DL
- SET DA(2)=J(N)
- SET DA=DQ
- DO ^DIK
- KILL DIK,DA
- +2 SET DA=DL
- DO DIEZ^DIU0
- D IF $DATA(^DD(J(0),0,"DIK"))
- SET X=^("DIK")
- SET Y=J(0)
- SET DMAX=^DD("ROU")
- DO EN^DIKZ
- +1 QUIT
- +2 ;
- CHIX ;
- +1 KILL DH
- SET DQ=0
- SET X="CURRENT CROSS-REFERENCE"
- +2 FOR Y=0:1
- SET DQ=$ORDER(^DD(DI,DA,1,DQ))
- IF DQ'>0
- QUIT
- SET DH(DQ)=^(DQ,0)
- SET DH(DQ,4)=Y
- IF $DATA(^(3))
- SET DH(DQ,3)=^(3)
- +3 WRITE !!
- IF 'Y
- SET DQ=0
- WRITE "NO ",X
- QUIT
- +4 IF Y=1
- WRITE X_" IS "
- SET DQ=$ORDER(DH(0))
- DO L
- IF '$DATA(DICD)
- QUIT
- SET %=2
- WRITE !,"WANT TO "_DICD_" IT"
- DO YN^DICN
- IF %=-1
- SET DICDF=1
- IF %=1
- SET DICD=DQ
- QUIT
- +5 DO M
- IF '$DATA(DICD)
- QUIT
- SET %=2
- WRITE !,"WANT TO "_DICD_" ONE OF THEM"
- DO YN^DICN
- IF %-1
- QUIT
- R READ !,"WHICH NUMBER: ",X:DTIME
- IF U[X
- QUIT
- IF X\1'=X!'$DATA(DH(X))
- DO M
- GOTO R
- +1 SET DICD=X
- SET I=DH(X)
- QUIT
- M WRITE !,"CURRENT CROSS-REFERENCES:"
- FOR J=0:0
- SET J=$ORDER(DH(J))
- IF J'>0
- QUIT
- WRITE !?8,J,?14
- SET DQ=J
- DO L
- +1 QUIT
- +2 ;
- L SET I=DH(DQ)
- SET X=$PIECE(I,U,3)
- IF X=""
- SET X="REGULAR"
- WRITE X
- +1 IF X["BULL"
- GOTO E
- IF X["TRIGGER"
- SET %=+$PIECE(I,U,4)
- SET (%F,Y)=+$PIECE(I,U,5)
- WRITE " OF "
- IF $DATA(^DD(%,Y,0))
- DO WR^DIDH
- DO N
- QUIT
- +2 WRITE " '",$PIECE(I,U,2),"' INDEX OF "
- IF +I=J(0)
- WRITE "FILE"
- +3 IF '$TEST
- WRITE $PIECE(^DD(+I,0),U)
- N IF $DATA(DH(DQ,3))
- WRITE !?14,"("_DH(DQ,3)_")"
- QUIT
- +1 ;
- E FOR %="CREA","DELE"
- SET %=%_"TE VALUE"
- IF $DATA(^DD(DI,DA,1,DQ,%))
- IF ^(%)'="NO EFFECT"
- WRITE " ("_^(%)_")"
- +1 DO N
- QUIT
- +2 ;
- DD ;
- +1 NEW DIKJ,DA,DV,DH,Y,DCNT,DIK
- SET DIKJ=$JOB
- +2 KILL ^UTILITY("DIK",$JOB)
- SET J=J(N)
- SET ^($JOB)=$HOROLOG
- SET ^($JOB,J,DL,1)=X
- SET Y=$PIECE(^DD(DI,DL,0),U,4)
- SET ^UTILITY("DIK",$JOB,J,DL)=$PIECE(Y,";",1)
- SET Y=$PIECE(Y,";",2)
- SET ^(DL,0)="S X=$"_$SELECT(Y:"P(^(X),U,"_Y_")",1:"E(^(X),"_+$EXTRACT(Y,2,9)_","_$PIECE(Y,",",2)_")")
- +3 IF $DATA(^DD(J,DL,1,DQ,"DIK"))
- SET ^UTILITY("DIK",$JOB,J,DL,1)="D RCR"
- SET ^(1,0)=X
- +4 KILL Y,DA,DV,DH
- SET DH(1)=J(0)
- FOR Y=1:1:N
- SET DV(J(Y-1),1)=I(Y)
- SET DV(J(Y-1),1,0)=J(Y)
- +5 DO WAIT
- SET DIK=DIU
- SET DA=0
- SET DCNT=0
- GOTO CNT^DIK1
- +6 ;
- KOLD KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="DO YOU WANT TO EXECUTE THE OLD KILL LOGIC NOW"
- SET DIR("?",1)="Enter 'YES' to execute the original kill logic now."
- SET DIR("?")="Otherwise, enter 'NO'."
- +1 DO ^DIR
- KILL DIR
- IF 'Y!$DATA(DIRUT)
- KILL DTOUT,DUOUT,DIRUT,DIROUT
- QUIT
- +2 NEW DA
- WRITE !!,"Executing old kill logic...",!
- SET X=A1(2)
- DO DD
- QUIT
- WAIT ;
- +1 WRITE !,"..."
- +2 WRITE $PIECE("HMMM^EXCUSE ME^SORRY","^",$RANDOM(3)+1),", ",$PIECE("THIS MAY TAKE A FEW MOMENTS^LET ME PUT YOU ON 'HOLD' FOR A SECOND^HOLD ON^JUST A MOMENT PLEASE^I'M WORKING AS FAST AS I CAN^LET ME THINK ABOUT THAT A MOMENT","^",$RANDOM(6)+1)_"
- ..."
- +3 QUIT
- +4 ;
- RD ;
- +1 NEW DQ,DH
- WRITE !
- SET DIR(0)="SAO^E:EDIT;D:DELETE;C:CREATE"
- SET DIR("A")="Choose E (Edit)/D (Delete)/C (Create): "
- +2 SET DIR("?",1)="Enter 'E' to edit an existing X-reference"
- SET DIR("?",2)=" 'D' to delete it"
- SET DIR("?")=" 'C' to create a new X-reference."
- +3 DO ^DIR
- KILL DIR
- QUIT
- +4 ;
- Q DO Q^DICE
- KILL DICD,DDA
- QUIT
