DDS6 ;SFISC/MKO-DELETIONS ;14NOV2012
;;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.
;
;Enter here if user deleted record from the .01 of the (sub)record
;(called from DDS01)
;In: DDSU array, DDSOLD, DDSFLD
D D
I 'Y D ;DELETE DIDN'T HAPPEN
. S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
. S:$D(DDSU("X"))#2 @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X")
E D
. I $D(DDSREP) D
.. D DEL^DDSM1(DDSDA) ;THIS WILL COME BACK TO K IN THIS ROUTINE!
. E D K(DDSDA,DIE) I $D(DDSPTB) D
.. S DDACT="NB"
.. S $P(@DDSREFT@(DDSPG,DDSBK),U)=""
.. D DB^DDSR(DDSPG,DDSBK)
.. D RPF^DDS7(DDP,DDSPTB,DDSDA,.DA)
. E S DDACT="Q",DA="",DDSDAORG=DA,DDSDA="0,"
. I '$D(DDSPTB),'$P(DDSSC(DDSSC),U,4),'$D(DDSREP) D
.. D PG^DDSRSEL
.. I $G(DDSSEL) D
... D CLRDAT^DDSRSEL
... D R^DDSR
... D PUT^DDSVALF(1,1,$P(^DIST(.403,+DDS,21),U),"","","0,")
Q
;
DM ;Enter here if user deleted record from the Select prompt
;(called from DDS5)
;In: DDSU array, DDSOLD, DDSFLD
;
;Get DA and DIE for subfile level and delete
D DDA^DDS5(DDSOLD,.DA,.DDSDL)
D
. N DIE,DDSDA
. S DIE=U_$P(DDSU("M"),U,2)
. S DDSDA=DA_"," F DDSI=1:1:DDSDL S DDSDA=DDSDA_DA(DDSI)_","
. K DDSI
. D D
. D:Y K(DDSDA,DIE)
;
I 'Y D
. S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
. S:$D(DDSU("X"))#2 @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X")
. D UDA^DDS5(.DA,.DDSDL)
E D
. D LST^DDS5(.DA,.DDSDL,DDP,DDSDA,DDSFLD)
. D UDA^DDS5(.DA,.DDSDL)
Q
;
D ;Delete the subrecord
;In: DA array, DIE, DDSDL; Out: Y=1 if successful
N DR,DDS6DA,DDSI
D:DDM CLRMSG^DDS
S DDM=1
;
K DIR S DIR(0)="YO"
D BLD^DIALOG(8080,$$EZBLD^DIALOG(8078+(DDSDL>0)),"","DIR(""A"")")
D BLD^DIALOG(9038,"","","DIR(""?"")")
;
S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^3^"_(IOSL-3)_"^0"
D ^DIR K DIR
D CLRMSG^DDS
I X=""!$D(DIRUT)!'Y S Y=0 K DIRUT,DUOUT,DIROUT,DTOUT Q
;
S DDS6DA=DA N D0
F DDSI=1:1 Q:$D(DA(DDSI))[0 S DDS6DA(DDSI)=DA(DDSI) N @("D"_DDSI)
W $P(DDGLVID,DDGLDEL,9) S X=IOM X DDGLZOSF("RM")
S DR=".01///@" D ^DIE K DI ;DELETE THE SUB-RECORD!
W $P(DDGLVID,DDGLDEL,8) S X=0 X DDGLZOSF("RM")
;
;I $D(DA) H 2 W $P(DDGLCLR,DDGLDEL,2) D R^DDSR S Y=0 Q
I $D(DA) S:$Y>(DDSHBX+1) DDSKM=1,DDM=1 S Y=0 Q
;
S Y=1,DA=DDS6DA
I '$G(DDSCHANG),$G(DDSPARM)["C" S DDSCHANG=1
F DDSI=1:1 Q:$D(DDS6DA(DDSI))[0 S DA(DDSI)=DDS6DA(DDSI)
Q
;
K(DDSIEN,DIE) ;Remove all data pertaining to the (sub)record from @DDSREFT
;In: DDSIEN = IENS of record being deleted
; DIE = global root
;
N B,P,FN,PAT,PDA,IENS
S PAT=".E1"""_DDSIEN_""""
;
;Loop through all pages/blocks in ^TMP
S P=0 F S P=$O(@DDSREFT@(P)) Q:'P D
. S B=0 F S B=$O(@DDSREFT@(P,B)) Q:'B D
.. ;Get file number of the block
.. S FN="F"_$P(@DDSREFS@(P,B),U,3)
.. ;
.. ;Loop through all records loaded for that block
.. S IENS=" "
B .. F S IENS=$O(@DDSREFT@(P,B,IENS)) Q:IENS'["," D
... ;
... ;If the data pertains to the current or ancestor file, kill it
... ;Get the parent IENS (also indicates the block is repeating)
... S PDA=$P($G(@DDSREFT@(P,B,IENS)),U,2)
... ;
... I 'PDA,IENS?@PAT,$P(@DDSREFT@(P,B,IENS,"GL"),DIE)="" D
.... K @DDSREFT@(P,B,IENS)
.... K @DDSREFT@(FN,IENS)
SUB ... E I $P($G(@DDSREFT@(P,B,IENS)),U,6)!PDA,@DDSREFT@(P,B,IENS,"GL")=DIE D ;IF IT'S A MULTIPLE IN A REPEATING BLOCK
.... D DELP(P,B,PDA,DDSIEN)
.... K @DDSREFT@(FN,DDSIEN)
Q
;
DELP(P,B,PDA,IENS) ;Delete subrecord from parent's list
;In: P = page number
; B = block number
; PDA = parent IENS
; IENS = IENS of record to remove
N R,S
;
S S=$G(@DDSREFT@(P,B,PDA,"B",IENS)) Q:'S
K @DDSREFT@(P,B,PDA,"B",IENS)
;
F S=S:1 Q:$D(@DDSREFT@(P,B,PDA,S+1))[0 D
. S R=@DDSREFT@(P,B,PDA,S+1)
. S @DDSREFT@(P,B,PDA,S)=R
. S @DDSREFT@(P,B,PDA,"B",R)=S
K @DDSREFT@(P,B,PDA,S)
Q
;
DEL ;Delete (sub)records added between saves
;(user quit without saving)
N DA,DIK
S DDSI=0
F S DDSI=$O(@DDSREFT@("ADD",DDSI)) Q:'DDSI D
. K DA
. S DA=$P(@DDSREFT@("ADD",DDSI),U),DIK=U_$P(^(DDSI),U,2)
. F DDSX=2:1:$L(DA,",")-1 S DA(DDSX-1)=$P(DA,",",DDSX)
. S DA=+DA
. D ^DIK
K DDSI,DDSX
Q
;#8078 record
;#8079 subrecord
;#8080 WARNING: DELETIONS ARE DONE...
;#9038 Enter 'Y' to delete...
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS6 4529 printed Sep 23, 2025@20:19:14 Page 2
DDS6 ;SFISC/MKO-DELETIONS ;14NOV2012
+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 ;
+7 ;Enter here if user deleted record from the .01 of the (sub)record
+8 ;(called from DDS01)
+9 ;In: DDSU array, DDSOLD, DDSFLD
+10 DO D
+11 ;DELETE DIDN'T HAPPEN
IF 'Y
Begin DoDot:1
+12 SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
+13 if $DATA(DDSU("X"))#2
SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X")
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 IF $DATA(DDSREP)
Begin DoDot:2
+16 ;THIS WILL COME BACK TO K IN THIS ROUTINE!
DO DEL^DDSM1(DDSDA)
End DoDot:2
+17 IF '$TEST
DO K(DDSDA,DIE)
IF $DATA(DDSPTB)
Begin DoDot:2
+18 SET DDACT="NB"
+19 SET $PIECE(@DDSREFT@(DDSPG,DDSBK),U)=""
+20 DO DB^DDSR(DDSPG,DDSBK)
+21 DO RPF^DDS7(DDP,DDSPTB,DDSDA,.DA)
End DoDot:2
+22 IF '$TEST
SET DDACT="Q"
SET DA=""
SET DDSDAORG=DA
SET DDSDA="0,"
+23 IF '$DATA(DDSPTB)
IF '$PIECE(DDSSC(DDSSC),U,4)
IF '$DATA(DDSREP)
Begin DoDot:2
+24 DO PG^DDSRSEL
+25 IF $GET(DDSSEL)
Begin DoDot:3
+26 DO CLRDAT^DDSRSEL
+27 DO R^DDSR
+28 DO PUT^DDSVALF(1,1,$PIECE(^DIST(.403,+DDS,21),U),"","","0,")
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
DM ;Enter here if user deleted record from the Select prompt
+1 ;(called from DDS5)
+2 ;In: DDSU array, DDSOLD, DDSFLD
+3 ;
+4 ;Get DA and DIE for subfile level and delete
+5 DO DDA^DDS5(DDSOLD,.DA,.DDSDL)
+6 Begin DoDot:1
+7 NEW DIE,DDSDA
+8 SET DIE=U_$PIECE(DDSU("M"),U,2)
+9 SET DDSDA=DA_","
FOR DDSI=1:1:DDSDL
SET DDSDA=DDSDA_DA(DDSI)_","
+10 KILL DDSI
+11 DO D
+12 if Y
DO K(DDSDA,DIE)
End DoDot:1
+13 ;
+14 IF 'Y
Begin DoDot:1
+15 SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
+16 if $DATA(DDSU("X"))#2
SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X")
+17 DO UDA^DDS5(.DA,.DDSDL)
End DoDot:1
+18 IF '$TEST
Begin DoDot:1
+19 DO LST^DDS5(.DA,.DDSDL,DDP,DDSDA,DDSFLD)
+20 DO UDA^DDS5(.DA,.DDSDL)
End DoDot:1
+21 QUIT
+22 ;
D ;Delete the subrecord
+1 ;In: DA array, DIE, DDSDL; Out: Y=1 if successful
+2 NEW DR,DDS6DA,DDSI
+3 if DDM
DO CLRMSG^DDS
+4 SET DDM=1
+5 ;
+6 KILL DIR
SET DIR(0)="YO"
+7 DO BLD^DIALOG(8080,$$EZBLD^DIALOG(8078+(DDSDL>0)),"","DIR(""A"")")
+8 DO BLD^DIALOG(9038,"","","DIR(""?"")")
+9 ;
+10 SET DIR0=IOSL-1_U_($LENGTH(DIR("A"))+1)_"^3^"_(IOSL-3)_"^0"
+11 DO ^DIR
KILL DIR
+12 DO CLRMSG^DDS
+13 IF X=""!$DATA(DIRUT)!'Y
SET Y=0
KILL DIRUT,DUOUT,DIROUT,DTOUT
QUIT
+14 ;
+15 SET DDS6DA=DA
NEW D0
+16 FOR DDSI=1:1
if $DATA(DA(DDSI))[0
QUIT
SET DDS6DA(DDSI)=DA(DDSI)
NEW @("D"_DDSI)
+17 WRITE $PIECE(DDGLVID,DDGLDEL,9)
SET X=IOM
XECUTE DDGLZOSF("RM")
+18 ;DELETE THE SUB-RECORD!
SET DR=".01///@"
DO ^DIE
KILL DI
+19 WRITE $PIECE(DDGLVID,DDGLDEL,8)
SET X=0
XECUTE DDGLZOSF("RM")
+20 ;
+21 ;I $D(DA) H 2 W $P(DDGLCLR,DDGLDEL,2) D R^DDSR S Y=0 Q
+22 IF $DATA(DA)
if $Y>(DDSHBX+1)
SET DDSKM=1
SET DDM=1
SET Y=0
QUIT
+23 ;
+24 SET Y=1
SET DA=DDS6DA
+25 IF '$GET(DDSCHANG)
IF $GET(DDSPARM)["C"
SET DDSCHANG=1
+26 FOR DDSI=1:1
if $DATA(DDS6DA(DDSI))[0
QUIT
SET DA(DDSI)=DDS6DA(DDSI)
+27 QUIT
+28 ;
K(DDSIEN,DIE) ;Remove all data pertaining to the (sub)record from @DDSREFT
+1 ;In: DDSIEN = IENS of record being deleted
+2 ; DIE = global root
+3 ;
+4 NEW B,P,FN,PAT,PDA,IENS
+5 SET PAT=".E1"""_DDSIEN_""""
+6 ;
+7 ;Loop through all pages/blocks in ^TMP
+8 SET P=0
FOR
SET P=$ORDER(@DDSREFT@(P))
if 'P
QUIT
Begin DoDot:1
+9 SET B=0
FOR
SET B=$ORDER(@DDSREFT@(P,B))
if 'B
QUIT
Begin DoDot:2
+10 ;Get file number of the block
+11 SET FN="F"_$PIECE(@DDSREFS@(P,B),U,3)
+12 ;
+13 ;Loop through all records loaded for that block
+14 SET IENS=" "
B FOR
SET IENS=$ORDER(@DDSREFT@(P,B,IENS))
if IENS'[","
QUIT
Begin DoDot:3
+1 ;
+2 ;If the data pertains to the current or ancestor file, kill it
+3 ;Get the parent IENS (also indicates the block is repeating)
+4 SET PDA=$PIECE($GET(@DDSREFT@(P,B,IENS)),U,2)
+5 ;
+6 IF 'PDA
IF IENS?@PAT
IF $PIECE(@DDSREFT@(P,B,IENS,"GL"),DIE)=""
Begin DoDot:4
+7 KILL @DDSREFT@(P,B,IENS)
+8 KILL @DDSREFT@(FN,IENS)
End DoDot:4
SUB ;IF IT'S A MULTIPLE IN A REPEATING BLOCK
IF '$TEST
IF $PIECE($GET(@DDSREFT@(P,B,IENS)),U,6)!PDA
IF @DDSREFT@(P,B,IENS,"GL")=DIE
Begin DoDot:4
+1 DO DELP(P,B,PDA,DDSIEN)
+2 KILL @DDSREFT@(FN,DDSIEN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+3 QUIT
+4 ;
DELP(P,B,PDA,IENS) ;Delete subrecord from parent's list
+1 ;In: P = page number
+2 ; B = block number
+3 ; PDA = parent IENS
+4 ; IENS = IENS of record to remove
+5 NEW R,S
+6 ;
+7 SET S=$GET(@DDSREFT@(P,B,PDA,"B",IENS))
if 'S
QUIT
+8 KILL @DDSREFT@(P,B,PDA,"B",IENS)
+9 ;
+10 FOR S=S:1
if $DATA(@DDSREFT@(P,B,PDA,S+1))[0
QUIT
Begin DoDot:1
+11 SET R=@DDSREFT@(P,B,PDA,S+1)
+12 SET @DDSREFT@(P,B,PDA,S)=R
+13 SET @DDSREFT@(P,B,PDA,"B",R)=S
End DoDot:1
+14 KILL @DDSREFT@(P,B,PDA,S)
+15 QUIT
+16 ;
DEL ;Delete (sub)records added between saves
+1 ;(user quit without saving)
+2 NEW DA,DIK
+3 SET DDSI=0
+4 FOR
SET DDSI=$ORDER(@DDSREFT@("ADD",DDSI))
if 'DDSI
QUIT
Begin DoDot:1
+5 KILL DA
+6 SET DA=$PIECE(@DDSREFT@("ADD",DDSI),U)
SET DIK=U_$PIECE(^(DDSI),U,2)
+7 FOR DDSX=2:1:$LENGTH(DA,",")-1
SET DA(DDSX-1)=$PIECE(DA,",",DDSX)
+8 SET DA=+DA
+9 DO ^DIK
End DoDot:1
+10 KILL DDSI,DDSX
+11 QUIT
+12 ;#8078 record
+13 ;#8079 subrecord
+14 ;#8080 WARNING: DELETIONS ARE DONE...
+15 ;#9038 Enter 'Y' to delete...
