Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DDSDEL

DDSDEL.m

Go to the documentation of this file. 
  1. DDSDEL ;SFISC/MKO-DELETE FORMS FOR A FILE ;24JUL2003
  1.  ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1.  ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1.  ;;Licensed under the terms of the Apache License, Version 2.0.
  1.  ;
  1. FORM(DDSFILE,DDSECHO) ;
  1.  ;Delete all forms/blocks associated with file DDSFILE
  1.  N DDSREF,DDSBLK,DDSBNAM,DDSFRM,DDSOFRM,DDSLN,DDSPDD,DDSPG
  1.  N %,DIK,DIOVRD,DA,D0,X,Y
  1.  I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
  1.  S DIOVRD=1
  1.  D SETUP,GETFORMS(DDSFILE,DDSREF)
  1.  ;
  1.  ;Delete forms
  1.  W:DDSECHO !?3,"Deleting the FORMS..."
  1.  S DDSFRM="",DIK="^DIST(.403,"
  1.  F  S DDSFRM=$O(@DDSREF@("FRM",DDSFRM)) Q:'DDSFRM  S DA=DDSFRM D ^DIK
  1.  K DIK,DA
  1.  ;
  1.  ;Delete blocks
  1.  W:DDSECHO !?3,"Deleting the BLOCKS..."
  1.  S DDSBLK="",DIK="^DIST(.404,"
  1.  F  S DDSBLK=$O(@DDSREF@("BLK",DDSBLK)) Q:'DDSBLK  D
  1.  . S DDSLN=@DDSREF@("BLK",DDSBLK)
  1.  . S DDSBNAM=$P(DDSLN,U),DDSOFRM=$P(DDSLN,U,2),DDSPDD=$P(DDSLN,U,3)
  1.  . ;
  1.  . I DDSOFRM,DDSPDD D
  1.  .. I DDSECHO D
  1.  ... W !!?3,$C(7)_"***  Warning  ***"
  1.  ... W !!?3,"Block "_DDSBNAM_" (#"_DDSBLK_")"
  1.  ... W !?3,"was deleted from the Block file."
  1.  ... W !!?3,"I'm deleting pointers to that block from"
  1.  .. S DDSFRM=""
  1.  .. F  S DDSFRM=$O(@DDSREF@("BLK",DDSBLK,DDSFRM)) Q:'DDSFRM  D
  1.  ... W:DDSECHO !?6,"Form "_$P(^DIST(.403,DDSFRM,0),U)_" (#"_DDSFRM_") ..."
  1.  ... D DELBLK(DDSBLK,DDSFRM)
  1.  .. W:DDSECHO !!?3,"The above form(s) need to be redesigned.",!
  1.  . ;
  1.  . E  I 'DDSOFRM D
  1.  .. S DA=DDSBLK D ^DIK
  1.  ;
  1. QUIT ;Cleanup and quit
  1.  K @DDSREF
  1.  Q
  1.  ;
  1. SETUP ;Setup local variables
  1.  S:$D(DDSECHO)[0 DDSECHO=0
  1.  S DDSREF="^TMP(""DDSDEL"","""_$J_""")" ;IF $J IS NOT NUMERIC
  1.  K @DDSREF
  1.  Q
  1.  ;
  1. GETFORMS(FILE,REF) ;
  1.  ;Get all forms and blocks associated with file number FILE
  1.  ;and all subfiles associated with FILE
  1.  ;Put results in
  1.  ;  @REF@("DD",file#)         = null
  1.  ;       ("FRM",form#)        = form name
  1.  ;       ("BLK",block#)       = block name^used on forms not being
  1.  ;                              deleted^dd of block is being deleted
  1.  ;       ("BLK",block#,form#) = null for all blocks that are found
  1.  ;                              on a form not being deleted
  1.  ;
  1.  N B,F,P,FNAM
  1.  ;Get DDs of file and subfiles
  1.  D DD(FILE,REF)
  1.  ;
  1.  ;Get all forms associated with file
  1.  S FNAM="" F  S FNAM=$O(^DIST(.403,"F"_FILE,FNAM)) Q:FNAM=""  D
  1.  . S F="" F  S F=$O(^DIST(.403,"F"_FILE,FNAM,F)) Q:F=""  D
  1.  .. Q:$D(^DIST(.403,F,0))[0
  1.  .. S @REF@("FRM",F)=$P(^DIST(.403,F,0),U)
  1.  ;
  1.  ;Get all blocks associated with each form
  1.  S F="" F  S F=$O(@REF@("FRM",F)) Q:F=""  D
  1.  . S P=0 F  S P=$O(^DIST(.403,F,40,P)) Q:'P  D
  1.  .. S B=$P($G(^DIST(.403,F,40,P,0)),U,2)
  1.  .. I B D SETBLK(B,REF)
  1.  .. S B=0 F  S B=$O(^DIST(.403,F,40,P,40,B)) Q:'B  D SETBLK(B,REF)
  1.  Q
  1.  ;
  1. SETBLK(B,REF) ;
  1.  ;Put block info into @REF
  1.  N B0
  1.  S B0=$G(^DIST(.404,B,0)) Q:B0?."^"
  1.  S @REF@("BLK",B)=$P(B0,U)_U_$$OTHER(B,REF)_U_($D(@REF@("DD",+$P(B0,U,2)))#2)
  1.  Q
  1.  ;
  1. DELBLK(DDSBLK,DDSFRM) ;
  1.  ;Delete block DDSBLK from form DDSFRM
  1.  N DIK,DA,D0
  1.  S DDSPG=0 F  S DDSPG=$O(^DIST(.403,DDSFRM,40,DDSPG)) Q:'DDSPG  D
  1.  . I $D(^DIST(.403,DDSFRM,40,DDSPG,40,"B",DDSBLK)) D
  1.  .. S DIK="^DIST(.403,"_DDSFRM_",40,"_DDSPG_",40,"
  1.  .. S DA(2)=DDSFRM,DA(1)=DDSPG,DA=DDSBLK
  1.  .. D ^DIK
  1.  Q
  1.  ;
  1. DD(F,REF,K) ;
  1.  ;Put file # and all its subfile #s into array @REF@("DD")
  1.  ;Kill REF first if $G(K)=""
  1.  N SB
  1.  K:$G(K)="" @REF@("DD")
  1.  S @REF@("DD",F)=""
  1.  S SB="" F  S SB=$O(^DD(F,"SB",SB)) Q:SB=""  D DD(SB,REF,1)
  1.  Q
  1.  ;
  1. OTHER(B,REF) ;
  1.  ;Is block B found on forms other than what's in @REF@("FRM",F)=""
  1.  ;If so, put form numbers in @REF@("BLK",B,F)
  1.  N F,O,C
  1.  S O=0,F=""
  1.  F C="AB","AC" F  S F=$O(^DIST(.403,C,B,F)) Q:F=""  D
  1.  . I $D(@REF@("FRM",F))[0 S O=1,@REF@("BLK",B,F)=""
  1.  Q O