DDSVALF ;SFISC/MKO-GET,PUT VALUES FOR FORM ONLY FIELDS ;2OCT2003
;;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.
;
GET(DDSVFD,DDSVBK,DDSVPG,DDSPARM,DDSVDA) ;Get value
;In: DDSPG = Current page
; DDSBK = Current block
; DDSPARM = "I" : internal, "E" : external form
;
N DDSANS,DDSFLD,DDSVDDP,DIERR
I $D(DDSPG)[0 N DDSPG S DDSPG=0
I $D(DDSBK)[0 N DDSBK S DDSBK=0
S DDSANS=""
I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"I"
;
S DDSFLD=$P($$GETFLD^DDSLIB($G(DDSVFD),$G(DDSVBK),$G(DDSVPG),DDS,$G(DDSPG),$G(DDSBK),"F"),",",1,2)
G:$G(DIERR) GETQ
;
S DDSVFD=+DDSFLD,DDSVBK=+$P(DDSFLD,",",2)
;
S DDSVDDP=+$P($G(^DIST(.404,DDSVBK,0)),U,2)
I DDSVDDP,$G(DDSVDA)]"" N DDSDA D
. I DDSVDA'["," S DDSVDA=$$IENS^DILF(.DDSVDA)
. E S:DDSVDA'?.E1"," DDSVDA=DDSVDA_","
. S DDSDA=DDSVDA
E I DDSVDDP,DDSVBK'=DDSBK N DDSDA D GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA)
;
I $D(@DDSREFT@("F0",DDSDA,DDSFLD,"D"))#2 S DDSANS=^("D") S:DDSPARM["E"&($D(^("X"))#2) DDSANS=^("X") G GETQ
;
I "013"[$P(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3) D BLD^DIALOG(520,"DD or caption-only") G GETQ
;
;Form-only fields
I $P($G(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=2 D G:$G(DIERR) GETQ
. I $P($G(^DIST(.404,DDSVBK,40,DDSVFD,20)),U)="" D Q
.. N P S P(1)="READ TYPE",P(2)="FIELD multiple of the BLOCK"
.. D BLD^DIALOG(3011,.P)
. D:$D(^DIST(.404,DDSVBK,40,DDSVFD,3))#2 DEF(^(3),$G(^(3.1)),.DDSANS)
. S (@DDSREFT@("F0",DDSDA,DDSFLD,"D"),^("O"))=DDSANS
. I DDSANS]"" D
.. D:$D(DDSANS(0))
... S @DDSREFT@("F0",DDSDA,DDSFLD,"X")=$G(DDSANS(0,0),DDSANS(0))
... S:DDSPARM["E" DDSANS=$G(DDSANS(0,0),DDSANS(0))
.. S $P(@DDSREFT@("F0",DDSDA,DDSFLD,"F"),U)=3,DDSCHG=1
;
;Computed fields
E S:$P($G(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=4 DDSANS=$$VAL^DDSCOMP(DDSVFD,DDSVBK,DDSDA)
;
GETQ D:$G(DIERR) ERR^DDSVALM("$$GET^DDSVALF")
Q DDSANS
;
PUT(DDSVFD,DDSVBK,DDSVPG,DDSVAL,DDSPARM,DDSVDA) ;Put value
N DIR,X,Y
N DDER,DDSFLD,DDSVDDP,DDSVX,DIERR
I $D(DDSPG)[0 N DDSPG S DDSPG=0
I $D(DDSBK)[0 N DDSBK S DDSBK=0
S:$D(DDSVAL)[0 DDSVAL=""
I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"E"
;
S DDSFLD=$$GETFLD^DDSLIB($G(DDSVFD),$G(DDSVBK),$G(DDSVPG),DDS,DDSPG,DDSBK,"F")
G:$G(DIERR) PUTQ
S DDSVFD=+DDSFLD,DDSVBK=+$P(DDSFLD,",",2),DDSVPG=$P(DDSFLD,",",3)
S DDSFLD=$P(DDSFLD,",",1,2)
;
S DDSVDDP=+$P($G(^DIST(.404,DDSVBK,0)),U,2)
I DDSVDDP,$G(DDSVDA)]"" N DDSDA D
. I DDSVDA'["," S DDSVDA=$$IENS^DILF(.DDSVDA)
. E S:DDSVDA'?.E1"," DDSVDA=DDSVDA_","
. S DDSDA=DDSVDA
E I DDSVDDP,DDSVBK'=DDSBK N DDSDA D GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA)
;
I $P(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3)'=2 D BLD^DIALOG(520,"DD, computed, or caption-only") G PUTQ
;
S DIR(0)=$P(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$P(^(20),U,2,3)
I DDSPARM["I",$E(DIR(0))="P"!(DIR(0)?1"DD".E) D
. N FIL,FILROOT,FLD
. S Y=DDSVAL
. I $E(DIR(0))="P" D
.. S FIL=$P($P(DIR(0),U,2),":")
.. I 'FIL S FILROOT=U_FIL,FIL=+$P($G(@(U_FIL_"0)")),U,2) Q:'FIL
.. E S FILROOT=$G(^DIC(FIL,0,"GL")) Q:FILROOT=""
.. S Y(0)=$P($G(@(FILROOT_Y_",0)")),U)
.. S Y(0)=$$EXTERNAL^DILFD(FIL,.01,"",Y(0))
. E D
.. N DV,I S FIL=$P($P(DIR(0),","),U,2),FLD=$P(DIR(0),",",2)
.. S DV=$P($G(^DD(FIL,FLD,0)),U,2)
.. F I="O","P","V","D","S" I DV[I S Y(0)=$$EXTERNAL^DILFD(FIL,FLD,"",Y) Q
E D G:$G(DDER) PUTQ
. I DDSVAL="" D Q
.. N DDSVREQ
.. S DDSVREQ=$P($G(@DDSREFT@(DDSVPG,DDSVBK,DDSVFD)),U)
.. S:DDSVREQ]"" DDSVREQ=$P($G(^DIST(.404,DDSVBK,40,DDSVFD,4)),U)
.. I DDSVREQ S DDER=1
.. E S Y=""
. S DIR("V")="",(X,DIR("B"))=DDSVAL
. S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
. I $P(DIR(0),U)["P",$P($P(DIR(0),U,2),":",2)'["Z" D
.. N I
.. S I=$P(DIR(0),U,2) Q:$P(I,":",2)["Z"
.. S $P(I,":",2)=$P(I,":",2)_"Z"
.. S $P(DIR(0),U,2)=I
. D ^DIR
. I $E($P(DIR(0),U))="P" S Y=$P(Y,U)
;
;Update ^TMP
S DDSCHG=1
S (DDSVX,@DDSREFT@("F0",DDSDA,DDSFLD,"D"))=Y,^("F")=3 S:$D(Y(0))#2 (DDSVX,^("X"))=$S($D(Y(0,0))#2:Y(0,0),1:Y(0)) I $D(^("X"))#2,Y="" S (DDSVX,^("X"))=""
;
;Repaint field if it appears on the current page
I $D(@DDSREFS@("F0",DDSFLD,"L",DDSPG,DDSVBK,DDSVFD))#2 D
. N DY,DX,DDSVL,DDSVRJ,DDSX,DDSVREP
. S DDSVREP=$P($G(@DDSREFS@(DDSPG,DDSVBK)),U,7)
. S DY=+@DDSREFS@(DDSPG,DDSVBK,DDSVFD,"D"),DX=$P(^("D"),U,2),DDSVL=$P(^("D"),U,3),DDSVRJ=$P(^("D"),U,10)
. I $G(DDSVREP) D Q:DY=""
.. N DDSVSN,DDSVPDA,DDSVOFS
.. S DDSVPDA=$G(@DDSREFT@(DDSPG,DDSVBK)) I 'DDSVPDA S DY="" Q
.. S DDSVREP=$P($G(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA)),U,2,999) I DDSVREP="" S DY="" Q
.. S DDSVSN=$G(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA,"B",DDSDA)) I 'DDSVSN S DY="" Q
HITE .. N HITE S HITE=$$HITE^DDSR(DDSVBK),DDSVOFS=DDSVSN-$P(DDSVREP,U,2)*HITE ;DJW/GFT
.. I DDSVOFS'<0,$P(DDSVREP,U,5)*HITE>DDSVOFS S DY=DY+DDSVOFS ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW
.. E S DY=""
. S DDSX=$P(DDGLVID,DDGLDEL)_$E(DDSVX,1,DDSVL)_$P(DDGLVID,DDGLDEL,10)
. X IOXY
. W $S(DDSVRJ:$J("",DDSVL-$L(DDSVX))_DDSX,1:DDSX_$J("",DDSVL-$L(DDSVX)))
;
D
. N DDP,DDSDA S DDP=0,DDSDA="0,"
. D:$D(@DDSREFS@("PT",DDP,DDSFLD)) RPB^DDS7(DDP,DDSFLD,DDSPG)
. D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF^DDSCOMP(DDSPG)
;
PUTQ D:$G(DIERR) ERR^DDSVALM("PUT^DDSVALF")
Q
;
DEF(DDSLN3,DDSLN31,Y) ;Get default
N DDER,DIR,X
Q:DDSLN3=""
;
I DDSLN3'="!M" S Y=DDSLN3
E I DDSLN31'?."^" X DDSLN31 S:$D(Y)[0 Y=""
Q:Y=""
;
S DIR(0)=$P(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$P(^(20),U,2,3)
S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
S DIR("V")="",(X,DIR("B"))=Y
D ^DIR I DDER K Y S Y=""
;
I Y]"",$E($P(DIR(0),U))="P" S Y=$P(Y,U)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSVALF 5888 printed Dec 13, 2024@02:43:38 Page 2
DDSVALF ;SFISC/MKO-GET,PUT VALUES FOR FORM ONLY FIELDS ;2OCT2003
+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 ;
GET(DDSVFD,DDSVBK,DDSVPG,DDSPARM,DDSVDA) ;Get value
+1 ;In: DDSPG = Current page
+2 ; DDSBK = Current block
+3 ; DDSPARM = "I" : internal, "E" : external form
+4 ;
+5 NEW DDSANS,DDSFLD,DDSVDDP,DIERR
+6 IF $DATA(DDSPG)[0
NEW DDSPG
SET DDSPG=0
+7 IF $DATA(DDSBK)[0
NEW DDSBK
SET DDSBK=0
+8 SET DDSANS=""
+9 IF $GET(DDSPARM)'["I"
IF $GET(DDSPARM)'["E"
SET DDSPARM=$GET(DDSPARM)_"I"
+10 ;
+11 SET DDSFLD=$PIECE($$GETFLD^DDSLIB($GET(DDSVFD),$GET(DDSVBK),$GET(DDSVPG),DDS,$GET(DDSPG),$GET(DDSBK),"F"),",",1,2)
+12 if $GET(DIERR)
GOTO GETQ
+13 ;
+14 SET DDSVFD=+DDSFLD
SET DDSVBK=+$PIECE(DDSFLD,",",2)
+15 ;
+16 SET DDSVDDP=+$PIECE($GET(^DIST(.404,DDSVBK,0)),U,2)
+17 IF DDSVDDP
IF $GET(DDSVDA)]""
NEW DDSDA
Begin DoDot:1
+18 IF DDSVDA'[","
SET DDSVDA=$$IENS^DILF(.DDSVDA)
+19 IF '$TEST
if DDSVDA'?.E1","
SET DDSVDA=DDSVDA_","
+20 SET DDSDA=DDSVDA
End DoDot:1
+21 IF '$TEST
IF DDSVDDP
IF DDSVBK'=DDSBK
NEW DDSDA
DO GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA)
+22 ;
+23 IF $DATA(@DDSREFT@("F0",DDSDA,DDSFLD,"D"))#2
SET DDSANS=^("D")
if DDSPARM["E"&($DATA(^("X"))#2)
SET DDSANS=^("X")
GOTO GETQ
+24 ;
+25 IF "013"[$PIECE(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3)
DO BLD^DIALOG(520,"DD or caption-only")
GOTO GETQ
+26 ;
+27 ;Form-only fields
+28 IF $PIECE($GET(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=2
Begin DoDot:1
+29 IF $PIECE($GET(^DIST(.404,DDSVBK,40,DDSVFD,20)),U)=""
Begin DoDot:2
+30 NEW P
SET P(1)="READ TYPE"
SET P(2)="FIELD multiple of the BLOCK"
+31 DO BLD^DIALOG(3011,.P)
End DoDot:2
QUIT
+32 if $DATA(^DIST(.404,DDSVBK,40,DDSVFD,3))#2
DO DEF(^(3),$GET(^(3.1)),.DDSANS)
+33 SET (@DDSREFT@("F0",DDSDA,DDSFLD,"D"),^("O"))=DDSANS
+34 IF DDSANS]""
Begin DoDot:2
+35 if $DATA(DDSANS(0))
Begin DoDot:3
+36 SET @DDSREFT@("F0",DDSDA,DDSFLD,"X")=$GET(DDSANS(0,0),DDSANS(0))
+37 if DDSPARM["E"
SET DDSANS=$GET(DDSANS(0,0),DDSANS(0))
End DoDot:3
+38 SET $PIECE(@DDSREFT@("F0",DDSDA,DDSFLD,"F"),U)=3
SET DDSCHG=1
End DoDot:2
End DoDot:1
if $GET(DIERR)
GOTO GETQ
+39 ;
+40 ;Computed fields
+41 IF '$TEST
if $PIECE($GET(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=4
SET DDSANS=$$VAL^DDSCOMP(DDSVFD,DDSVBK,DDSDA)
+42 ;
GETQ if $GET(DIERR)
DO ERR^DDSVALM("$$GET^DDSVALF")
+1 QUIT DDSANS
+2 ;
PUT(DDSVFD,DDSVBK,DDSVPG,DDSVAL,DDSPARM,DDSVDA) ;Put value
+1 NEW DIR,X,Y
+2 NEW DDER,DDSFLD,DDSVDDP,DDSVX,DIERR
+3 IF $DATA(DDSPG)[0
NEW DDSPG
SET DDSPG=0
+4 IF $DATA(DDSBK)[0
NEW DDSBK
SET DDSBK=0
+5 if $DATA(DDSVAL)[0
SET DDSVAL=""
+6 IF $GET(DDSPARM)'["I"
IF $GET(DDSPARM)'["E"
SET DDSPARM=$GET(DDSPARM)_"E"
+7 ;
+8 SET DDSFLD=$$GETFLD^DDSLIB($GET(DDSVFD),$GET(DDSVBK),$GET(DDSVPG),DDS,DDSPG,DDSBK,"F")
+9 if $GET(DIERR)
GOTO PUTQ
+10 SET DDSVFD=+DDSFLD
SET DDSVBK=+$PIECE(DDSFLD,",",2)
SET DDSVPG=$PIECE(DDSFLD,",",3)
+11 SET DDSFLD=$PIECE(DDSFLD,",",1,2)
+12 ;
+13 SET DDSVDDP=+$PIECE($GET(^DIST(.404,DDSVBK,0)),U,2)
+14 IF DDSVDDP
IF $GET(DDSVDA)]""
NEW DDSDA
Begin DoDot:1
+15 IF DDSVDA'[","
SET DDSVDA=$$IENS^DILF(.DDSVDA)
+16 IF '$TEST
if DDSVDA'?.E1","
SET DDSVDA=DDSVDA_","
+17 SET DDSDA=DDSVDA
End DoDot:1
+18 IF '$TEST
IF DDSVDDP
IF DDSVBK'=DDSBK
NEW DDSDA
DO GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA)
+19 ;
+20 IF $PIECE(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3)'=2
DO BLD^DIALOG(520,"DD, computed, or caption-only")
GOTO PUTQ
+21 ;
+22 SET DIR(0)=$PIECE(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$PIECE(^(20),U,2,3)
+23 IF DDSPARM["I"
IF $EXTRACT(DIR(0))="P"!(DIR(0)?1"DD".E)
Begin DoDot:1
+24 NEW FIL,FILROOT,FLD
+25 SET Y=DDSVAL
+26 IF $EXTRACT(DIR(0))="P"
Begin DoDot:2
+27 SET FIL=$PIECE($PIECE(DIR(0),U,2),":")
+28 IF 'FIL
SET FILROOT=U_FIL
SET FIL=+$PIECE($GET(@(U_FIL_"0)")),U,2)
if 'FIL
QUIT
+29 IF '$TEST
SET FILROOT=$GET(^DIC(FIL,0,"GL"))
if FILROOT=""
QUIT
+30 SET Y(0)=$PIECE($GET(@(FILROOT_Y_",0)")),U)
+31 SET Y(0)=$$EXTERNAL^DILFD(FIL,.01,"",Y(0))
End DoDot:2
+32 IF '$TEST
Begin DoDot:2
+33 NEW DV,I
SET FIL=$PIECE($PIECE(DIR(0),","),U,2)
SET FLD=$PIECE(DIR(0),",",2)
+34 SET DV=$PIECE($GET(^DD(FIL,FLD,0)),U,2)
+35 FOR I="O","P","V","D","S"
IF DV[I
SET Y(0)=$$EXTERNAL^DILFD(FIL,FLD,"",Y)
QUIT
End DoDot:2
End DoDot:1
+36 IF '$TEST
Begin DoDot:1
+37 IF DDSVAL=""
Begin DoDot:2
+38 NEW DDSVREQ
+39 SET DDSVREQ=$PIECE($GET(@DDSREFT@(DDSVPG,DDSVBK,DDSVFD)),U)
+40 if DDSVREQ]""
SET DDSVREQ=$PIECE($GET(^DIST(.404,DDSVBK,40,DDSVFD,4)),U)
+41 IF DDSVREQ
SET DDER=1
+42 IF '$TEST
SET Y=""
End DoDot:2
QUIT
+43 SET DIR("V")=""
SET (X,DIR("B"))=DDSVAL
+44 if DIR(0)?1"DD".E
SET DIR(0)=$PIECE(DIR(0),U,2,999)
+45 IF $PIECE(DIR(0),U)["P"
IF $PIECE($PIECE(DIR(0),U,2),":",2)'["Z"
Begin DoDot:2
+46 NEW I
+47 SET I=$PIECE(DIR(0),U,2)
if $PIECE(I,"
QUIT
+48 SET $PIECE(I,":",2)=$PIECE(I,":",2)_"Z"
+49 SET $PIECE(DIR(0),U,2)=I
End DoDot:2
+50 DO ^DIR
+51 IF $EXTRACT($PIECE(DIR(0),U))="P"
SET Y=$PIECE(Y,U)
End DoDot:1
if $GET(DDER)
GOTO PUTQ
+52 ;
+53 ;Update ^TMP
+54 SET DDSCHG=1
+55 SET (DDSVX,@DDSREFT@("F0",DDSDA,DDSFLD,"D"))=Y
SET ^("F")=3
if $DATA(Y(0))#2
SET (DDSVX,^("X"))=$SELECT($DATA(Y(0,0))#2:Y(0,0),1:Y(0))
IF $DATA(^("X"))#2
IF Y=""
SET (DDSVX,^("X"))=""
+56 ;
+57 ;Repaint field if it appears on the current page
+58 IF $DATA(@DDSREFS@("F0",DDSFLD,"L",DDSPG,DDSVBK,DDSVFD))#2
Begin DoDot:1
+59 NEW DY,DX,DDSVL,DDSVRJ,DDSX,DDSVREP
+60 SET DDSVREP=$PIECE($GET(@DDSREFS@(DDSPG,DDSVBK)),U,7)
+61 SET DY=+@DDSREFS@(DDSPG,DDSVBK,DDSVFD,"D")
SET DX=$PIECE(^("D"),U,2)
SET DDSVL=$PIECE(^("D"),U,3)
SET DDSVRJ=$PIECE(^("D"),U,10)
+62 IF $GET(DDSVREP)
Begin DoDot:2
+63 NEW DDSVSN,DDSVPDA,DDSVOFS
+64 SET DDSVPDA=$GET(@DDSREFT@(DDSPG,DDSVBK))
IF 'DDSVPDA
SET DY=""
QUIT
+65 SET DDSVREP=$PIECE($GET(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA)),U,2,999)
IF DDSVREP=""
SET DY=""
QUIT
+66 SET DDSVSN=$GET(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA,"B",DDSDA))
IF 'DDSVSN
SET DY=""
QUIT
HITE ;DJW/GFT
NEW HITE
SET HITE=$$HITE^DDSR(DDSVBK)
SET DDSVOFS=DDSVSN-$PIECE(DDSVREP,U,2)*HITE
+1 ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW
IF DDSVOFS'<0
IF $PIECE(DDSVREP,U,5)*HITE>DDSVOFS
SET DY=DY+DDSVOFS
+2 IF '$TEST
SET DY=""
End DoDot:2
if DY=""
QUIT
+3 SET DDSX=$PIECE(DDGLVID,DDGLDEL)_$EXTRACT(DDSVX,1,DDSVL)_$PIECE(DDGLVID,DDGLDEL,10)
+4 XECUTE IOXY
+5 WRITE $SELECT(DDSVRJ:$JUSTIFY("",DDSVL-$LENGTH(DDSVX))_DDSX,1:DDSX_$JUSTIFY("",DDSVL-$LENGTH(DDSVX)))
End DoDot:1
+6 ;
+7 Begin DoDot:1
+8 NEW DDP,DDSDA
SET DDP=0
SET DDSDA="0,"
+9 if $DATA(@DDSREFS@("PT",DDP,DDSFLD))
DO RPB^DDS7(DDP,DDSFLD,DDSPG)
+10 if $DATA(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG))
DO RPCF^DDSCOMP(DDSPG)
End DoDot:1
+11 ;
PUTQ if $GET(DIERR)
DO ERR^DDSVALM("PUT^DDSVALF")
+1 QUIT
+2 ;
DEF(DDSLN3,DDSLN31,Y) ;Get default
+1 NEW DDER,DIR,X
+2 if DDSLN3=""
QUIT
+3 ;
+4 IF DDSLN3'="!M"
SET Y=DDSLN3
+5 IF '$TEST
IF DDSLN31'?."^"
XECUTE DDSLN31
if $DATA(Y)[0
SET Y=""
+6 if Y=""
QUIT
+7 ;
+8 SET DIR(0)=$PIECE(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$PIECE(^(20),U,2,3)
+9 if DIR(0)?1"DD".E
SET DIR(0)=$PIECE(DIR(0),U,2,999)
+10 SET DIR("V")=""
SET (X,DIR("B"))=Y
+11 DO ^DIR
IF DDER
KILL Y
SET Y=""
+12 ;
+13 IF Y]""
IF $EXTRACT($PIECE(DIR(0),U))="P"
SET Y=$PIECE(Y,U)
+14 QUIT
+15 ;
