DDSDEL ;SFISC/MKO-DELETE FORMS FOR A FILE ;24JUL2003
;;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.
;
FORM(DDSFILE,DDSECHO) ;
;Delete all forms/blocks associated with file DDSFILE
N DDSREF,DDSBLK,DDSBNAM,DDSFRM,DDSOFRM,DDSLN,DDSPDD,DDSPG
N %,DIK,DIOVRD,DA,D0,X,Y
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
S DIOVRD=1
D SETUP,GETFORMS(DDSFILE,DDSREF)
;
;Delete forms
W:DDSECHO !?3,"Deleting the FORMS..."
S DDSFRM="",DIK="^DIST(.403,"
F S DDSFRM=$O(@DDSREF@("FRM",DDSFRM)) Q:'DDSFRM S DA=DDSFRM D ^DIK
K DIK,DA
;
;Delete blocks
W:DDSECHO !?3,"Deleting the BLOCKS..."
S DDSBLK="",DIK="^DIST(.404,"
F S DDSBLK=$O(@DDSREF@("BLK",DDSBLK)) Q:'DDSBLK D
. S DDSLN=@DDSREF@("BLK",DDSBLK)
. S DDSBNAM=$P(DDSLN,U),DDSOFRM=$P(DDSLN,U,2),DDSPDD=$P(DDSLN,U,3)
. ;
. I DDSOFRM,DDSPDD D
.. I DDSECHO D
... W !!?3,$C(7)_"*** Warning ***"
... W !!?3,"Block "_DDSBNAM_" (#"_DDSBLK_")"
... W !?3,"was deleted from the Block file."
... W !!?3,"I'm deleting pointers to that block from"
.. S DDSFRM=""
.. F S DDSFRM=$O(@DDSREF@("BLK",DDSBLK,DDSFRM)) Q:'DDSFRM D
... W:DDSECHO !?6,"Form "_$P(^DIST(.403,DDSFRM,0),U)_" (#"_DDSFRM_") ..."
... D DELBLK(DDSBLK,DDSFRM)
.. W:DDSECHO !!?3,"The above form(s) need to be redesigned.",!
. ;
. E I 'DDSOFRM D
.. S DA=DDSBLK D ^DIK
;
QUIT ;Cleanup and quit
K @DDSREF
Q
;
SETUP ;Setup local variables
S:$D(DDSECHO)[0 DDSECHO=0
S DDSREF="^TMP(""DDSDEL"","""_$J_""")" ;IF $J IS NOT NUMERIC
K @DDSREF
Q
;
GETFORMS(FILE,REF) ;
;Get all forms and blocks associated with file number FILE
;and all subfiles associated with FILE
;Put results in
; @REF@("DD",file#) = null
; ("FRM",form#) = form name
; ("BLK",block#) = block name^used on forms not being
; deleted^dd of block is being deleted
; ("BLK",block#,form#) = null for all blocks that are found
; on a form not being deleted
;
N B,F,P,FNAM
;Get DDs of file and subfiles
D DD(FILE,REF)
;
;Get all forms associated with file
S FNAM="" F S FNAM=$O(^DIST(.403,"F"_FILE,FNAM)) Q:FNAM="" D
. S F="" F S F=$O(^DIST(.403,"F"_FILE,FNAM,F)) Q:F="" D
.. Q:$D(^DIST(.403,F,0))[0
.. S @REF@("FRM",F)=$P(^DIST(.403,F,0),U)
;
;Get all blocks associated with each form
S F="" F S F=$O(@REF@("FRM",F)) Q:F="" D
. S P=0 F S P=$O(^DIST(.403,F,40,P)) Q:'P D
.. S B=$P($G(^DIST(.403,F,40,P,0)),U,2)
.. I B D SETBLK(B,REF)
.. S B=0 F S B=$O(^DIST(.403,F,40,P,40,B)) Q:'B D SETBLK(B,REF)
Q
;
SETBLK(B,REF) ;
;Put block info into @REF
N B0
S B0=$G(^DIST(.404,B,0)) Q:B0?."^"
S @REF@("BLK",B)=$P(B0,U)_U_$$OTHER(B,REF)_U_($D(@REF@("DD",+$P(B0,U,2)))#2)
Q
;
DELBLK(DDSBLK,DDSFRM) ;
;Delete block DDSBLK from form DDSFRM
N DIK,DA,D0
S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSFRM,40,DDSPG)) Q:'DDSPG D
. I $D(^DIST(.403,DDSFRM,40,DDSPG,40,"B",DDSBLK)) D
.. S DIK="^DIST(.403,"_DDSFRM_",40,"_DDSPG_",40,"
.. S DA(2)=DDSFRM,DA(1)=DDSPG,DA=DDSBLK
.. D ^DIK
Q
;
DD(F,REF,K) ;
;Put file # and all its subfile #s into array @REF@("DD")
;Kill REF first if $G(K)=""
N SB
K:$G(K)="" @REF@("DD")
S @REF@("DD",F)=""
S SB="" F S SB=$O(^DD(F,"SB",SB)) Q:SB="" D DD(SB,REF,1)
Q
;
OTHER(B,REF) ;
;Is block B found on forms other than what's in @REF@("FRM",F)=""
;If so, put form numbers in @REF@("BLK",B,F)
N F,O,C
S O=0,F=""
F C="AB","AC" F S F=$O(^DIST(.403,C,B,F)) Q:F="" D
. I $D(@REF@("FRM",F))[0 S O=1,@REF@("BLK",B,F)=""
Q O
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSDEL 3843 printed Sep 23, 2025@20:19:22 Page 2
DDSDEL ;SFISC/MKO-DELETE FORMS FOR A FILE ;24JUL2003
+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 ;
FORM(DDSFILE,DDSECHO) ;
+1 ;Delete all forms/blocks associated with file DDSFILE
+2 NEW DDSREF,DDSBLK,DDSBNAM,DDSFRM,DDSOFRM,DDSLN,DDSPDD,DDSPG
+3 NEW %,DIK,DIOVRD,DA,D0,X,Y
+4 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+5 SET DIOVRD=1
+6 DO SETUP
DO GETFORMS(DDSFILE,DDSREF)
+7 ;
+8 ;Delete forms
+9 if DDSECHO
WRITE !?3,"Deleting the FORMS..."
+10 SET DDSFRM=""
SET DIK="^DIST(.403,"
+11 FOR
SET DDSFRM=$ORDER(@DDSREF@("FRM",DDSFRM))
if 'DDSFRM
QUIT
SET DA=DDSFRM
DO ^DIK
+12 KILL DIK,DA
+13 ;
+14 ;Delete blocks
+15 if DDSECHO
WRITE !?3,"Deleting the BLOCKS..."
+16 SET DDSBLK=""
SET DIK="^DIST(.404,"
+17 FOR
SET DDSBLK=$ORDER(@DDSREF@("BLK",DDSBLK))
if 'DDSBLK
QUIT
Begin DoDot:1
+18 SET DDSLN=@DDSREF@("BLK",DDSBLK)
+19 SET DDSBNAM=$PIECE(DDSLN,U)
SET DDSOFRM=$PIECE(DDSLN,U,2)
SET DDSPDD=$PIECE(DDSLN,U,3)
+20 ;
+21 IF DDSOFRM
IF DDSPDD
Begin DoDot:2
+22 IF DDSECHO
Begin DoDot:3
+23 WRITE !!?3,$CHAR(7)_"*** Warning ***"
+24 WRITE !!?3,"Block "_DDSBNAM_" (#"_DDSBLK_")"
+25 WRITE !?3,"was deleted from the Block file."
+26 WRITE !!?3,"I'm deleting pointers to that block from"
End DoDot:3
+27 SET DDSFRM=""
+28 FOR
SET DDSFRM=$ORDER(@DDSREF@("BLK",DDSBLK,DDSFRM))
if 'DDSFRM
QUIT
Begin DoDot:3
+29 if DDSECHO
WRITE !?6,"Form "_$PIECE(^DIST(.403,DDSFRM,0),U)_" (#"_DDSFRM_") ..."
+30 DO DELBLK(DDSBLK,DDSFRM)
End DoDot:3
+31 if DDSECHO
WRITE !!?3,"The above form(s) need to be redesigned.",!
End DoDot:2
+32 ;
+33 IF '$TEST
IF 'DDSOFRM
Begin DoDot:2
+34 SET DA=DDSBLK
DO ^DIK
End DoDot:2
End DoDot:1
+35 ;
QUIT ;Cleanup and quit
+1 KILL @DDSREF
+2 QUIT
+3 ;
SETUP ;Setup local variables
+1 if $DATA(DDSECHO)[0
SET DDSECHO=0
+2 ;IF $J IS NOT NUMERIC
SET DDSREF="^TMP(""DDSDEL"","""_$JOB_""")"
+3 KILL @DDSREF
+4 QUIT
+5 ;
GETFORMS(FILE,REF) ;
+1 ;Get all forms and blocks associated with file number FILE
+2 ;and all subfiles associated with FILE
+3 ;Put results in
+4 ; @REF@("DD",file#) = null
+5 ; ("FRM",form#) = form name
+6 ; ("BLK",block#) = block name^used on forms not being
+7 ; deleted^dd of block is being deleted
+8 ; ("BLK",block#,form#) = null for all blocks that are found
+9 ; on a form not being deleted
+10 ;
+11 NEW B,F,P,FNAM
+12 ;Get DDs of file and subfiles
+13 DO DD(FILE,REF)
+14 ;
+15 ;Get all forms associated with file
+16 SET FNAM=""
FOR
SET FNAM=$ORDER(^DIST(.403,"F"_FILE,FNAM))
if FNAM=""
QUIT
Begin DoDot:1
+17 SET F=""
FOR
SET F=$ORDER(^DIST(.403,"F"_FILE,FNAM,F))
if F=""
QUIT
Begin DoDot:2
+18 if $DATA(^DIST(.403,F,0))[0
QUIT
+19 SET @REF@("FRM",F)=$PIECE(^DIST(.403,F,0),U)
End DoDot:2
End DoDot:1
+20 ;
+21 ;Get all blocks associated with each form
+22 SET F=""
FOR
SET F=$ORDER(@REF@("FRM",F))
if F=""
QUIT
Begin DoDot:1
+23 SET P=0
FOR
SET P=$ORDER(^DIST(.403,F,40,P))
if 'P
QUIT
Begin DoDot:2
+24 SET B=$PIECE($GET(^DIST(.403,F,40,P,0)),U,2)
+25 IF B
DO SETBLK(B,REF)
+26 SET B=0
FOR
SET B=$ORDER(^DIST(.403,F,40,P,40,B))
if 'B
QUIT
DO SETBLK(B,REF)
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
SETBLK(B,REF) ;
+1 ;Put block info into @REF
+2 NEW B0
+3 SET B0=$GET(^DIST(.404,B,0))
if B0?."^"
QUIT
+4 SET @REF@("BLK",B)=$PIECE(B0,U)_U_$$OTHER(B,REF)_U_($DATA(@REF@("DD",+$PIECE(B0,U,2)))#2)
+5 QUIT
+6 ;
DELBLK(DDSBLK,DDSFRM) ;
+1 ;Delete block DDSBLK from form DDSFRM
+2 NEW DIK,DA,D0
+3 SET DDSPG=0
FOR
SET DDSPG=$ORDER(^DIST(.403,DDSFRM,40,DDSPG))
if 'DDSPG
QUIT
Begin DoDot:1
+4 IF $DATA(^DIST(.403,DDSFRM,40,DDSPG,40,"B",DDSBLK))
Begin DoDot:2
+5 SET DIK="^DIST(.403,"_DDSFRM_",40,"_DDSPG_",40,"
+6 SET DA(2)=DDSFRM
SET DA(1)=DDSPG
SET DA=DDSBLK
+7 DO ^DIK
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
DD(F,REF,K) ;
+1 ;Put file # and all its subfile #s into array @REF@("DD")
+2 ;Kill REF first if $G(K)=""
+3 NEW SB
+4 if $GET(K)=""
KILL @REF@("DD")
+5 SET @REF@("DD",F)=""
+6 SET SB=""
FOR
SET SB=$ORDER(^DD(F,"SB",SB))
if SB=""
QUIT
DO DD(SB,REF,1)
+7 QUIT
+8 ;
OTHER(B,REF) ;
+1 ;Is block B found on forms other than what's in @REF@("FRM",F)=""
+2 ;If so, put form numbers in @REF@("BLK",B,F)
+3 NEW F,O,C
+4 SET O=0
SET F=""
+5 FOR C="AB","AC"
FOR
SET F=$ORDER(^DIST(.403,C,B,F))
if F=""
QUIT
Begin DoDot:1
+6 IF $DATA(@REF@("FRM",F))[0
SET O=1
SET @REF@("BLK",B,F)=""
End DoDot:1
+7 QUIT O
