DICD ;SFISC/XAK-DISP,SELECT,DELETE,EDIT XREF ;11:26 AM 18 Aug 2000
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICD 3599 printed Sep 23, 2025@20:21:58 Page 2
DICD ;SFISC/XAK-DISP,SELECT,DELETE,EDIT XREF ;11:26 AM 18 Aug 2000
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 KILL DICD
SET (DA,DL)=+Y
DO CHIX
IF 'DQ
DO ^DICE
GOTO Q
+8 DO RD
if $DATA(DIRUT)
GOTO Q
IF Y["C"
DO ^DICE
GOTO Q
+9 IF Y["E"
DO EDT^DICE
GOTO Q
+10 DO DEL
GOTO Q
+11 ;
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
