DIE17 ;SFISC/GFT-COMPILED TMPLT UTIL ;9:08 AM 22 Oct 1999 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**4,11**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
I $D(DTOUT) S X="" G OUT
G:$A(X)-94 X:'$P(DW,";E",2),@("T^"_DNM)
I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,"EXIT NOT ALLOWED " S D="" G X
I $D(DIE("NO^")),X?1"^"1.E,DIE("NO^")'["BACK" W !?3,"JUMPING NOT ALLOWED " S D="" G X
I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE17
S X=$P(X,U,2),DIC(0)="E" G OUT
Z ;
S DL=1,X=0
OUT ;
I 0[X S DM=DW D FILE G ABORT:DL=1,R
S DIC="^DD("_DP_"," G OJ:'$D(^DIE(DIEZ,"AB")) S DIEZAB=$S(DL=1:U,1:DNM(DL,0)_U_DNM(DL)) I X?1"@".N,$D(^("AB",DIEZAB,X)) S DNM=^(X) G JMP
S DDBK=0 I $D(DIE("NO^")),DIE("NO^")["BACK" D DR S DDBK=1,DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)) D S^DIE0"
E S DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)),DIC(0)[""F""!'$D(^(Y,""///""))"
S DIC="^DD("_DP_"," D ^DIC S DIC=DIE I Y<0 S D="" W:DDBK !?3,"JUMPING FORWARD NOT ALLOWED "
I DDBK K DR S DR(1,DP)=^DIE(DIEZ,"ROU"),DR=DI
K A0,A1,DDBK,DIC,DTOUT G X:Y<0 S DNM=^DIE(DIEZ,"AB",DIEZAB,+Y)
JMP K DIEZAB D FILE S Y=DNM,DNM=$P(Y,U,2),DQ=+Y,D=0 D @("DE^"_DNM) G @Y
;
OJ I X?1"@".N,$D(^DIE("AF",X,DIEZ)) S DNM=^(DIEZ)
E S DIC("S")="I $D(^DIE(""AF"","_DP_",Y,DIEZ)),DIC(0)[""F""!'$D(^(DIEZ,""///""))" D ^DIC K DIC S DIC=DIE G X:Y<0 S DNM=^DIE("AF",DP,+Y,DIEZ)
G JMP
F ;
S DC=$S($D(X)#2:X,1:0) D FILE S X=DC Q
FILE ;
K DQ Q:$D(DG)<9 S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU
I DU'<0 S ^(DU)=DV,DU=-2
G E1:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y
PC S $P(DV,U,DW)=DG(DQ) G Y
;
IX D:$D(DE(DQ))#2 @DE(DQ)
K K DE(DQ)
E1 S DQ=$O(DE(" ")) I DQ'="" G IX:$D(DG(DQ)),K
K DG,DE,DIFLD S DQ=0 Q
1 ;
D FILE
R D UP G @("R"_DQ_U_DNM)
;
UP S DNM=DNM(DL),DQ=DNM(DL,0) K DTOUT,DNM(DL) I $D(DIEC(DL)) D DIEC^DIE1 G U
S DIEL=DIEL-1,%=2,DA=DA(1) K DA(1)
DA I $D(DA(%)) S DA(%-1)=DA(%) K DA(%) S %=%+1 G DA
S DIIENS=$P(DIIENS,",",2,999)
U S DL=DL-1 Q
;
X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G Z:$D(DB(DQ))
B G @(DQ_U_DNM)
N ;
D DOWN S DA=$P(DC,U,4),$P(DIIENS,",")=DA,D=0 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
D1 S @("D"_DIEL)=DA G @(DGO)
M ;
S DD=X D DOWN S DO(2)=$P(DC,"^",2),DO=DOW_"^"_DO(2)_"^"_$P(DC,"^",4,5),DIC(0)="LM"_$S($D(DB(DNM(DL,0))):"X",1:"QE") I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2)
E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX")
K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC K DIC("PTRIX")
I Y>0 S DA=+Y,$P(DIIENS,",")=DA,X=$P(Y,U,2),D=$P(Y,U,3) G D1
D UP G @(DQ_U_DNM)
;
DOWN S DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ D FILE
F %=DL+1:-1:1 I $D(DA(%)) S DA(%+1)=DA(%)
S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_""",",DIEL=DIEL+1,DIIENS=","_DIIENS Q
ABORT D E S Y(DM)="" Q
0 ;
D FILE
E D FIREREC K:$D(DIEZTMP)#2 @DIEZTMP
K DIP,Y,DE,DOW,DB,DP,DW,DU,DC,DV,DH,DIL,DNM,DIEZ,DLB,DIEL,DGO,DICRREC Q
DR ;
N F,DA I $E(DR)="[" S %X="^DIE(DIEZ,""DR"",",%Y="DR(" D %XY^%RCR S DR=DR(DL,DP) Q
S F=0 D DICS^DIA F DDW=1:1 S DDW1=$P(DR,";",DDW) Q:DDW1="" I $D(^DD(DI,+DDW1,0)),+$P(^(0),U,2)!(DDW1[":") S X=+DDW1,D(F)=+$P(DDW1,":",2) S:'D(F) D(F)=X D RANGE^DIA1
K DDW,DDW1 Q
;
FIREREC ;Fire the record level xrefs
Q:'$D(DIEZRXR)&$S($D(DIEZTMP)#2:'$D(@DIEZTMP@("R")),1:1)
N DA,DIE,DIEZXR,DIIENS,DIKEY,DP
;
S DP=0 F S DP=$O(DIEZRXR(DP)) Q:'DP D
. S DIIENS=" " F S DIIENS=$O(DIEZRXR(DP,DIIENS)) Q:DIIENS="" D
.. S DIE=DIEZRXR(DP,DIIENS)
.. D DA^DILF(DIIENS,.DA)
.. S DIEZXR=0 F S DIEZXR=$O(DIEZRXR(DP,DIEZXR)) Q:DIEZXR'=+DIEZXR D
... I $D(DIEZAR(DP,DIEZXR))#2 N DIEXEC S DIEXEC="K" D @DIEZAR(DP,DIEZXR)
;
;Fire record level indexes for triggered fields not in the template
S DP=0 F S DP=$O(@DIEZTMP@("R",DP)) Q:'DP D
. S DIIENS=" " F S DIIENS=$O(@DIEZTMP@("R",DP,DIIENS)) Q:DIIENS="" D
.. D DA^DILF(DIIENS,.DA)
.. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIEZTMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A"))
;
;If any keys are invalid, restore values
D:$D(DIKEY)>9 RESTORE^DIE1(.DIKEY,DIEZTMP)
;
K DIEFIRE,DIEZRXR,@DIEZTMP@("V")
Q
;
;===========
; $$UNIQUE
;===========
;Called from compiled routine.
;Look at actual (untruncated) values in the matching indexes.
;Return 1 if unique.
;In:
; DIUIR = Root of matching uniqueness index
; DISETX = Entry point to set X array
; DIMAXL(order#) = max length of subscript with order #
;
UNIQUE(X,DA,DIUIR,DISETX,DIMAXL) ;
N DIDASV,DIIENS,DIIENSC,DINDX,DINS,DIUNIQ,DIXSV,I,O
;
M DIDASV=DA,DIXSV=X
S DIIENSC=$$IENS(.DA)
;
S DIUNIQ=1,DINS=$QL(DIUIR),DINDX=DIUIR
F S DINDX=$Q(@DINDX) Q:$NA(@DINDX,DINS)'=DIUIR D Q:'DIUNIQ
. ;Set DA array, quit if this is index for current record
. S DIIENS=$E(DINDX,$L(DIUIR)+1,$L(DINDX)-1),L=$L(DIIENS,",")
. S DA=$P(DIIENS,",",L) F I=1:1:L-1 S DA(I)=$P(DIIENS,",",L-I)
. S DIIENS=$$IENS(.DA) Q:DIIENS=DIIENSC
. I '$D(DIMAXL) S DIUNIQ=0 Q
. ;
. ;Set the X array for the indexed record and compare
. D @(DISETX_"(""ONFILE"")")
. S O=0 F S O=$O(DIMAXL(O)) Q:'O Q:X(O)'=DIXSV(O)
. S:'O DIUNIQ=0
;
K DA,X M DA=DIDASV,X=DIXSV
Q DIUNIQ
;
UNIQFERR ;The field is part of a key and is not unique
I '$D(ZTQUEUED),'$D(DDS) D
. W $C(7)_"??"
. W:'$D(DB(DQ)) !," Another entry already exists with this key value."
K DIEFXREF S ^("N")=@DIEZTMP@("V",DP,DIIENS,DIFLD,"O")
G:$D(DB(DQ)) Z
S X="?BAD"
G @("QS^"_DNM)
;
IENS(DA) ;Return IENS from DA array
N I,IENS
S IENS=$G(DA)_"," F I=1:1:$O(DA(" "),-1) S IENS=IENS_DA(I)_","
Q IENS
;
TRIG ;Save info for record level indexes on a triggered field.
;Called by DICR (via @DICRREC)
N DIE,DIE17RXR,OLD,XR
S OLD=DIU
;
;Get record level indexes on triggered field
D LOADFLD^DIKC1(DIH,DIG,"KS","",$NA(@DIEZTMP@("V")),"","DIE17RXR","",.RLIST,"f")
Q:RLIST=""
;
S DIE=$$OREF^DILF($NA(@$$FROOTDA^DIKCU(DIH)))
I $D(^DIE("AF",DIH,DIG,DIEZ)) D
. N N,PC,RL,XR
. S RL=RLIST
. F D Q:RL=""
.. F PC=1:1:$L(RL,U) S XR=$P(RL,U,PC) S:XR DIEZRXR(DIH,XR)=""
.. S N=$G(N)+1,RL=$G(RLIST(N))
. S DIEZRXR(DIH,DICRIENS)=DIE
E M @DIEZTMP@("R")=DIE17RXR S @DIEZTMP@("R",DIH,DICRIENS)=DIE
;
;Save the old value of the field
S @DIEZTMP@("V",DIH,DICRIENS,DIG,"O")=OLD S:$D(^("F"))[0 ^("F")=OLD
Q
DIE17 ;SFISC/GFT-COMPILED TMPLT UTIL ;9:08 AM 22 Oct 1999 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**4,11**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 IF $DATA(DTOUT)
SET X=""
GOTO OUT
+5 IF $ASCII(X)-94
IF '$PIECE(DW,";E",2)
GOTO X
GOTO @("T^"_DNM)
+6 IF $DATA(DIE("NO^"))
IF X=U
IF DIE("NO^")'["OUTOK"
WRITE !?3,"EXIT NOT ALLOWED "
SET D=""
GOTO X
+7 IF $DATA(DIE("NO^"))
IF X?1"^"1.E
IF DIE("NO^")'["BACK"
WRITE !?3,"JUMPING NOT ALLOWED "
SET D=""
GOTO X
+8 IF $LENGTH(X,"^")-1>1
SET X=$EXTRACT(X,2,99)
GOTO DIE17
+9 SET X=$PIECE(X,U,2)
SET DIC(0)="E"
GOTO OUT
Z ;
+1 SET DL=1
SET X=0
OUT ;
+1 IF 0[X
SET DM=DW
DO FILE
IF DL=1
GOTO ABORT
GOTO R
+2 SET DIC="^DD("_DP_","
IF '$DATA(^DIE(DIEZ,"AB"))
GOTO OJ
SET DIEZAB=$SELECT(DL=1:U,1:DNM(DL,0)_U_DNM(DL))
IF X?1"@".N
IF $DATA(^("AB",DIEZAB,X))
SET DNM=^(X)
GOTO JMP
+3 SET DDBK=0
IF $DATA(DIE("NO^"))
IF DIE("NO^")["BACK"
DO DR
SET DDBK=1
SET DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)) D S^DIE0"
+4 IF '$TEST
SET DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)),DIC(0)[""F""!'$D(^(Y,""///""))"
+5 SET DIC="^DD("_DP_","
DO ^DIC
SET DIC=DIE
IF Y<0
SET D=""
IF DDBK
WRITE !?3,"JUMPING FORWARD NOT ALLOWED "
+6 IF DDBK
KILL DR
SET DR(1,DP)=^DIE(DIEZ,"ROU")
SET DR=DI
+7 KILL A0,A1,DDBK,DIC,DTOUT
IF Y<0
GOTO X
SET DNM=^DIE(DIEZ,"AB",DIEZAB,+Y)
JMP KILL DIEZAB
DO FILE
SET Y=DNM
SET DNM=$PIECE(Y,U,2)
SET DQ=+Y
SET D=0
DO @("DE^"_DNM)
GOTO @Y
+1 ;
OJ IF X?1"@".N
IF $DATA(^DIE("AF",X,DIEZ))
SET DNM=^(DIEZ)
+1 IF '$TEST
SET DIC("S")="I $D(^DIE(""AF"","_DP_",Y,DIEZ)),DIC(0)[""F""!'$D(^(DIEZ,""///""))"
DO ^DIC
KILL DIC
SET DIC=DIE
IF Y<0
GOTO X
SET DNM=^DIE("AF",DP,+Y,DIEZ)
+2 GOTO JMP
F ;
+1 SET DC=$SELECT($DATA(X)#2:X,1:0)
DO FILE
SET X=DC
QUIT
FILE ;
+1 KILL DQ
IF $DATA(DG)<9
QUIT
SET DQ=""
SET DU=-2
SET DG="$D("_DIE_DA_",DU))"
Y SET DQ=$ORDER(DG(DQ))
SET DW=$PIECE(DQ,";",2)
IF $PIECE(DQ,";",1)=DU
GOTO DE
+1 IF DU'<0
SET ^(DU)=DV
SET DU=-2
+2 IF DQ=""
GOTO E1
SET DU=$PIECE(DQ,";",1)
SET DV=""
IF @DG
SET DV=^(DU)
DE IF 'DW
SET DW=$EXTRACT(DW,2,99)
SET DE=DW-$LENGTH(DV)-1
SET %=$PIECE(DW,",",2)+1
SET X=$EXTRACT(DV,%,999)
SET DV=$EXTRACT(DV,0,DW-1)_$JUSTIFY("",$SELECT(DE>0:DE,1:0))_DG(DQ)
IF X'?." "
SET DV=DV_$JUSTIFY("",%-DW-$LENGTH(DG(DQ)))_X
GOTO Y
PC SET $PIECE(DV,U,DW)=DG(DQ)
GOTO Y
+1 ;
IX IF $DATA(DE(DQ))#2
DO @DE(DQ)
K KILL DE(DQ)
E1 SET DQ=$ORDER(DE(" "))
IF DQ'=""
IF $DATA(DG(DQ))
GOTO IX
GOTO K
+1 KILL DG,DE,DIFLD
SET DQ=0
QUIT
1 ;
+1 DO FILE
R DO UP
GOTO @("R"_DQ_U_DNM)
+1 ;
UP SET DNM=DNM(DL)
SET DQ=DNM(DL,0)
KILL DTOUT,DNM(DL)
IF $DATA(DIEC(DL))
DO DIEC^DIE1
GOTO U
+1 SET DIEL=DIEL-1
SET %=2
SET DA=DA(1)
KILL DA(1)
DA IF $DATA(DA(%))
SET DA(%-1)=DA(%)
KILL DA(%)
SET %=%+1
GOTO DA
+1 SET DIIENS=$PIECE(DIIENS,",",2,999)
U SET DL=DL-1
QUIT
+1 ;
X IF X'["?"&'$DATA(ZTQUEUED)
WRITE $CHAR(7),"??"
IF $DATA(DB(DQ))
GOTO Z
B GOTO @(DQ_U_DNM)
N ;
+1 DO DOWN
SET DA=$PIECE(DC,U,4)
SET $PIECE(DIIENS,",")=DA
SET D=0
SET ^DISV(DUZ,$EXTRACT(DIC,1,28))=$EXTRACT(DIC,29,999)_DA
D1 SET @("D"_DIEL)=DA
GOTO @(DGO)
M ;
+1 SET DD=X
DO DOWN
SET DO(2)=$PIECE(DC,"^",2)
SET DO=DOW_"^"_DO(2)_"^"_$PIECE(DC,"^",4,5)
SET DIC(0)="LM"_$SELECT($DATA(DB(DNM(DL,0))):"X",1:"QE")
IF @("'$D("_DIC_"0))")
SET ^(0)="^"_DO(2)
+2 IF '$TEST
IF DO(2)["I"
SET %=0
SET DIC("W")=""
DO W^DIC1
+3 KILL DIC("PTRIX")
MERGE DIC("PTRIX")=DIE("PTRIX")
+4 KILL DICR
SET D="B"
SET DLAYGO=DP\1
SET X=DD
DO X^DIC
KILL DIC("PTRIX")
+5 IF Y>0
SET DA=+Y
SET $PIECE(DIIENS,",")=DA
SET X=$PIECE(Y,U,2)
SET D=$PIECE(Y,U,3)
GOTO D1
+6 DO UP
GOTO @(DQ_U_DNM)
+7 ;
DOWN SET DL=DL+1
SET DNM(DL)=DNM
SET DNM(DL,0)=DQ
DO FILE
+1 FOR %=DL+1:-1:1
IF $DATA(DA(%))
SET DA(%+1)=DA(%)
+2 SET DA(1)=DA
SET DIC=DIE_DA_","""_$PIECE(DC,U,3)_""","
SET DIEL=DIEL+1
SET DIIENS=","_DIIENS
QUIT
ABORT DO E
SET Y(DM)=""
QUIT
0 ;
+1 DO FILE
E DO FIREREC
IF $DATA(DIEZTMP)#2
KILL @DIEZTMP
+1 KILL DIP,Y,DE,DOW,DB,DP,DW,DU,DC,DV,DH,DIL,DNM,DIEZ,DLB,DIEL,DGO,DICRREC
QUIT
DR ;
+1 NEW F,DA
IF $EXTRACT(DR)="["
SET %X="^DIE(DIEZ,""DR"","
SET %Y="DR("
DO %XY^%RCR
SET DR=DR(DL,DP)
QUIT
+2 SET F=0
DO DICS^DIA
FOR DDW=1:1
SET DDW1=$PIECE(DR,";",DDW)
IF DDW1=""
QUIT
IF $DATA(^DD(DI,+DDW1,0))
IF +$PIECE(^(0),U,2)!(DDW1[":")
SET X=+DDW1
SET D(F)=+$PIECE(DDW1,":",2)
IF 'D(F)
SET D(F)=X
DO RANGE^DIA1
+3 KILL DDW,DDW1
QUIT
+4 ;
FIREREC ;Fire the record level xrefs
+1 IF '$DATA(DIEZRXR)&$SELECT($DATA(DIEZTMP)#2
QUIT
+2 NEW DA,DIE,DIEZXR,DIIENS,DIKEY,DP
+3 ;
+4 SET DP=0
FOR
SET DP=$ORDER(DIEZRXR(DP))
IF 'DP
QUIT
Begin DoDot:1
+5 SET DIIENS=" "
FOR
SET DIIENS=$ORDER(DIEZRXR(DP,DIIENS))
IF DIIENS=""
QUIT
Begin DoDot:2
+6 SET DIE=DIEZRXR(DP,DIIENS)
+7 DO DA^DILF(DIIENS,.DA)
+8 SET DIEZXR=0
FOR
SET DIEZXR=$ORDER(DIEZRXR(DP,DIEZXR))
IF DIEZXR'=+DIEZXR
QUIT
Begin DoDot:3
+9 IF $DATA(DIEZAR(DP,DIEZXR))#2
NEW DIEXEC
SET DIEXEC="K"
DO @DIEZAR(DP,DIEZXR)
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
+11 ;Fire record level indexes for triggered fields not in the template
+12 SET DP=0
FOR
SET DP=$ORDER(@DIEZTMP@("R",DP))
IF 'DP
QUIT
Begin DoDot:1
+13 SET DIIENS=" "
FOR
SET DIIENS=$ORDER(@DIEZTMP@("R",DP,DIIENS))
IF DIIENS=""
QUIT
Begin DoDot:2
+14 DO DA^DILF(DIIENS,.DA)
+15 DO FIRE^DIKC(DP,.DA,"KS",$NAME(@DIEZTMP@("R")),"F^^K",.DIKEY,$EXTRACT("C",$GET(DIOPER)="A"))
End DoDot:2
End DoDot:1
+16 ;
+17 ;If any keys are invalid, restore values
+18 IF $DATA(DIKEY)>9
DO RESTORE^DIE1(.DIKEY,DIEZTMP)
+19 ;
+20 KILL DIEFIRE,DIEZRXR,@DIEZTMP@("V")
+21 QUIT
+22 ;
+23 ;===========
+24 ; $$UNIQUE
+25 ;===========
+26 ;Called from compiled routine.
+27 ;Look at actual (untruncated) values in the matching indexes.
+28 ;Return 1 if unique.
+29 ;In:
+30 ; DIUIR = Root of matching uniqueness index
+31 ; DISETX = Entry point to set X array
+32 ; DIMAXL(order#) = max length of subscript with order #
+33 ;
UNIQUE(X,DA,DIUIR,DISETX,DIMAXL) ;
+1 NEW DIDASV,DIIENS,DIIENSC,DINDX,DINS,DIUNIQ,DIXSV,I,O
+2 ;
+3 MERGE DIDASV=DA,DIXSV=X
+4 SET DIIENSC=$$IENS(.DA)
+5 ;
+6 SET DIUNIQ=1
SET DINS=$QLENGTH(DIUIR)
SET DINDX=DIUIR
+7 FOR
SET DINDX=$QUERY(@DINDX)
IF $NAME(@DINDX,DINS)'=DIUIR
QUIT
Begin DoDot:1
+8 ;Set DA array, quit if this is index for current record
+9 SET DIIENS=$EXTRACT(DINDX,$LENGTH(DIUIR)+1,$LENGTH(DINDX)-1)
SET L=$LENGTH(DIIENS,",")
+10 SET DA=$PIECE(DIIENS,",",L)
FOR I=1:1:L-1
SET DA(I)=$PIECE(DIIENS,",",L-I)
+11 SET DIIENS=$$IENS(.DA)
IF DIIENS=DIIENSC
QUIT
+12 IF '$DATA(DIMAXL)
SET DIUNIQ=0
QUIT
+13 ;
+14 ;Set the X array for the indexed record and compare
+15 DO @(DISETX_"(""ONFILE"")")
+16 SET O=0
FOR
SET O=$ORDER(DIMAXL(O))
IF 'O
QUIT
IF X(O)'=DIXSV(O)
QUIT
+17 IF 'O
SET DIUNIQ=0
End DoDot:1
IF 'DIUNIQ
QUIT
+18 ;
+19 KILL DA,X
MERGE DA=DIDASV,X=DIXSV
+20 QUIT DIUNIQ
+21 ;
UNIQFERR ;The field is part of a key and is not unique
+1 IF '$DATA(ZTQUEUED)
IF '$DATA(DDS)
Begin DoDot:1
+2 WRITE $CHAR(7)_"??"
+3 IF '$DATA(DB(DQ))
WRITE !," Another entry already exists with this key value."
End DoDot:1
+4 KILL DIEFXREF
SET ^("N")=@DIEZTMP@("V",DP,DIIENS,DIFLD,"O")
+5 IF $DATA(DB(DQ))
GOTO Z
+6 SET X="?BAD"
+7 GOTO @("QS^"_DNM)
+8 ;
IENS(DA) ;Return IENS from DA array
+1 NEW I,IENS
+2 SET IENS=$GET(DA)_","
FOR I=1:1:$ORDER(DA(" "),-1)
SET IENS=IENS_DA(I)_","
+3 QUIT IENS
+4 ;
TRIG ;Save info for record level indexes on a triggered field.
+1 ;Called by DICR (via @DICRREC)
+2 NEW DIE,DIE17RXR,OLD,XR
+3 SET OLD=DIU
+4 ;
+5 ;Get record level indexes on triggered field
+6 DO LOADFLD^DIKC1(DIH,DIG,"KS","",$NAME(@DIEZTMP@("V")),"","DIE17RXR","",.RLIST,"f")
+7 IF RLIST=""
QUIT
+8 ;
+9 SET DIE=$$OREF^DILF($NAME(@$$FROOTDA^DIKCU(DIH)))
+10 IF $DATA(^DIE("AF",DIH,DIG,DIEZ))
Begin DoDot:1
+11 NEW N,PC,RL,XR
+12 SET RL=RLIST
+13 FOR
Begin DoDot:2
+14 FOR PC=1:1:$LENGTH(RL,U)
SET XR=$PIECE(RL,U,PC)
IF XR
SET DIEZRXR(DIH,XR)=""
+15 SET N=$GET(N)+1
SET RL=$GET(RLIST(N))
End DoDot:2
IF RL=""
QUIT
+16 SET DIEZRXR(DIH,DICRIENS)=DIE
End DoDot:1
+17 IF '$TEST
MERGE @DIEZTMP@("R")=DIE17RXR
SET @DIEZTMP@("R",DIH,DICRIENS)=DIE
+18 ;
+19 ;Save the old value of the field
+20 SET @DIEZTMP@("V",DIH,DICRIENS,DIG,"O")=OLD
IF $DATA(^("F"))[0
SET ^("F")=OLD
+21 QUIT
