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

DDSCLONE.m

Go to the documentation of this file. 
  1. DDSCLONE ;SFISC/MKO-CLONE A FORM ;10:20 PM  10 Jul 1994
  1.  ;;22.0;VA FileMan;;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  N %,%CHK,%RET,%X,%Y,D,D0,D1,DA,DI,DIOVRD,DIC,DIR,DIZ,DQ,DREF,X,Y
  1.  K ^TMP("DDSCLONE",$J)
  1.  S DDSQUIT=0,DIOVRD=1
  1.  ;
  1.  S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
  1.  ;
  1.  D GETBLKS
  1.  D REPORT G:DDSQUIT QUIT
  1.  D RENMSP G:DDSQUIT QUIT
  1.  D RENAME G:DDSQUIT QUIT
  1.  D ^DDSCLONF
  1.  W !!!,"DONE!"
  1.  ;
  1. QUIT ;Cleanup
  1.  K ^TMP("DDSCLONE",$J)
  1.  K DDSBK,DDSBKDA,DDSFILE,DDSFORM,DDSNFRM,DDSNNS,DDSONS,DDSQUIT
  1.  K DDH,DIRUT,DIROUT,DTOUT,DUOUT
  1.  Q
  1.  ;
  1. FORM() ;Prompt for form
  1.  ;Select file
  1.  N D,DIC
  1.  S DDS1="CLONE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
  1.  I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
  1.  S DDSFILE=Y
  1.  ;
  1.  ;Select form
  1.  W ! K DIC
  1.  S DIC="^DIST(.403,",DIC(0)="QEAM"
  1.  S DIC(0)="QEA",D="F"_+DDSFILE
  1.  S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
  1.  S DIC("A")="Select FORM to clone: "
  1.  S DIC("W")=$P($T(DICW),";",3,999)
  1. DICW ;;N %G,%Y S %Y=Y,%G=^(0) W:$X>35 ! W ?35,"#"_Y S Y=$P(%G,U,5) W:Y]"" ?43," "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y S Y=%Y
  1.  D IX^DIC
  1.  ;
  1. FORMQ Q Y
  1.  ;
  1. GETBLKS ;Get all blocks on form
  1.  ; ^TMP("DDSCLONE",$J,bk#)=Block name
  1.  ;
  1.  N B,P
  1.  S P=0 F  S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P  D
  1.  . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
  1.  . I B]"",'$D(^TMP("DDSCLONE",$J,B)) D
  1.  .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
  1.  . S B=0
  1.  . F  S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B  D
  1.  .. Q:$D(^TMP("DDSCLONE",$J,B))
  1.  .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
  1.  Q
  1.  ;
  1. REPORT ;Print report
  1.  N B
  1.  W !!!
  1.  I '$D(^TMP("DDSCLONE",$J)) S DDSQUIT=1 W "There are no blocks on this form." Q
  1.  ;
  1.  W "  BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
  1.  W !!,"  Internal"
  1.  W !,"  Entry Number   Block Name"
  1.  W !,"  ------------   ----------"
  1.  ;
  1.  S B="" F  S B=$O(^TMP("DDSCLONE",$J,B)) Q:B=""  D
  1.  . W !,"  "_B,?17,$P(^TMP("DDSCLONE",$J,B),U)
  1.  ;
  1.  K DIR
  1.  S DIR(0)="E"
  1.  W ! D ^DIR K DIR
  1.  I $D(DIRUT) S DDSQUIT=1
  1.  W !
  1.  Q
  1.  ;
  1. RENMSP ;Prompt for new namespace
  1.  W !!,"The new form and blocks must be given unique names.",!
  1.  ;
  1.  K DIR
  1.  S DIR(0)="Y",DIR("B")="YES"
  1.  S DIR("A",1)="Give the new form and blocks the same names as the original,"
  1.  S DIR("A")="but a different namespace"
  1.  S DIR("?",1)="   Answer 'YES' if the original form and blocks are namespaced, and you want"
  1.  S DIR("?")="   the new forms and blocks to have a different namespace."
  1.  D ^DIR K DIR
  1.  I $D(DIRUT) S DDSQUIT=1 Q
  1.  I 'Y K DDSONSP,DDSNNSP Q
  1.  ;
  1.  K DIR
  1.  W !!
  1.  S DIR(0)="FA^1:30"
  1.  S DIR("A")="Original namespace: "
  1.  S DIR("?")="   Enter the namespace of the original form and blocks"
  1.  D ^DIR K DIR
  1.  I $D(DIRUT) S DDSQUIT=1 Q
  1.  S DDSONS=Y
  1.  ;
  1.  K DIR,X,Y
  1.  S DIR(0)="FA^1:30"
  1.  S DIR("A")="     New namespace: "
  1.  S DIR("?")="   Enter the namespace of the new form and blocks"
  1.  D ^DIR K DIR
  1.  I $D(DIRUT) S DDSQUIT=1 Q
  1.  S DDSNNS=Y
  1.  K X,Y
  1.  Q
  1.  ;
  1. RENAME ;Prompt for new names
  1.  N DDSBK,DDSBKDA
  1.  D:'$D(IOST) HOME^%ZIS
  1.  W @IOF
  1.  W "Enter names for the new form and blocks."
  1.  ;
  1.  D RENFORM Q:DDSQUIT
  1.  ;
  1.  W !
  1.  S DDSBKDA=0
  1.  F  S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA))  Q:'DDSBKDA!DDSQUIT  D
  1.  . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
  1.  . D RENBLK(.DDSBK) Q:DDSQUIT
  1.  . S ^TMP("DDSCLONE",$J,DDSBKDA)=DDSBK
  1.  . S ^TMP("DDSCLONE",$J,"B",$P(DDSBK,U,2))=""
  1.  ;
  1.  Q
  1.  ;
  1. RENFORM ;Rename the form
  1.  N DDSANS,DDSCOD
  1.  F  D  Q:DDSANS]""!DDSQUIT
  1.  . W !!,"Original form name: "_$P(DDSFORM,U,2)
  1.  . W !,"     New form name: "
  1.  . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSFORM,U,2),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
  1.  . ;
  1.  . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
  1.  . I DDSANS?1."?" W !!,"  Enter the name of the new form." S DDSANS=""
  1.  . Q:DDSANS=""
  1.  . S X=DDSANS X $P(^DD(.403,.01,0),U,5,999)
  1.  . I '$D(X) S DDSANS="" W !!,$C(7)_"  Invalid name." Q
  1.  . I $D(^DIST(.403,"B",DDSANS)) D  Q
  1.  .. S DDSANS=""
  1.  .. W !!,$C(7)_"  Form with this name already exists."
  1.  Q:DDSQUIT
  1.  ;
  1.  S $P(DDSFORM,U,3)=DDSANS
  1.  Q
  1.  ;
  1. RENBLK(DDSBK) ;Rename the blocks
  1.  N DDSANS,DDSCOD
  1.  F  D  Q:DDSANS]""!DDSQUIT
  1.  . W !!,"Original block name: "_$P(DDSBK,U)
  1.  . W !,"     New block name: "
  1.  . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSBK,U),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
  1.  . ;
  1.  . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
  1.  . I DDSANS?1."?" W !!,"  Enter the name of the new form." S DDSANS=""
  1.  . Q:DDSANS=""
  1.  . S X=DDSANS X $P(^DD(.404,.01,0),U,5,999)
  1.  . I '$D(X) S DDSANS="" W !!,$C(7)_"  Invalid name." Q
  1.  . D:$D(^DIST(.404,"B",DDSANS))!$D(^TMP("DDSCLONE",$J,"B",DDSANS))
  1.  .. S DDSANS=""
  1.  .. W !!,$C(7)_"  Block with this name already exists."
  1.  Q:DDSQUIT
  1.  ;
  1.  S $P(DDSBK,U,2)=DDSANS
  1.  Q
  1.  ;
  1. NAME(NAME,ONS,NNS) ;Replace old namespace with new
  1.  I $G(ONS)=""!($G(NNS)="") Q NAME
  1.  I $P(NAME,ONS)]"" Q NAME
  1.  Q NNS_$E(NAME,$L(ONS)+1,999)