- 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 Feb 19, 2025@00:09:24 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...