DIED ;SFISC/GFT,XAK - MAJOR INPUT PROCESSOR ;9MAY2016
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;;GFT;**4,21,11,59,96,999,1004,1022,1052**
;
O D W W Y W:$X>48 !?9
I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
I Y]"" W "// " I 'DV,DV["I",$D(DE(DQ))#2 K X S X("FIELD")=DIFLD,X("FILE")=DP,X=" ("_$$EZBLD^DIALOG(3090,$$LABEL^DIALOGZ(DP,DIFLD))_")" W:$L(X)+$X>78 !?9 W X K X S X="" Q ;**
TR Q:$P(DQ(DQ),U,2)["K"&(DUZ(0)'="@") R X:DTIME E S (DTOUT,X)=U W $C(7)
Q
W I $P(DQ(DQ),U,2)["K"&(DUZ(0)'="@") Q
I $D(DIE("W")) X DIE("W") Q
W !?DL+DL-2,$P(DQ(DQ),U,1)_": " Q
;
DQ ;
S:$D(DTIME)[0 DTIME=300 S DQ=1 G B
A K DQ(DQ) S DQ=DQ+1
B ;COME BACK HERE FROM DIE2
S DIFLD=$S($D(DIFLD(DQ)):DIFLD(DQ),1:-1)
I '$D(DQ(DQ)) G E^DIE1:'$D(DQ(0,DQ)),BR^DIE0
RE ;
S DIP=$P(DQ(DQ),U,1),DV=$P(DQ(DQ),U,2),DU=$P(DQ(DQ),U,3) G:DV["K"&(DUZ(0)'="@") A G PR:$D(DE(DQ)) D W,TR I $D(DTOUT) K DQ,DG G QY^DIE1
N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:$P(DC,U,2)-DP(0),A
RD G ^DIE0:X[U I X="@" G:DV'["I"!'DV ^DIE2 D NO^DIE0 G B ;You can't delete an uneditable MULTIPLE
I X?."?" G A:$D(DB(DQ)),^DIEQ ;MAC-1201-61253
I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DIP)) S X=^(DIP) I DV'["D",DV'["S" W " "_X
T G M^DIE1:DV,^DIE3:DV["V",X:X'?.ANP
I DV["t" D G UNIQ ;EXTENSIBLE DATA TYPES
.X $S($D(DB(DQ)):$$VALEXTS^DIETLIBF(DP,DIFLD),1:$$VALEXT^DIETLIBF(DP,DIFLD)) K DIPA ;presence of DB array tells that value is stuffed (Silent)
I DV["S" D SET G V:'DDER K DDER G X
P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G AST:DV["*" D NOSCR S X=+Y,DIC=DIE G X:X<0
G V:DV'["N" I $L($P(X,"."))>24 K X G Z
I $P(DQ(DQ),U,5,99)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
V S DIER=1 X $P(DQ(DQ),U,5,99) K DIER,YS
UNIQ I $P(DQ(DQ),U,2)["U",$D(X),DIFLD=.01 K % M %=@(DIE_"""B"",X)") K %(DA) K:$O(%(0)) X
Z K DIC("S"),DLAYGO I $D(X),X?.ANP,X'=U D LOADXR G:'$$KEYCHK UNIQFERR S DG($P(DQ(DQ),U,4))=X S:DV["d" ^DISV(DUZ,"DIE",DIP)=X G A
X W:'$D(ZTQUEUED) $C(7) W:'$D(DDS)&'$D(ZTQUEUED) "??"
G B^DIE1
;
PR I $D(DE(DQ,0)) S Y=DE(DQ,0) G F:Y?1"/".E I $D(DE(DQ))=10 D Y:$E(Y)=U,O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
S DG=DV,Y=DE(DQ),X=DU I DG["O",$D(^DD(DP,DIFLD,2)) X ^(2) G S
I DG["t" X $$OUTPUT^DIETLIBF(DP,DIFLD) K DIPA G S
R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G S:'$D(^(Y,0)) S Y=$P(^(0),U,1),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G S:'$D(^(+Y,0)) S Y=$P(^(0),U,1) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
X:DG["D" ^DD("DD")
I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") I %]"" S Y=$S($G(DUZ("LANG"))'>1:%,'DIFLD:%,1:$$SET^DIQ(DP,DIFLD,Y))
S D O I $D(DTOUT) K DQ,DG G QY^DIE1
I X="" S X=DE(DQ) X:$D(DICATTZ) $P(DQ(DQ),U,5,99) G A:'DV,A:DC<2 G N^DIE1
G RD:DQ(DQ)'["DINUM" D E^DIE0 G RD:$D(X),PR
;
F S DB(DQ)=1,X=$E(Y,2,999),DH=$F(DQ(DQ),"%DT=""E") I DH S DQ(DQ)=$E(DQ(DQ),1,DH-2)_$E(DQ(DQ),DH,999)
I X?1"/".E S X=$E(X,2,999),DH=""
X:$E(X,1)=U $E(X,2,999) G:X="" A:'DV,A:'$P(DC,U,4),N^DIE1 I $D(DE(DQ))#2,DV["I"!(DQ(DQ)["DINUM") D E^DIE0
G X:'$D(X),RD:DH]"",RD:X="@",M^DIE1:DV,Z
;
Y X $E(Y,2,999) S Y=X I DV["D",Y?7N.NP X ^DD("DD")
Q Q
;
SET ;FROM COMPILED TEMPLATES,TOO
N DILANG
I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
I $G(DUZ("LANG"))>1,$D(^DD(DP,+$G(DIFLD),0)) S DILANG=$$SETIN^DIALOGZ D
.I DILANG'=DU S DU=DILANG Q
.K DILANG
I $D(^DD(DP,DIFLD,12.1)) X ^(12.1) ;CODE TO SET POINTER SCREEN DIC("S") IS SAME AS SET SCREEN
D READSET(.X,DU,$G(DIC("S"))) S DDER='$D(X)
Q
;
READSET(X,DU,DISCR) ;X=INCOMING VALUE, DU=SET OF CODES, DISCR=SCREENING LOGIC X IS KILLED IF BAD
N DIR,Y,%,DDER
S DIR(0)="SV"_$E("o",$G(DIQUIET))_U_DU,DIR("V")=1 S:$G(DISCR)]"" DIR("S")=DISCR D ^DIR I DDER K X Q ;Call the READER
I $D(DILANG) S %=$F(";"_DILANG,";"_Y) I % S Y=$P($P($P(^DD(DP,DIFLD,0),U,3),";",Y),":") ;Return the 'REAL' internal value
S %=Y(0),X=Y
W:'$G(DIQUIET) " "_%
Q
;
;
AST ;G V:DV["'",AST^DIE9
I DV["'" D
. D SCRNL(.DICONT)
E D SCRL(.DICONT)
I DICONT="V" K DICONT G V:$D(DNM)[0,@("V^"_DNM)
I DICONT="X" K DICONT G X:$D(DNM)[0,@("X^"_DNM)
I DICONT="Z" K DICONT G Z:$D(DNM)[0,@("Z^"_DNM)
Q
;
RW G RW^DIR2
;
LOADXR ;Load all index file xrefs for a field
Q:$D(DIETMP)[0
N FLIST,RLIST,OLD
;
I $G(DICRREC)]"" N DP,DIFLD,DIIENS S OLD=DIU,DP=DIH,DIFLD=DIG,DIIENS=DICRIENS
E S OLD=$G(DE(DQ))
;
;Get field- and record-level xrefs
D LOADFLD^DIKC1(DP,DIFLD,"KS","",$NA(@DIETMP@("V")),"DIEFXREF",$NA(@DIETMP@("R")),.FLIST,.RLIST)
I FLIST="",RLIST="" Q
S:RLIST]"" @DIETMP@("R",DP,DIIENS)=DIE
;
;Save the old value of the field
S @DIETMP@("V",DP,DIIENS,DIFLD,"O")=OLD S:$D(^("F"))[0 ^("F")=OLD
I $G(DICRREC)="",$G(DE(DQ,0))?1"//".E S @DIETMP@("V",DP,DIIENS,DIFLD,"4/")=""
E K @DIETMP@("V",DP,DIIENS,DIFLD,"4/")
Q
;
KEYCHK() ;If this is a key field, return 0 if not unique.
N DIEKCHK
Q:$D(DIETMP)[0 1
Q:'$D(DIEFXREF) 1
Q:$G(DE(DQ,0))?1"//".E 1
S @DIETMP@("V",DP,DIIENS,DIFLD,"N")=X
S DIEKCHK=$$KEYCHK^DIKK2(DP,.DA,DIFLD,"DIEFXREF",DIIENS,"","N")
K @DIETMP@("V",DP,DIIENS,DIFLD,"N")
Q DIEKCHK
;
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)) !," ",$$EZBLD^DIALOG(3094)
K DIEFXREF S ^("N")=@DIETMP@("V",DP,DIIENS,DIFLD,"O")
G B^DIE1
;
NKEY ;No value was assigned to this key field
I '$D(ZTQUEUED),'$D(DDS) W $C(7)_"?? ",$$EZBLD^DIALOG(3092.2)
G B^DIE1
;
NOSCR ;No screen
N DIXRL
D GETXRL(DP,DIFLD,+$P(DV,"P",2),.DIXRL)
I DV'["'",$G(DIXRL)]"",(U_DIXRL_U)'["^B^" S DIXRL=DIXRL_"^B"
D DIC($G(DIXRL))
Q
;
SCRNL(DICONT) ;Screen, No LAYGO allowed
N DIFRST,DILAST,DIXRL
K DICONT
;
D GETXRL(DP,DIFLD,+$P(DV,"P",2),.DIXRL)
G:$G(DIXRL)="" EXIT
;
D:$D(DNM)#2 @("D^"_DNM)
D PARSE($P(DQ(DQ),U,5,999),.DIFRST,.DILAST)
G:'$D(DIFRST) EXIT
;
X DIFRST
D DIC(DIXRL) S X=+Y
X:Y>0 DILAST
S DICONT=$S('$D(X):"X",X<0:"X",1:"Z")
Q
;
SCRL(DICONT) ;Screen, LAYGO allowed
N DICALL,DICSS,DIFRST,DILAST,DIXRL
K DICONT
;
D GETXRL(DP,DIFLD,+$P(DV,"P",2),.DIXRL)
D:$D(DNM) @("D^"_DNM)
D PARSE($P(DQ(DQ),U,5,999),.DIFRST,.DILAST)
G:'$D(DIFRST) EXIT
;
K D X DIFRST I '$D(DIC("S")),$G(DIXRL)="" S DICONT="V" Q
S DICSS=$G(DIC("S"))
;
I $G(DIXRL)="" S DIXRL=$G(D)
E S:(U_DIXRL_U)'["^B^" DIXRL=DIXRL_"^B"
D DIC($G(DIXRL))
S X=+Y
;
I $P(Y,U,3) S Y=+Y X:$D(@(DIC_Y_",0)")) DICSS E D S DICONT="X" Q
. N DV,DU,DA
. S DA=Y,DIK=DIC D ^DIK
;
X:Y>0 DILAST
S DICONT=$S('$D(X):"X",X<0:"X",1:"Z")
Q
;
EXIT ;Cleanup and set flag to continue by executing the input transform
K DIC("PTRIX")
S DICONT="V"
Q
;
DIC(D) ;Make the appropriate ^DIC call based on D
I $G(D)]"",$P(D,U,2)="" S DIC(0)=$TR(DIC(0),"M")
E S:DIC(0)'["M" DIC(0)="M"_DIC(0)
;
I $P($G(D),U)="" D
. D ^DIC
E I $P(D,U,2)]"" D
. D MIX^DIC1
E D IX^DIC
K DIC("PTRIX")
Q
;
PARSE(IT,FRST,LAST) ;Parse input transform
N CALL,I
F CALL=" D ^DIC"," D IX^DIC"," D MIX^DIC1","" Q:IT[CALL
I CALL="" K FRST,LAST Q
S FRST=$P(IT,CALL),LAST=$P(IT,CALL_" ",2,999)
I FRST?.E1" " D S FRST=$E(FRST,1,I)
. F I=$L(FRST)-1:-1:0 Q:$E(FRST,I)'=" "
Q
;
GETXRL(FIL,FLD,PFIL,LIST) ;Get list of indexes from DIE("PTRIX")
K DIC("PTRIX"),LIST Q:'$D(DIE("PTRIX"))
M DIC("PTRIX")=DIE("PTRIX")
;
S LIST=$G(DIE("PTRIX",FIL,FLD,PFIL))
K:LIST="" LIST
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIED 7793 printed Oct 16, 2024@18:47:39 Page 2
DIED ;SFISC/GFT,XAK - MAJOR INPUT PROCESSOR ;9MAY2016
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 ;;GFT;**4,21,11,59,96,999,1004,1022,1052**
+7 ;
O DO W
WRITE Y
if $X>48
WRITE !?9
+1 IF $LENGTH(Y)>19
IF 'DV
IF DV'["I"
IF (DV["F"!(DV["K"))
GOTO RW^DIR2
+2 ;**
IF Y]""
WRITE "// "
IF 'DV
IF DV["I"
IF $DATA(DE(DQ))#2
KILL X
SET X("FIELD")=DIFLD
SET X("FILE")=DP
SET X=" ("_$$EZBLD^DIALOG(3090,$$LABEL^DIALOGZ(DP,DIFLD))_")"
if $LENGTH(X)+$X>78
WRITE !?9
WRITE X
KILL X
SET X=""
QUIT
TR if $PIECE(DQ(DQ),U,2)["K"&(DUZ(0)'="@")
QUIT
READ X:DTIME
IF '$TEST
SET (DTOUT,X)=U
WRITE $CHAR(7)
+1 QUIT
W IF $PIECE(DQ(DQ),U,2)["K"&(DUZ(0)'="@")
QUIT
+1 IF $DATA(DIE("W"))
XECUTE DIE("W")
QUIT
+2 WRITE !?DL+DL-2,$PIECE(DQ(DQ),U,1)_": "
QUIT
+3 ;
DQ ;
+1 if $DATA(DTIME)[0
SET DTIME=300
SET DQ=1
GOTO B
A KILL DQ(DQ)
SET DQ=DQ+1
B ;COME BACK HERE FROM DIE2
+1 SET DIFLD=$SELECT($DATA(DIFLD(DQ)):DIFLD(DQ),1:-1)
+2 IF '$DATA(DQ(DQ))
if '$DATA(DQ(0,DQ))
GOTO E^DIE1
GOTO BR^DIE0
RE ;
+1 SET DIP=$PIECE(DQ(DQ),U,1)
SET DV=$PIECE(DQ(DQ),U,2)
SET DU=$PIECE(DQ(DQ),U,3)
if DV["K"&(DUZ(0)'="@")
GOTO A
if $DATA(DE(DQ))
GOTO PR
DO W
DO TR
IF $DATA(DTOUT)
KILL DQ,DG
GOTO QY^DIE1
N IF X=""
if $DATA(^DD("KEY","F",DP,DIFLD))
GOTO NKEY
if DV'["R"
GOTO A
if 'DV
GOTO X
if $PIECE(DC,U,2)-DP(0)
GOTO X
GOTO A
RD ;You can't delete an uneditable MULTIPLE
if X[U
GOTO ^DIE0
IF X="@"
if DV'["I"!'DV
GOTO ^DIE2
DO NO^DIE0
GOTO B
+1 ;MAC-1201-61253
IF X?."?"
if $DATA(DB(DQ))
GOTO A
GOTO ^DIEQ
+2 IF X=" "
IF DV["d"
IF DV'["P"
IF $DATA(^DISV(DUZ,"DIE",DIP))
SET X=^(DIP)
IF DV'["D"
IF DV'["S"
WRITE " "_X
T if DV
GOTO M^DIE1
if DV["V"
GOTO ^DIE3
if X'?.ANP
GOTO X
+1 ;EXTENSIBLE DATA TYPES
IF DV["t"
Begin DoDot:1
+2 ;presence of DB array tells that value is stuffed (Silent)
XECUTE $SELECT($DATA(DB(DQ)):$$VALEXTS^DIETLIBF(DP,DIFLD),1:$$VALEXT^DIETLIBF(DP,DIFLD))
KILL DIPA
End DoDot:1
GOTO UNIQ
+3 IF DV["S"
DO SET
if 'DDER
GOTO V
KILL DDER
GOTO X
P IF DV["P"
SET DIC=U_DU
SET DIC(0)=$EXTRACT("EN",$DATA(DB(DQ))+1)_"M"_$EXTRACT("L",DV'["'")
if DIC(0)["L"
SET DLAYGO=+$PIECE(DV,"P",2)
if DV["*"
GOTO AST
DO NOSCR
SET X=+Y
SET DIC=DIE
if X<0
GOTO X
+1 if DV'["N"
GOTO V
IF $LENGTH($PIECE(X,"."))>24
KILL X
GOTO Z
+2 IF $PIECE(DQ(DQ),U,5,99)'["$"
IF X?.1"-".N.1".".N
IF $PIECE(DQ(DQ),U,5,99)["+X'=X"
SET X=+X
V SET DIER=1
XECUTE $PIECE(DQ(DQ),U,5,99)
KILL DIER,YS
UNIQ IF $PIECE(DQ(DQ),U,2)["U"
IF $DATA(X)
IF DIFLD=.01
KILL %
MERGE %=@(DIE_"""B"",X)")
KILL %(DA)
if $ORDER(%(0))
KILL X
Z KILL DIC("S"),DLAYGO
IF $DATA(X)
IF X?.ANP
IF X'=U
DO LOADXR
if '$$KEYCHK
GOTO UNIQFERR
SET DG($PIECE(DQ(DQ),U,4))=X
if DV["d"
SET ^DISV(DUZ,"DIE",DIP)=X
GOTO A
X if '$DATA(ZTQUEUED)
WRITE $CHAR(7)
if '$DATA(DDS)&'$DATA(ZTQUEUED)
WRITE "??"
+1 GOTO B^DIE1
+2 ;
PR IF $DATA(DE(DQ,0))
SET Y=DE(DQ,0)
if Y?1"/".E
GOTO F
IF $DATA(DE(DQ))=10
if $EXTRACT(Y)=U
DO Y
DO O
if "@"'[X
GOTO RD
if DV'["R"&(X="@")
GOTO A
if X="@"
GOTO X
SET X=Y
GOTO N
+1 SET DG=DV
SET Y=DE(DQ)
SET X=DU
IF DG["O"
IF $DATA(^DD(DP,DIFLD,2))
XECUTE ^(2)
GOTO S
+2 IF DG["t"
XECUTE $$OUTPUT^DIETLIBF(DP,DIFLD)
KILL DIPA
GOTO S
R IF DG["P"
IF @("$D(^"_X_"0))")
SET X=+$PIECE(^(0),U,2)
if '$DATA(^(Y,0))
GOTO S
SET Y=$PIECE(^(0),U,1)
SET X=$PIECE(^DD(X,.01,0),U,3)
SET DG=$PIECE(^(0),U,2)
GOTO R
+1 IF DG["V"
IF +Y
IF $PIECE(Y,";",2)["("
IF $DATA(@(U_$PIECE(Y,";",2)_"0)"))
SET X=+$PIECE(^(0),U,2)
if '$DATA(^(+Y,0))
GOTO S
SET Y=$PIECE(^(0),U,1)
IF $DATA(^DD(+X,.01,0))
SET DG=$PIECE(^(0),U,2)
SET X=$PIECE(^(0),U,3)
GOTO R
+2 if DG["D"
XECUTE ^DD("DD")
+3 IF DG["S"
SET %=$PIECE($PIECE(";"_X,";"_Y_":",2),";")
IF %]""
SET Y=$SELECT($GET(DUZ("LANG"))'>1:%,'DIFLD:%,1:$$SET^DIQ(DP,DIFLD,Y))
S DO O
IF $DATA(DTOUT)
KILL DQ,DG
GOTO QY^DIE1
+1 IF X=""
SET X=DE(DQ)
if $DATA(DICATTZ)
XECUTE $PIECE(DQ(DQ),U,5,99)
if 'DV
GOTO A
if DC<2
GOTO A
GOTO N^DIE1
+2 if DQ(DQ)'["DINUM"
GOTO RD
DO E^DIE0
if $DATA(X)
GOTO RD
GOTO PR
+3 ;
F SET DB(DQ)=1
SET X=$EXTRACT(Y,2,999)
SET DH=$FIND(DQ(DQ),"%DT=""E")
IF DH
SET DQ(DQ)=$EXTRACT(DQ(DQ),1,DH-2)_$EXTRACT(DQ(DQ),DH,999)
+1 IF X?1"/".E
SET X=$EXTRACT(X,2,999)
SET DH=""
+2 if $EXTRACT(X,1)=U
XECUTE $EXTRACT(X,2,999)
if X=""
if 'DV
GOTO A
if '$PIECE(DC,U,4)
GOTO A
GOTO N^DIE1
IF $DATA(DE(DQ))#2
IF DV["I"!(DQ(DQ)["DINUM")
DO E^DIE0
+3 if '$DATA(X)
GOTO X
if DH]""
GOTO RD
if X="@"
GOTO RD
if DV
GOTO M^DIE1
GOTO Z
+4 ;
Y XECUTE $EXTRACT(Y,2,999)
SET Y=X
IF DV["D"
IF Y?7N.NP
XECUTE ^DD("DD")
Q QUIT
+1 ;
SET ;FROM COMPILED TEMPLATES,TOO
+1 NEW DILANG
+2 IF $DATA(DB(DQ))
IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+3 IF $GET(DUZ("LANG"))>1
IF $DATA(^DD(DP,+$GET(DIFLD),0))
SET DILANG=$$SETIN^DIALOGZ
Begin DoDot:1
+4 IF DILANG'=DU
SET DU=DILANG
QUIT
+5 KILL DILANG
End DoDot:1
+6 ;CODE TO SET POINTER SCREEN DIC("S") IS SAME AS SET SCREEN
IF $DATA(^DD(DP,DIFLD,12.1))
XECUTE ^(12.1)
+7 DO READSET(.X,DU,$GET(DIC("S")))
SET DDER='$DATA(X)
+8 QUIT
+9 ;
READSET(X,DU,DISCR) ;X=INCOMING VALUE, DU=SET OF CODES, DISCR=SCREENING LOGIC X IS KILLED IF BAD
+1 NEW DIR,Y,%,DDER
+2 ;Call the READER
SET DIR(0)="SV"_$EXTRACT("o",$GET(DIQUIET))_U_DU
SET DIR("V")=1
if $GET(DISCR)]""
SET DIR("S")=DISCR
DO ^DIR
IF DDER
KILL X
QUIT
+3 ;Return the 'REAL' internal value
IF $DATA(DILANG)
SET %=$FIND(";"_DILANG,";"_Y)
IF %
SET Y=$PIECE($PIECE($PIECE(^DD(DP,DIFLD,0),U,3),";",Y),":")
+4 SET %=Y(0)
SET X=Y
+5 if '$GET(DIQUIET)
WRITE " "_%
+6 QUIT
+7 ;
+8 ;
AST ;G V:DV["'",AST^DIE9
+1 IF DV["'"
Begin DoDot:1
+2 DO SCRNL(.DICONT)
End DoDot:1
+3 IF '$TEST
DO SCRL(.DICONT)
+4 IF DICONT="V"
KILL DICONT
if $DATA(DNM)[0
GOTO V
GOTO @("V^"_DNM)
+5 IF DICONT="X"
KILL DICONT
if $DATA(DNM)[0
GOTO X
GOTO @("X^"_DNM)
+6 IF DICONT="Z"
KILL DICONT
if $DATA(DNM)[0
GOTO Z
GOTO @("Z^"_DNM)
+7 QUIT
+8 ;
RW GOTO RW^DIR2
+1 ;
LOADXR ;Load all index file xrefs for a field
+1 if $DATA(DIETMP)[0
QUIT
+2 NEW FLIST,RLIST,OLD
+3 ;
+4 IF $GET(DICRREC)]""
NEW DP,DIFLD,DIIENS
SET OLD=DIU
SET DP=DIH
SET DIFLD=DIG
SET DIIENS=DICRIENS
+5 IF '$TEST
SET OLD=$GET(DE(DQ))
+6 ;
+7 ;Get field- and record-level xrefs
+8 DO LOADFLD^DIKC1(DP,DIFLD,"KS","",$NAME(@DIETMP@("V")),"DIEFXREF",$NAME(@DIETMP@("R")),.FLIST,.RLIST)
+9 IF FLIST=""
IF RLIST=""
QUIT
+10 if RLIST]""
SET @DIETMP@("R",DP,DIIENS)=DIE
+11 ;
+12 ;Save the old value of the field
+13 SET @DIETMP@("V",DP,DIIENS,DIFLD,"O")=OLD
if $DATA(^("F"))[0
SET ^("F")=OLD
+14 IF $GET(DICRREC)=""
IF $GET(DE(DQ,0))?1"//".E
SET @DIETMP@("V",DP,DIIENS,DIFLD,"4/")=""
+15 IF '$TEST
KILL @DIETMP@("V",DP,DIIENS,DIFLD,"4/")
+16 QUIT
+17 ;
KEYCHK() ;If this is a key field, return 0 if not unique.
+1 NEW DIEKCHK
+2 if $DATA(DIETMP)[0
QUIT 1
+3 if '$DATA(DIEFXREF)
QUIT 1
+4 if $GET(DE(DQ,0))?1"//".E
QUIT 1
+5 SET @DIETMP@("V",DP,DIIENS,DIFLD,"N")=X
+6 SET DIEKCHK=$$KEYCHK^DIKK2(DP,.DA,DIFLD,"DIEFXREF",DIIENS,"","N")
+7 KILL @DIETMP@("V",DP,DIIENS,DIFLD,"N")
+8 QUIT DIEKCHK
+9 ;
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 !," ",$$EZBLD^DIALOG(3094)
End DoDot:1
+4 KILL DIEFXREF
SET ^("N")=@DIETMP@("V",DP,DIIENS,DIFLD,"O")
+5 GOTO B^DIE1
+6 ;
NKEY ;No value was assigned to this key field
+1 IF '$DATA(ZTQUEUED)
IF '$DATA(DDS)
WRITE $CHAR(7)_"?? ",$$EZBLD^DIALOG(3092.2)
+2 GOTO B^DIE1
+3 ;
NOSCR ;No screen
+1 NEW DIXRL
+2 DO GETXRL(DP,DIFLD,+$PIECE(DV,"P",2),.DIXRL)
+3 IF DV'["'"
IF $GET(DIXRL)]""
IF (U_DIXRL_U)'["^B^"
SET DIXRL=DIXRL_"^B"
+4 DO DIC($GET(DIXRL))
+5 QUIT
+6 ;
SCRNL(DICONT) ;Screen, No LAYGO allowed
+1 NEW DIFRST,DILAST,DIXRL
+2 KILL DICONT
+3 ;
+4 DO GETXRL(DP,DIFLD,+$PIECE(DV,"P",2),.DIXRL)
+5 if $GET(DIXRL)=""
GOTO EXIT
+6 ;
+7 if $DATA(DNM)#2
DO @("D^"_DNM)
+8 DO PARSE($PIECE(DQ(DQ),U,5,999),.DIFRST,.DILAST)
+9 if '$DATA(DIFRST)
GOTO EXIT
+10 ;
+11 XECUTE DIFRST
+12 DO DIC(DIXRL)
SET X=+Y
+13 if Y>0
XECUTE DILAST
+14 SET DICONT=$SELECT('$DATA(X):"X",X<0:"X",1:"Z")
+15 QUIT
+16 ;
SCRL(DICONT) ;Screen, LAYGO allowed
+1 NEW DICALL,DICSS,DIFRST,DILAST,DIXRL
+2 KILL DICONT
+3 ;
+4 DO GETXRL(DP,DIFLD,+$PIECE(DV,"P",2),.DIXRL)
+5 if $DATA(DNM)
DO @("D^"_DNM)
+6 DO PARSE($PIECE(DQ(DQ),U,5,999),.DIFRST,.DILAST)
+7 if '$DATA(DIFRST)
GOTO EXIT
+8 ;
+9 KILL D
XECUTE DIFRST
IF '$DATA(DIC("S"))
IF $GET(DIXRL)=""
SET DICONT="V"
QUIT
+10 SET DICSS=$GET(DIC("S"))
+11 ;
+12 IF $GET(DIXRL)=""
SET DIXRL=$GET(D)
+13 IF '$TEST
if (U_DIXRL_U)'["^B^"
SET DIXRL=DIXRL_"^B"
+14 DO DIC($GET(DIXRL))
+15 SET X=+Y
+16 ;
+17 IF $PIECE(Y,U,3)
SET Y=+Y
if $DATA(@(DIC_Y_",0)"))
XECUTE DICSS
IF '$TEST
Begin DoDot:1
+18 NEW DV,DU,DA
+19 SET DA=Y
SET DIK=DIC
DO ^DIK
End DoDot:1
SET DICONT="X"
QUIT
+20 ;
+21 if Y>0
XECUTE DILAST
+22 SET DICONT=$SELECT('$DATA(X):"X",X<0:"X",1:"Z")
+23 QUIT
+24 ;
EXIT ;Cleanup and set flag to continue by executing the input transform
+1 KILL DIC("PTRIX")
+2 SET DICONT="V"
+3 QUIT
+4 ;
DIC(D) ;Make the appropriate ^DIC call based on D
+1 IF $GET(D)]""
IF $PIECE(D,U,2)=""
SET DIC(0)=$TRANSLATE(DIC(0),"M")
+2 IF '$TEST
if DIC(0)'["M"
SET DIC(0)="M"_DIC(0)
+3 ;
+4 IF $PIECE($GET(D),U)=""
Begin DoDot:1
+5 DO ^DIC
End DoDot:1
+6 IF '$TEST
IF $PIECE(D,U,2)]""
Begin DoDot:1
+7 DO MIX^DIC1
End DoDot:1
+8 IF '$TEST
DO IX^DIC
+9 KILL DIC("PTRIX")
+10 QUIT
+11 ;
PARSE(IT,FRST,LAST) ;Parse input transform
+1 NEW CALL,I
+2 FOR CALL=" D ^DIC"," D IX^DIC"," D MIX^DIC1",""
if IT[CALL
QUIT
+3 IF CALL=""
KILL FRST,LAST
QUIT
+4 SET FRST=$PIECE(IT,CALL)
SET LAST=$PIECE(IT,CALL_" ",2,999)
+5 IF FRST?.E1" "
Begin DoDot:1
+6 FOR I=$LENGTH(FRST)-1:-1:0
if $EXTRACT(FRST,I)'=" "
QUIT
End DoDot:1
SET FRST=$EXTRACT(FRST,1,I)
+7 QUIT
+8 ;
GETXRL(FIL,FLD,PFIL,LIST) ;Get list of indexes from DIE("PTRIX")
+1 KILL DIC("PTRIX"),LIST
if '$DATA(DIE("PTRIX"))
QUIT
+2 MERGE DIC("PTRIX")=DIE("PTRIX")
+3 ;
+4 SET LIST=$GET(DIE("PTRIX",FIL,FLD,PFIL))
+5 if LIST=""
KILL LIST
+6 QUIT
