DIED ;SFISC/GFT,XAK-MAJOR INPUT PROCESSOR ;05:43 PM 2 Jan 2002 [ 12/09/2003 4:14 PM ]
;;22.0;VA FileMan;**4,21,11,59,96,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
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 S X="" W " (No Editing)" 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 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,^DIE2:X="@" 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",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V
SET .N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
.I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
.D ^DIR I 'DDER S %=Y(0),X=Y
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
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,1)=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
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),";",1) S:%]"" 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
;
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)) !," Another entry already exists with this key value."
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)_"?? Required key field"
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
DIED ;SFISC/GFT,XAK-MAJOR INPUT PROCESSOR ;05:43 PM 2 Jan 2002 [ 12/09/2003 4:14 PM ]
+1 ;;22.0;VA FileMan;**4,21,11,59,96,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
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
SET X=""
WRITE " (No Editing)"
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 SET DIFLD=$SELECT($DATA(DIFLD(DQ)):DIFLD(DQ),1:-1)
+1 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 ;MAC-1201-61253
IF X[U
GOTO ^DIE0
IF X="@"
GOTO ^DIE2
IF X?."?"
IF $DATA(DB(DQ))
GOTO A
GOTO ^DIEQ
+1 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 DV'["S"
GOTO P
IF $DATA(^DD(DP,DIFLD,12.1))
XECUTE ^(12.1)
IF X?.ANP
Begin DoDot:1
SET NEW DIR
SET DIR(0)="SV"_$EXTRACT("o",$DATA(DB(DQ)))_U_DU
SET DIR("V")=1
+1 IF $DATA(DB(DQ))
IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+2 DO ^DIR
IF 'DDER
SET %=Y(0)
SET X=Y
End DoDot:1
IF 'DDER
IF $DATA(DIC("S"))
XECUTE DIC("S")
IF $TEST
IF '$DATA(DB(DQ))
WRITE " "_%
GOTO V
+3 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
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,1)=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
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")
IF DG["S"
SET %=$PIECE($PIECE(";"_X,";"_Y_":",2),";",1)
IF %]""
SET 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 ;
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
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 !," Another entry already exists with this key value."
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)_"?? Required key field"
+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
