DDSCLONE ;SFISC/MKO-CLONE A FORM ;2OCT2003
;;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.
;
N %,%CHK,%RET,%X,%Y,D,D0,D1,DA,DI,DIOVRD,DIC,DIR,DIZ,DQ,DREF,X,Y
K ^TMP("DDSCLONE",$J)
S DDSQUIT=0,DIOVRD=1
;
S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
;
D GETBLKS
D REPORT G:DDSQUIT QUIT
D RENMSP G:DDSQUIT QUIT
D RENAME G:DDSQUIT QUIT
D ^DDSCLONF
DONE I '$G(DDSQUIT) W !!!,"DONE!"
;
QUIT ;Cleanup
K ^TMP("DDSCLONE",$J)
K DDSBK,DDSBKDA,DDSFILE,DDSFORM,DDSNFRM,DDSNNS,DDSONS,DDSQUIT
K DDH,DIRUT,DIROUT,DTOUT,DUOUT
Q
;
FORM() ;Prompt for form
;Select file
N D,DIC
EGP S DDS1=8108 D W^DICRW K DDS1 G:Y<0 FORMQ ;**CCO/NI 'CLONE FORM'
I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
S DDSFILE=Y
;
;Select form
W ! K DIC
S DIC="^DIST(.403,",DIC(0)="QEAM"
S DIC(0)="QEA",D="F"_+DDSFILE
S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
S DIC("A")="Select FORM to clone: "
S DIC("W")=$P($T(DICW),";",3,999)
DICW ;;N %G S %G=^(0) W:$X>35 ! W ?35,"#"_Y N Y S Y=$P(%G,U,5) W:Y]"" ?43,$$OUT^DIALOGU(Y,"FMTE","2D") S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y ;**CCO/NI NICE DATE OUTOUT
D IX^DIC
;
FORMQ Q Y
;
GETBLKS ;Get all blocks on form
; ^TMP("DDSCLONE",$J,bk#)=Block name
;
N B,P
S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D
. S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
. I B]"",'$D(^TMP("DDSCLONE",$J,B)) D
.. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
. S B=0
. F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D
.. Q:$D(^TMP("DDSCLONE",$J,B))
.. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
Q
;
REPORT ;Print report
N B
W !!!
I '$D(^TMP("DDSCLONE",$J)) S DDSQUIT=1 W "There are no blocks on this form." Q
;
W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
W !!," Internal"
W !," Entry Number Block Name"
W !," ------------ ----------"
;
S B="" F S B=$O(^TMP("DDSCLONE",$J,B)) Q:B="" D
. W !," "_B,?17,$P(^TMP("DDSCLONE",$J,B),U)
;
K DIR
S DIR(0)="E"
W ! D ^DIR K DIR
I $D(DIRUT) S DDSQUIT=1
W !
Q
;
RENMSP ;Prompt for new namespace
W !!,"The new form and blocks must be given unique names.",!
;
K DIR
S DIR(0)="Y",DIR("B")="YES"
S DIR("A",1)="Give the new form and blocks the same names as the original,"
S DIR("A")="but a different namespace"
S DIR("?",1)=" Answer 'YES' if the original form and blocks are namespaced, and you want"
S DIR("?")=" the new forms and blocks to have a different namespace."
D ^DIR K DIR
I $D(DIRUT) S DDSQUIT=1 Q
I 'Y K DDSONSP,DDSNNSP Q
;
K DIR
W !!
S DIR(0)="FA^1:30"
S DIR("A")="Original namespace: "
S DIR("?")=" Enter the namespace of the original form and blocks"
D ^DIR K DIR
I $D(DIRUT) S DDSQUIT=1 Q
S DDSONS=Y
;
K DIR,X,Y
S DIR(0)="FA^1:30"
S DIR("A")=" New namespace: "
S DIR("?")=" Enter the namespace of the new form and blocks"
D ^DIR K DIR
I $D(DIRUT) S DDSQUIT=1 Q
S DDSNNS=Y
K X,Y
Q
;
RENAME ;Prompt for new names
N DDSBK,DDSBKDA
D:'$D(IOST) HOME^%ZIS
W @IOF
W "Enter names for the new form and blocks."
;
D RENFORM Q:DDSQUIT
;
W !
S DDSBKDA=0
F S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT D
. S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
. D RENBLK(.DDSBK) Q:DDSQUIT
. S ^TMP("DDSCLONE",$J,DDSBKDA)=DDSBK
. S ^TMP("DDSCLONE",$J,"B",$P(DDSBK,U,2))=""
;
Q
;
RENFORM ;Rename the form
N DDSANS,DDSCOD
F D Q:DDSANS]""!DDSQUIT
. W !!,"Original form name: "_$P(DDSFORM,U,2)
. W !," New form name: "
. 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)
. ;
. I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
. I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS=""
. Q:DDSANS=""
. S X=DDSANS X $P(^DD(.403,.01,0),U,5,999)
. I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q
. I $D(^DIST(.403,"B",DDSANS)) D Q
.. S DDSANS=""
.. W !!,$C(7)_" Form with this name already exists."
Q:DDSQUIT
;
S $P(DDSFORM,U,3)=DDSANS
Q
;
RENBLK(DDSBK) ;Rename the blocks
N DDSANS,DDSCOD
F D Q:DDSANS]""!DDSQUIT
. W !!,"Original block name: "_$P(DDSBK,U)
. W !," New block name: "
. D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSBK,U),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
. ;
. I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
. I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS=""
. Q:DDSANS=""
. S X=DDSANS X $P(^DD(.404,.01,0),U,5,999)
. I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q
. D:$D(^DIST(.404,"B",DDSANS))!$D(^TMP("DDSCLONE",$J,"B",DDSANS))
.. S DDSANS=""
.. W !!,$C(7)_" Block with this name already exists."
Q:DDSQUIT
;
S $P(DDSBK,U,2)=DDSANS
Q
;
NAME(NAME,ONS,NNS) ;Replace old namespace with new
I $G(ONS)=""!($G(NNS)="") Q NAME
I $P(NAME,ONS)]"" Q NAME
Q NNS_$E(NAME,$L(ONS)+1,999)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSCLONE 5186 printed Apr 09, 2024@21:53:18 Page 2
DDSCLONE ;SFISC/MKO-CLONE A FORM ;2OCT2003
+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 NEW %,%CHK,%RET,%X,%Y,D,D0,D1,DA,DI,DIOVRD,DIC,DIR,DIZ,DQ,DREF,X,Y
+8 KILL ^TMP("DDSCLONE",$JOB)
+9 SET DDSQUIT=0
SET DIOVRD=1
+10 ;
+11 SET DDSFORM=$$FORM
if DDSFORM=-1
GOTO QUIT
+12 ;
+13 DO GETBLKS
+14 DO REPORT
if DDSQUIT
GOTO QUIT
+15 DO RENMSP
if DDSQUIT
GOTO QUIT
+16 DO RENAME
if DDSQUIT
GOTO QUIT
+17 DO ^DDSCLONF
DONE IF '$GET(DDSQUIT)
WRITE !!!,"DONE!"
+1 ;
QUIT ;Cleanup
+1 KILL ^TMP("DDSCLONE",$JOB)
+2 KILL DDSBK,DDSBKDA,DDSFILE,DDSFORM,DDSNFRM,DDSNNS,DDSONS,DDSQUIT
+3 KILL DDH,DIRUT,DIROUT,DTOUT,DUOUT
+4 QUIT
+5 ;
FORM() ;Prompt for form
+1 ;Select file
+2 NEW D,DIC
EGP ;**CCO/NI 'CLONE FORM'
SET DDS1=8108
DO W^DICRW
KILL DDS1
if Y<0
GOTO FORMQ
+1 IF '$DATA(@(DIC_"0)"))
SET Y=-1
GOTO FORMQ
+2 SET DDSFILE=Y
+3 ;
+4 ;Select form
+5 WRITE !
KILL DIC
+6 SET DIC="^DIST(.403,"
SET DIC(0)="QEAM"
+7 SET DIC(0)="QEA"
SET D="F"_+DDSFILE
+8 SET DIC("S")="I $P(^(0),U,8)=+DDSFILE"
+9 SET DIC("A")="Select FORM to clone: "
+10 SET DIC("W")=$PIECE($TEXT(DICW),";",3,999)
DICW ;;N %G S %G=^(0) W:$X>35 ! W ?35,"#"_Y N Y S Y=$P(%G,U,5) W:Y]"" ?43,$$OUT^DIALOGU(Y,"FMTE","2D") S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y ;**CCO/NI NICE DATE OUTOUT
+1 DO IX^DIC
+2 ;
FORMQ QUIT Y
+1 ;
GETBLKS ;Get all blocks on form
+1 ; ^TMP("DDSCLONE",$J,bk#)=Block name
+2 ;
+3 NEW B,P
+4 SET P=0
FOR
SET P=$ORDER(^DIST(.403,+DDSFORM,40,P))
if 'P
QUIT
Begin DoDot:1
+5 SET B=$PIECE(^DIST(.403,+DDSFORM,40,P,0),U,2)
+6 IF B]""
IF '$DATA(^TMP("DDSCLONE",$JOB,B))
Begin DoDot:2
+7 SET ^TMP("DDSCLONE",$JOB,B)=$PIECE($GET(^DIST(.404,B,0)),U)
End DoDot:2
+8 SET B=0
+9 FOR
SET B=$ORDER(^DIST(.403,+DDSFORM,40,P,40,B))
if 'B
QUIT
Begin DoDot:2
+10 if $DATA(^TMP("DDSCLONE",$JOB,B))
QUIT
+11 SET ^TMP("DDSCLONE",$JOB,B)=$PIECE($GET(^DIST(.404,B,0)),U)
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
REPORT ;Print report
+1 NEW B
+2 WRITE !!!
+3 IF '$DATA(^TMP("DDSCLONE",$JOB))
SET DDSQUIT=1
WRITE "There are no blocks on this form."
QUIT
+4 ;
+5 WRITE " BLOCKS USED ON FORM """_$PIECE(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
+6 WRITE !!," Internal"
+7 WRITE !," Entry Number Block Name"
+8 WRITE !," ------------ ----------"
+9 ;
+10 SET B=""
FOR
SET B=$ORDER(^TMP("DDSCLONE",$JOB,B))
if B=""
QUIT
Begin DoDot:1
+11 WRITE !," "_B,?17,$PIECE(^TMP("DDSCLONE",$JOB,B),U)
End DoDot:1
+12 ;
+13 KILL DIR
+14 SET DIR(0)="E"
+15 WRITE !
DO ^DIR
KILL DIR
+16 IF $DATA(DIRUT)
SET DDSQUIT=1
+17 WRITE !
+18 QUIT
+19 ;
RENMSP ;Prompt for new namespace
+1 WRITE !!,"The new form and blocks must be given unique names.",!
+2 ;
+3 KILL DIR
+4 SET DIR(0)="Y"
SET DIR("B")="YES"
+5 SET DIR("A",1)="Give the new form and blocks the same names as the original,"
+6 SET DIR("A")="but a different namespace"
+7 SET DIR("?",1)=" Answer 'YES' if the original form and blocks are namespaced, and you want"
+8 SET DIR("?")=" the new forms and blocks to have a different namespace."
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
SET DDSQUIT=1
QUIT
+11 IF 'Y
KILL DDSONSP,DDSNNSP
QUIT
+12 ;
+13 KILL DIR
+14 WRITE !!
+15 SET DIR(0)="FA^1:30"
+16 SET DIR("A")="Original namespace: "
+17 SET DIR("?")=" Enter the namespace of the original form and blocks"
+18 DO ^DIR
KILL DIR
+19 IF $DATA(DIRUT)
SET DDSQUIT=1
QUIT
+20 SET DDSONS=Y
+21 ;
+22 KILL DIR,X,Y
+23 SET DIR(0)="FA^1:30"
+24 SET DIR("A")=" New namespace: "
+25 SET DIR("?")=" Enter the namespace of the new form and blocks"
+26 DO ^DIR
KILL DIR
+27 IF $DATA(DIRUT)
SET DDSQUIT=1
QUIT
+28 SET DDSNNS=Y
+29 KILL X,Y
+30 QUIT
+31 ;
RENAME ;Prompt for new names
+1 NEW DDSBK,DDSBKDA
+2 if '$DATA(IOST)
DO HOME^%ZIS
+3 WRITE @IOF
+4 WRITE "Enter names for the new form and blocks."
+5 ;
+6 DO RENFORM
if DDSQUIT
QUIT
+7 ;
+8 WRITE !
+9 SET DDSBKDA=0
+10 FOR
SET DDSBKDA=$ORDER(^TMP("DDSCLONE",$JOB,DDSBKDA))
if 'DDSBKDA!DDSQUIT
QUIT
Begin DoDot:1
+11 SET DDSBK=^TMP("DDSCLONE",$JOB,DDSBKDA)
+12 DO RENBLK(.DDSBK)
if DDSQUIT
QUIT
+13 SET ^TMP("DDSCLONE",$JOB,DDSBKDA)=DDSBK
+14 SET ^TMP("DDSCLONE",$JOB,"B",$PIECE(DDSBK,U,2))=""
End DoDot:1
+15 ;
+16 QUIT
+17 ;
RENFORM ;Rename the form
+1 NEW DDSANS,DDSCOD
+2 FOR
Begin DoDot:1
+3 WRITE !!,"Original form name: "_$PIECE(DDSFORM,U,2)
+4 WRITE !," New form name: "
+5 DO EN^DIR0($SELECT($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($PIECE(DDSFORM,U,2),$GET(DDSONS),$GET(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
+6 ;
+7 IF $PIECE(DDSCOD,U)="TO"!(DDSANS=U)
SET DDSQUIT=1
QUIT
+8 IF DDSANS?1."?"
WRITE !!," Enter the name of the new form."
SET DDSANS=""
+9 if DDSANS=""
QUIT
+10 SET X=DDSANS
XECUTE $PIECE(^DD(.403,.01,0),U,5,999)
+11 IF '$DATA(X)
SET DDSANS=""
WRITE !!,$CHAR(7)_" Invalid name."
QUIT
+12 IF $DATA(^DIST(.403,"B",DDSANS))
Begin DoDot:2
+13 SET DDSANS=""
+14 WRITE !!,$CHAR(7)_" Form with this name already exists."
End DoDot:2
QUIT
End DoDot:1
if DDSANS]""!DDSQUIT
QUIT
+15 if DDSQUIT
QUIT
+16 ;
+17 SET $PIECE(DDSFORM,U,3)=DDSANS
+18 QUIT
+19 ;
RENBLK(DDSBK) ;Rename the blocks
+1 NEW DDSANS,DDSCOD
+2 FOR
Begin DoDot:1
+3 WRITE !!,"Original block name: "_$PIECE(DDSBK,U)
+4 WRITE !," New block name: "
+5 DO EN^DIR0($SELECT($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($PIECE(DDSBK,U),$GET(DDSONS),$GET(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
+6 ;
+7 IF $PIECE(DDSCOD,U)="TO"!(DDSANS=U)
SET DDSQUIT=1
QUIT
+8 IF DDSANS?1."?"
WRITE !!," Enter the name of the new form."
SET DDSANS=""
+9 if DDSANS=""
QUIT
+10 SET X=DDSANS
XECUTE $PIECE(^DD(.404,.01,0),U,5,999)
+11 IF '$DATA(X)
SET DDSANS=""
WRITE !!,$CHAR(7)_" Invalid name."
QUIT
+12 if $DATA(^DIST(.404,"B",DDSANS))!$DATA(^TMP("DDSCLONE",$JOB,"B",DDSANS))
Begin DoDot:2
+13 SET DDSANS=""
+14 WRITE !!,$CHAR(7)_" Block with this name already exists."
End DoDot:2
End DoDot:1
if DDSANS]""!DDSQUIT
QUIT
+15 if DDSQUIT
QUIT
+16 ;
+17 SET $PIECE(DDSBK,U,2)=DDSANS
+18 QUIT
+19 ;
NAME(NAME,ONS,NNS) ;Replace old namespace with new
+1 IF $GET(ONS)=""!($GET(NNS)="")
QUIT NAME
+2 IF $PIECE(NAME,ONS)]""
QUIT NAME
+3 QUIT NNS_$EXTRACT(NAME,$LENGTH(ONS)+1,999)
