source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDSCLONE.m@ 1474

Last change on this file since 1474 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
[613]1DDSCLONE ;SFISC/MKO-CLONE A FORM ;10:20 PM 10 Jul 1994
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N %,%CHK,%RET,%X,%Y,D,D0,D1,DA,DI,DIOVRD,DIC,DIR,DIZ,DQ,DREF,X,Y
5 K ^TMP("DDSCLONE",$J)
6 S DDSQUIT=0,DIOVRD=1
7 ;
8 S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
9 ;
10 D GETBLKS
11 D REPORT G:DDSQUIT QUIT
12 D RENMSP G:DDSQUIT QUIT
13 D RENAME G:DDSQUIT QUIT
14 D ^DDSCLONF
15 W !!!,"DONE!"
16 ;
17QUIT ;Cleanup
18 K ^TMP("DDSCLONE",$J)
19 K DDSBK,DDSBKDA,DDSFILE,DDSFORM,DDSNFRM,DDSNNS,DDSONS,DDSQUIT
20 K DDH,DIRUT,DIROUT,DTOUT,DUOUT
21 Q
22 ;
23FORM() ;Prompt for form
24 ;Select file
25 N D,DIC
26 S DDS1="CLONE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
27 I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
28 S DDSFILE=Y
29 ;
30 ;Select form
31 W ! K DIC
32 S DIC="^DIST(.403,",DIC(0)="QEAM"
33 S DIC(0)="QEA",D="F"_+DDSFILE
34 S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
35 S DIC("A")="Select FORM to clone: "
36 S DIC("W")=$P($T(DICW),";",3,999)
37DICW ;;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
38 D IX^DIC
39 ;
40FORMQ Q Y
41 ;
42GETBLKS ;Get all blocks on form
43 ; ^TMP("DDSCLONE",$J,bk#)=Block name
44 ;
45 N B,P
46 S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D
47 . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
48 . I B]"",'$D(^TMP("DDSCLONE",$J,B)) D
49 .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
50 . S B=0
51 . F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D
52 .. Q:$D(^TMP("DDSCLONE",$J,B))
53 .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
54 Q
55 ;
56REPORT ;Print report
57 N B
58 W !!!
59 I '$D(^TMP("DDSCLONE",$J)) S DDSQUIT=1 W "There are no blocks on this form." Q
60 ;
61 W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
62 W !!," Internal"
63 W !," Entry Number Block Name"
64 W !," ------------ ----------"
65 ;
66 S B="" F S B=$O(^TMP("DDSCLONE",$J,B)) Q:B="" D
67 . W !," "_B,?17,$P(^TMP("DDSCLONE",$J,B),U)
68 ;
69 K DIR
70 S DIR(0)="E"
71 W ! D ^DIR K DIR
72 I $D(DIRUT) S DDSQUIT=1
73 W !
74 Q
75 ;
76RENMSP ;Prompt for new namespace
77 W !!,"The new form and blocks must be given unique names.",!
78 ;
79 K DIR
80 S DIR(0)="Y",DIR("B")="YES"
81 S DIR("A",1)="Give the new form and blocks the same names as the original,"
82 S DIR("A")="but a different namespace"
83 S DIR("?",1)=" Answer 'YES' if the original form and blocks are namespaced, and you want"
84 S DIR("?")=" the new forms and blocks to have a different namespace."
85 D ^DIR K DIR
86 I $D(DIRUT) S DDSQUIT=1 Q
87 I 'Y K DDSONSP,DDSNNSP Q
88 ;
89 K DIR
90 W !!
91 S DIR(0)="FA^1:30"
92 S DIR("A")="Original namespace: "
93 S DIR("?")=" Enter the namespace of the original form and blocks"
94 D ^DIR K DIR
95 I $D(DIRUT) S DDSQUIT=1 Q
96 S DDSONS=Y
97 ;
98 K DIR,X,Y
99 S DIR(0)="FA^1:30"
100 S DIR("A")=" New namespace: "
101 S DIR("?")=" Enter the namespace of the new form and blocks"
102 D ^DIR K DIR
103 I $D(DIRUT) S DDSQUIT=1 Q
104 S DDSNNS=Y
105 K X,Y
106 Q
107 ;
108RENAME ;Prompt for new names
109 N DDSBK,DDSBKDA
110 D:'$D(IOST) HOME^%ZIS
111 W @IOF
112 W "Enter names for the new form and blocks."
113 ;
114 D RENFORM Q:DDSQUIT
115 ;
116 W !
117 S DDSBKDA=0
118 F S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT D
119 . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
120 . D RENBLK(.DDSBK) Q:DDSQUIT
121 . S ^TMP("DDSCLONE",$J,DDSBKDA)=DDSBK
122 . S ^TMP("DDSCLONE",$J,"B",$P(DDSBK,U,2))=""
123 ;
124 Q
125 ;
126RENFORM ;Rename the form
127 N DDSANS,DDSCOD
128 F D Q:DDSANS]""!DDSQUIT
129 . W !!,"Original form name: "_$P(DDSFORM,U,2)
130 . W !," New form name: "
131 . 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)
132 . ;
133 . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
134 . I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS=""
135 . Q:DDSANS=""
136 . S X=DDSANS X $P(^DD(.403,.01,0),U,5,999)
137 . I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q
138 . I $D(^DIST(.403,"B",DDSANS)) D Q
139 .. S DDSANS=""
140 .. W !!,$C(7)_" Form with this name already exists."
141 Q:DDSQUIT
142 ;
143 S $P(DDSFORM,U,3)=DDSANS
144 Q
145 ;
146RENBLK(DDSBK) ;Rename the blocks
147 N DDSANS,DDSCOD
148 F D Q:DDSANS]""!DDSQUIT
149 . W !!,"Original block name: "_$P(DDSBK,U)
150 . W !," New block name: "
151 . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSBK,U),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
152 . ;
153 . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
154 . I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS=""
155 . Q:DDSANS=""
156 . S X=DDSANS X $P(^DD(.404,.01,0),U,5,999)
157 . I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q
158 . D:$D(^DIST(.404,"B",DDSANS))!$D(^TMP("DDSCLONE",$J,"B",DDSANS))
159 .. S DDSANS=""
160 .. W !!,$C(7)_" Block with this name already exists."
161 Q:DDSQUIT
162 ;
163 S $P(DDSBK,U,2)=DDSANS
164 Q
165 ;
166NAME(NAME,ONS,NNS) ;Replace old namespace with new
167 I $G(ONS)=""!($G(NNS)="") Q NAME
168 I $P(NAME,ONS)]"" Q NAME
169 Q NNS_$E(NAME,$L(ONS)+1,999)
Note: See TracBrowser for help on using the repository browser.