DIE ;SFISC/GFT,XAK-PROC.DR-STR ;28MAR2006
;;22.0;VA FileMan;**1,4,8,11,59,95,159**;Mar 30, 1999;Build 8
;Per VHA Directive 2004-038, this routine should not be modified.
N DG,DNM,DICRREC K DB I DIE S DIE=^DIC(DIE,0,"GL")
Q:$D(@(DIE_DA_",-9)")) Q:'$D(@(DIE_"0)")) S U="^",DP=+$P(^(0),U,2) Q:$P($G(^DD($$FNO^DILIBF(DP),0,"DI")),U,2)["Y"&'$D(DIOVRD)&'$G(DIFROM)
GO Q:DIE?1"^DIA(".E Q:DA'>0 K DE,DOV,DIOV,DIEC,DTOUT N DIEDA D
. N %
. F %=1:1 Q:'$G(DA(%)) S DIEDA(%)=DA(%)
. S DIEDA=DA
. Q
I $D(DIETMP)[0 N DIETMP S DIETMP=$$GETTMP^DIKC1("DIE")
N DIEFXREF,DIIENS,DIE1,DIE1N K DIEFIRE,DIEBADK,DIESP S DIIENS=$$IENS^DIKCU(DP,.DA)
S DL=1,DIE1=1,D0=DA,DI=DP,DR(1,DP)=DR D INI I $E(DR)'="[" D DR^DIE17
S DP=DI,DA=D0,(DQ,DIEL,DK,DP(0))=0 K DIC("S")
MR S DK=DK+1,DH=$P(DR,";",DK) I +DH=DH S (DI,DM)=DH G S:$D(^DD(DP,DI)),MR
S DI=$P(DH,":",1) I 'DI G K:DI=0,PB
J I DH["//" S DE(DQ+1,0)=$P(DH,"//",2,9),DI=$P(DI,"//",1),DH=""
G K:+DI=DI S DM=+DI,Y=$P(DI,DM,2,99),DI=DM G MR:Y=""!'$D(^DD(DP,DI,0)) S DQ=DQ+1,(DZ,DQ(DQ))=^(0),DIFLD(DQ)=DI
SPC F %=1:1 S DIESP=$P(Y,$C(126),%) Q:DIESP="" D
.I DIESP="d"!(DIESP="R") S $P(DZ,U,2)=$P(DZ,U,2)_DIESP Q
.I DIESP="T"!(DIESP="t") S:$G(^DD(DP,DI,.1))]"" $P(DZ,U)=^(.1) Q
.S $P(DZ,U)=DIESP,DQ(DQ,"CAPTION")=DIESP
S:DH'[$C(126) DH=DH_$C(126) S DQ(DQ)=DZ K DZ G Y
;
K S DM=$P(DH,":",2),DM=$S(DM:DM,1:DI) I DI,$D(^DD(DP,DI)) G S
NX S DI=$O(^DD(DP,DI)) S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM
S I DQ'<50,'$D(DE(DQ+1)) G H
S DQ=DQ+1,DQ(DQ)=^(DI,0),DIFLD(DQ)=DI
Y S Y=$P(DQ(DQ),"^",4),DG=$P(Y,";",1)
;Determine whether field has a xref defined in the Index file
S DIEXREF=0 F S DIEXREF=$O(^DD("IX","F",DP,DI,DIEXREF)) Q:'DIEXREF I $P($G(^DD("IX",DIEXREF,0)),U) S DIEXREF=1 Q
I $D(^DD(DP,DI,1))!($P(DQ(DQ),U,2)["a")!DIEXREF S DE=0,DB=DM,DM=0,DE(Y)=DQ K DIEXREF F DW=1:1 S DE=$O(^DD(DP,DI,1,DE)) Q:DE<1 S DE(Y,DW,1)=^(DE,1),DE(Y,DW,2)=^(2)
I S:DE="" DE=-1
I $P(DQ(DQ),U,2)["a" S DE(Y,DW,2)="S DIIX=2_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y,DW,1)="S DIIX=3_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y)=DQ I ^DD(DP,DI,"AUDIT")="e" S DE(Y,DW,1)="I $D(DE(DE(DQ)))#2 "_DE(Y,DW,1)
S Y=$P(Y,";",2) I DU'=DG S D="",DU=DG,@DC G M:Y=0,B:DU=" ",EQ:DW[0 S D=^(DG)
I Y S:$P(D,"^",Y)]"" DE(DQ)=$P(D,"^",Y)
E S Y=$E(D,+$E(Y,2,9),$P(Y,",",2)) S:Y'?." " DE(DQ)=Y
EQ G MR:DI=DM,NX:DM S DM=DB K DB G D
;
INI K DIC("S") S DIC=DIE,DU=-1,DC="DW=$D("_DIE_DA_",DG))"
Q Q
;
;
MORE ;from ^DIE1
D INI G MR:DI=DM,NX:DI'[U,MR:'$D(^DD(DP,+DI)) S %=$P(DI,U,2),DI=+DI S:%]"" DQ(DQ+1,"CAPTION")=% G S
;
;
JMP ;from ^DIE0
D INI G J
;
PB I DH="" G D:$D(DR(DIE1,DP))<9 S:'$D(DOV) DOV=0,DR(DIE1,DP)=DR S DOV=$O(DR(DIE1,DP,DOV)) S:DOV="" DOV=-1 G D:DOV'>0 S DR=DR(DIE1,DP,DOV),DK=0 G MR
G MR:DH?1"@".N I 'DQ G TEM:DH?1"[".E S:"Q"'=DH DQ=1,DQ(0,1)=DH G MR:$A(DH)-94 S DC=$P(DH,U,1,4) X $P(DH,U,5,999) D DIE1N G O^DIE0
E S DK=DK-1,(DI,DM)=1
D G DQ^DIED
;
H S DI=DI_U G D
;Multiple field
M S Y=$P(DQ(DQ),U,2)_U_DG G DC:DW<9
I $D(DSC(+Y))#2,$P(DSC(+Y),"I $D(^UTILITY(",1)="" S D=DIEL+1 D D1 X DSC(+Y) S D=$O(^(0)) S:D="" D=-1 S @DC S DC=$O(^(DG,0)) S:DC="" DC=-1 G DE
I $D(^(DG,0)) S D=$P(^(0),U,3,4) S:$P(^(0),U,2)'=$P(Y,U) $P(^(0),U,2)=$P(Y,U) ;HMMM
E S D=$O(^(0)) S:D="" D=-1
DE I D>0 S Y=Y_U_D I DP(0)-Y!($P(DP(0),U,2)-DK),$D(^(+D,0)) S DE(DQ)=$P(^(0),U) ;Default value if this isn't same multiple we were down in before
DC S DC=$P(^DD(+Y,0),U,4)_U_Y,%=DQ(DQ),Y=^(.01,0)
MUL I $P(Y,U,2)'["W" S DQ(DQ)=$P($$EZBLD^DIALOG(8042,$G(DQ(DQ,"CAPTION"),$P(Y,U))),":")_U_1_$P(Y,U,2,99) D DIE1N G D ;MULTIPLE-FIELD LABEL
I DQ>1 K DQ(DQ) G E:$D(DE(DQ,0)),H
D
.Q:DH'[$C(126)
.N DIEA S DIEA=$P($P(DH,+DH,2),$C(126)) Q:DIEA=""!(DIEA="d")!(DIEA="R")
.I DIEA="T"!(DIEA="t") S:$D(^DD(+$P(%,U,2),.01,.1)) DQ(DQ,"CAPTION")=^(.1) Q
.S DQ(DQ,"CAPTION")=DIEA
DIWE S Y=$G(DQ(DQ,"CAPTION"),$P(%,U))_U_$P(Y,U,2) D DIEN^DIWE K DQ,DG,DE S DQ=0 G QY^DIE1:$D(DTOUT) G MORE ;WORD-PROCESSING FIELD LABEL
;
D1 Q:D'>0 S:'$D(@("D"_D)) @("D"_D)=0 S D=D-1 G D1
;
DIE1N N M,I S DIE1N="" F I=DK,DK+1 S M=$P(DR,";",I) I M?1"^"1.NP S DIE1N=$P(M,U,2) S:I>DK DK=DK+1 Q ;WPB-0804-30857
Q
;
;
B K DQ(DQ) S DQ=DQ-1,DU=-9 G EQ
;
TEM K:$D(DIETMP)#2 @DIETMP,DIETMP
S Y=0 F S Y=$O(^DIE("B",$P($E(DR,2,99),"]",1),Y)) S:Y="" Y=-1 G Q:Y=-1,Q:'$D(^DIE(+Y,0)) Q:$P(^(0),U,4)=DP
S $P(^(0),U,7)=DT I $G(^("ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) G @^DIE(+Y,"ROU")
S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR
S DIE("^")=DR,DR=$S($D(^DIE(Y,"DR"))#2:^("DR"),1:DR(1,DP)) D DIE K DR S DR=DIE(U)
Q
;
;Silent call concerning editing and filing of data.
;
FILE(DIEFFLAG,DIEFAR,DIEFOUT) ;
G FILEX^DIEF
;
WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ;
G WPX^DIEFW
;
HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ;
G GETX^DIEH
;
VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ;
G VALX^DIEV
;
KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT) ;
G KEYVALX^DIEVK
;
VALS(DIVSFLAG,DIVSEFDA,DIVSIFDA,DIVSMSG) ;
G VALSX^DIEVS
;
CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR) ;
G CHKX^DIEV
;
UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA) ;SEA/TOAD
; ENTRY POINT--update database
; procedure, all passed by value
G ADDX^DICA
;
DIE ;SFISC/GFT,XAK-PROC.DR-STR ;28MAR2006
+1 ;;22.0;VA FileMan;**1,4,8,11,59,95,159**;Mar 30, 1999;Build 8
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 NEW DG,DNM,DICRREC
KILL DB
IF DIE
SET DIE=^DIC(DIE,0,"GL")
+4 IF $DATA(@(DIE_DA_",-9)"))
QUIT
IF '$DATA(@(DIE_"0)"))
QUIT
SET U="^"
SET DP=+$PIECE(^(0),U,2)
IF $PIECE($GET(^DD($$FNO^DILIBF(DP),0,"DI")),U,2)["Y"&'$DATA(DIOVRD)&'$GET(DIFROM)
QUIT
GO IF DIE?1"^DIA(".E
QUIT
IF DA'>0
QUIT
KILL DE,DOV,DIOV,DIEC,DTOUT
NEW DIEDA
Begin DoDot:1
+1 NEW %
+2 FOR %=1:1
IF '$GET(DA(%))
QUIT
SET DIEDA(%)=DA(%)
+3 SET DIEDA=DA
+4 QUIT
End DoDot:1
+5 IF $DATA(DIETMP)[0
NEW DIETMP
SET DIETMP=$$GETTMP^DIKC1("DIE")
+6 NEW DIEFXREF,DIIENS,DIE1,DIE1N
KILL DIEFIRE,DIEBADK,DIESP
SET DIIENS=$$IENS^DIKCU(DP,.DA)
+7 SET DL=1
SET DIE1=1
SET D0=DA
SET DI=DP
SET DR(1,DP)=DR
DO INI
IF $EXTRACT(DR)'="["
DO DR^DIE17
+8 SET DP=DI
SET DA=D0
SET (DQ,DIEL,DK,DP(0))=0
KILL DIC("S")
MR SET DK=DK+1
SET DH=$PIECE(DR,";",DK)
IF +DH=DH
SET (DI,DM)=DH
IF $DATA(^DD(DP,DI))
GOTO S
GOTO MR
+1 SET DI=$PIECE(DH,":",1)
IF 'DI
IF DI=0
GOTO K
GOTO PB
J IF DH["//"
SET DE(DQ+1,0)=$PIECE(DH,"//",2,9)
SET DI=$PIECE(DI,"//",1)
SET DH=""
+1 IF +DI=DI
GOTO K
SET DM=+DI
SET Y=$PIECE(DI,DM,2,99)
SET DI=DM
IF Y=""!'$DATA(^DD(DP,DI,0))
GOTO MR
SET DQ=DQ+1
SET (DZ,DQ(DQ))=^(0)
SET DIFLD(DQ)=DI
SPC FOR %=1:1
SET DIESP=$PIECE(Y,$CHAR(126),%)
IF DIESP=""
QUIT
Begin DoDot:1
+1 IF DIESP="d"!(DIESP="R")
SET $PIECE(DZ,U,2)=$PIECE(DZ,U,2)_DIESP
QUIT
+2 IF DIESP="T"!(DIESP="t")
IF $GET(^DD(DP,DI,.1))]""
SET $PIECE(DZ,U)=^(.1)
QUIT
+3 SET $PIECE(DZ,U)=DIESP
SET DQ(DQ,"CAPTION")=DIESP
End DoDot:1
+4 IF DH'[$CHAR(126)
SET DH=DH_$CHAR(126)
SET DQ(DQ)=DZ
KILL DZ
GOTO Y
+5 ;
K SET DM=$PIECE(DH,":",2)
SET DM=$SELECT(DM:DM,1:DI)
IF DI
IF $DATA(^DD(DP,DI))
GOTO S
NX SET DI=$ORDER(^DD(DP,DI))
IF DI=""
SET DI=-1
IF DI'>0
GOTO MR
IF DI>DM
GOTO MR
S IF DQ'<50
IF '$DATA(DE(DQ+1))
GOTO H
+1 SET DQ=DQ+1
SET DQ(DQ)=^(DI,0)
SET DIFLD(DQ)=DI
Y SET Y=$PIECE(DQ(DQ),"^",4)
SET DG=$PIECE(Y,";",1)
+1 ;Determine whether field has a xref defined in the Index file
+2 SET DIEXREF=0
FOR
SET DIEXREF=$ORDER(^DD("IX","F",DP,DI,DIEXREF))
IF 'DIEXREF
QUIT
IF $PIECE($GET(^DD("IX",DIEXREF,0)),U)
SET DIEXREF=1
QUIT
+3 IF $DATA(^DD(DP,DI,1))!($PIECE(DQ(DQ),U,2)["a")!DIEXREF
SET DE=0
SET DB=DM
SET DM=0
SET DE(Y)=DQ
KILL DIEXREF
FOR DW=1:1
SET DE=$ORDER(^DD(DP,DI,1,DE))
IF DE<1
QUIT
SET DE(Y,DW,1)=^(DE,1)
SET DE(Y,DW,2)=^(2)
+4 IF $TEST
IF DE=""
SET DE=-1
+5 IF $PIECE(DQ(DQ),U,2)["a"
SET DE(Y,DW,2)="S DIIX=2_U_DIFLD(DE(DQ)) D AUDIT^DIET"
SET DE(Y,DW,1)="S DIIX=3_U_DIFLD(DE(DQ)) D AUDIT^DIET"
SET DE(Y)=DQ
IF ^DD(DP,DI,"AUDIT")="e"
SET DE(Y,DW,1)="I $D(DE(DE(DQ)))#2 "_DE(Y,DW,1)
+6 SET Y=$PIECE(Y,";",2)
IF DU'=DG
SET D=""
SET DU=DG
SET @DC
IF Y=0
GOTO M
IF DU=" "
GOTO B
IF DW[0
GOTO EQ
SET D=^(DG)
+7 IF Y
IF $PIECE(D,"^",Y)]""
SET DE(DQ)=$PIECE(D,"^",Y)
+8 IF '$TEST
SET Y=$EXTRACT(D,+$EXTRACT(Y,2,9),$PIECE(Y,",",2))
IF Y'?." "
SET DE(DQ)=Y
EQ IF DI=DM
GOTO MR
IF DM
GOTO NX
SET DM=DB
KILL DB
GOTO D
+1 ;
INI KILL DIC("S")
SET DIC=DIE
SET DU=-1
SET DC="DW=$D("_DIE_DA_",DG))"
Q QUIT
+1 ;
+2 ;
MORE ;from ^DIE1
+1 DO INI
IF DI=DM
GOTO MR
IF DI'[U
GOTO NX
IF '$DATA(^DD(DP,+DI))
GOTO MR
SET %=$PIECE(DI,U,2)
SET DI=+DI
IF %]""
SET DQ(DQ+1,"CAPTION")=%
GOTO S
+2 ;
+3 ;
JMP ;from ^DIE0
+1 DO INI
GOTO J
+2 ;
PB IF DH=""
IF $DATA(DR(DIE1,DP))<9
GOTO D
IF '$DATA(DOV)
SET DOV=0
SET DR(DIE1,DP)=DR
SET DOV=$ORDER(DR(DIE1,DP,DOV))
IF DOV=""
SET DOV=-1
IF DOV'>0
GOTO D
SET DR=DR(DIE1,DP,DOV)
SET DK=0
GOTO MR
+1 IF DH?1"@".N
GOTO MR
IF 'DQ
IF DH?1"[".E
GOTO TEM
IF "Q"'=DH
SET DQ=1
SET DQ(0,1)=DH
IF $ASCII(DH)-94
GOTO MR
SET DC=$PIECE(DH,U,1,4)
XECUTE $PIECE(DH,U,5,999)
DO DIE1N
GOTO O^DIE0
E SET DK=DK-1
SET (DI,DM)=1
D GOTO DQ^DIED
+1 ;
H SET DI=DI_U
GOTO D
+1 ;Multiple field
M SET Y=$PIECE(DQ(DQ),U,2)_U_DG
IF DW<9
GOTO DC
+1 IF $DATA(DSC(+Y))#2
IF $PIECE(DSC(+Y),"I $D(^UTILITY(",1)=""
SET D=DIEL+1
DO D1
XECUTE DSC(+Y)
SET D=$ORDER(^(0))
IF D=""
SET D=-1
SET @DC
SET DC=$ORDER(^(DG,0))
IF DC=""
SET DC=-1
GOTO DE
+2 ;HMMM
IF $DATA(^(DG,0))
SET D=$PIECE(^(0),U,3,4)
IF $PIECE(^(0),U,2)'=$PIECE(Y,U)
SET $PIECE(^(0),U,2)=$PIECE(Y,U)
+3 IF '$TEST
SET D=$ORDER(^(0))
IF D=""
SET D=-1
DE ;Default value if this isn't same multiple we were down in before
IF D>0
SET Y=Y_U_D
IF DP(0)-Y!($PIECE(DP(0),U,2)-DK)
IF $DATA(^(+D,0))
SET DE(DQ)=$PIECE(^(0),U)
DC SET DC=$PIECE(^DD(+Y,0),U,4)_U_Y
SET %=DQ(DQ)
SET Y=^(.01,0)
MUL ;MULTIPLE-FIELD LABEL
IF $PIECE(Y,U,2)'["W"
SET DQ(DQ)=$PIECE($$EZBLD^DIALOG(8042,$GET(DQ(DQ,"CAPTION"),$PIECE(Y,U))),":")_U_1_$PIECE(Y,U,2,99)
DO DIE1N
GOTO D
+1 IF DQ>1
KILL DQ(DQ)
IF $DATA(DE(DQ,0))
GOTO E
GOTO H
+2 Begin DoDot:1
+3 IF DH'[$CHAR(126)
QUIT
+4 NEW DIEA
SET DIEA=$PIECE($PIECE(DH,+DH,2),$CHAR(126))
IF DIEA=""!(DIEA="d")!(DIEA="R")
QUIT
+5 IF DIEA="T"!(DIEA="t")
IF $DATA(^DD(+$PIECE(%,U,2),.01,.1))
SET DQ(DQ,"CAPTION")=^(.1)
QUIT
+6 SET DQ(DQ,"CAPTION")=DIEA
End DoDot:1
DIWE ;WORD-PROCESSING FIELD LABEL
SET Y=$GET(DQ(DQ,"CAPTION"),$PIECE(%,U))_U_$PIECE(Y,U,2)
DO DIEN^DIWE
KILL DQ,DG,DE
SET DQ=0
IF $DATA(DTOUT)
GOTO QY^DIE1
GOTO MORE
+1 ;
D1 IF D'>0
QUIT
IF '$DATA(@("D"_D))
SET @("D"_D)=0
SET D=D-1
GOTO D1
+1 ;
DIE1N ;WPB-0804-30857
NEW M,I
SET DIE1N=""
FOR I=DK,DK+1
SET M=$PIECE(DR,";",I)
IF M?1"^"1.NP
SET DIE1N=$PIECE(M,U,2)
IF I>DK
SET DK=DK+1
QUIT
+1 QUIT
+2 ;
+3 ;
B KILL DQ(DQ)
SET DQ=DQ-1
SET DU=-9
GOTO EQ
+1 ;
TEM IF $DATA(DIETMP)#2
KILL @DIETMP,DIETMP
+1 SET Y=0
FOR
SET Y=$ORDER(^DIE("B",$PIECE($EXTRACT(DR,2,99),"]",1),Y))
IF Y=""
SET Y=-1
IF Y=-1
GOTO Q
IF '$DATA(^DIE(+Y,0))
GOTO Q
IF $PIECE(^(0),U,4)=DP
QUIT
+2 SET $PIECE(^(0),U,7)=DT
IF $GET(^("ROU"))[U
IF $$ROUEXIST^DILIBF($PIECE(^("ROU"),U,2))
GOTO @^DIE(+Y,"ROU")
+3 IF $DATA(^("W"))
SET DIE("W")=^("W")
SET %X="^DIE(+Y,""DR"","
SET %Y="DR("
DO %XY^%RCR
+4 SET DIE("^")=DR
SET DR=$SELECT($DATA(^DIE(Y,"DR"))#2:^("DR"),1:DR(1,DP))
DO DIE
KILL DR
SET DR=DIE(U)
+5 QUIT
+6 ;
+7 ;Silent call concerning editing and filing of data.
+8 ;
FILE(DIEFFLAG,DIEFAR,DIEFOUT) ;
+1 GOTO FILEX^DIEF
+2 ;
WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ;
+1 GOTO WPX^DIEFW
+2 ;
HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ;
+1 GOTO GETX^DIEH
+2 ;
VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ;
+1 GOTO VALX^DIEV
+2 ;
KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT) ;
+1 GOTO KEYVALX^DIEVK
+2 ;
VALS(DIVSFLAG,DIVSEFDA,DIVSIFDA,DIVSMSG) ;
+1 GOTO VALSX^DIEVS
+2 ;
CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR) ;
+1 GOTO CHKX^DIEV
+2 ;
UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA) ;SEA/TOAD
+1 ; ENTRY POINT--update database
+2 ; procedure, all passed by value
+3 GOTO ADDX^DICA
+4 ;
