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

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

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1DDSCLONF ;SFISC/MKO-CLONE A FORM ;1:35 PM 4 Sep 1998
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ASKCONT Q:DDSQUIT
5 D CREATBK Q:DDSQUIT
6 D CREATFM Q:DDSQUIT
7 D EDITFM
8 D INDEXFM
9 K DDSNFRM
10 Q
11 ;
12CREATBK ;Create blocks
13 N DA,DIC
14 W !!,"Creating new blocks ...",!
15 S DDSBKDA=0
16 F S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT D
17 . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
18 . W !?2,$P(DDSBK,U,2)
19 . K DIC,DD,DO
20 . S DIC="^DIST(.404,",DIC(0)="QL",X=$P(DDSBK,U,2)
21 . D FILE^DICN K DIC
22 . I Y=-1 D Q
23 .. W !,$C(7)_"Attempt to create block "_$P(DDSBK,U,2)_" failed."
24 .. S DDSQUIT=1
25 . M ^DIST(.404,+Y)=^DIST(.404,DDSBKDA)
26 . S $P(^DIST(.404,+Y,0),U)=$P(DDSBK,U,2)
27 . W ?35,"#"_+Y
28 . S $P(^TMP("DDSCLONE",$J,DDSBKDA),U,3)=+Y
29 Q
30 ;
31CREATFM ;Create form
32 N DA,DIC,DDSI,DDSJ
33 W !!,"Creating new form ..."
34 W !?2,$P(DDSFORM,U,3)
35 K DIC
36 S DIC="^DIST(.403,",DIC(0)="QL",X=$P(DDSFORM,U,3)
37 D FILE^DICN K DIC
38 I Y=-1 D Q
39 . W !,$C(7)_"Attempt to create form "_$P(DDSFORM,U,3)_" failed."
40 . S DDSQUIT=1
41 M ^DIST(.403,+Y)=^DIST(.403,+DDSFORM)
42 ;
43 ;Kill page and block multiple indexes
44 S DDSJ=" " F S DDSJ=$O(^DIST(.403,+Y,40,DDSJ)) Q:DDSJ="" D
45 . K ^DIST(.403,+Y,40,DDSJ)
46 S DDSI=0 F S DDSI=$O(^DIST(.403,+Y,40,DDSI)) Q:'DDSI D
47 . S DDSJ=" "
48 . F S DDSJ=$O(^DIST(.403,+Y,40,DDSI,40,DDSJ)) Q:DDSJ="" D
49 .. K ^DIST(.403,+Y,40,DDSI,40,DDSJ)
50 K @$$REF^DDS0(+Y)
51 ;
52 S $P(^DIST(.403,+Y,0),U)=$P(DDSFORM,U,3)
53 W ?35,"#"_+Y
54 S DDSNFRM=+Y
55 Q
56 ;
57EDITFM ;Edit blocks used on new form
58 W !!,"Repointing to new blocks ..."
59 N DDSBK,DDSNBK,DDSPG
60 S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSNFRM,40,DDSPG)) Q:'DDSPG D
61 . S DDSBK=$P(^DIST(.403,DDSNFRM,40,DDSPG,0),U,2)
62 . I DDSBK]"" D
63 .. N DIE,DA,DR
64 .. S DIE="^DIST(.403,"_DDSNFRM_",40,"
65 .. S DA(1)=DDSNFRM,DA=DDSPG
66 .. S DR="1////"_$P(^TMP("DDSCLONE",$J,DDSBK),U,3)
67 .. D ^DIE
68 . ;
69 . N DA,DIK
70 . S DIK="^DIST(.403,"_DDSNFRM_",40,"_DDSPG_",40,"
71 . S DA(2)=DDSNFRM,DA(1)=DDSPG
72 . S DDSBK=0
73 . F S DDSBK=$O(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)) Q:'DDSBK D
74 .. Q:$D(^TMP("DDSCLONE",$J,DDSBK))[0 S DDSNBK=$P(^(DDSBK),U,3)
75 .. M ^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK)=^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)
76 .. S $P(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK,0),U)=DDSNBK
77 .. S DA=DDSBK
78 .. D ^DIK
79 Q
80 ;
81INDEXFM ;Index new form
82 W !,"Reindexing new form ..."
83 N DIK,DA
84 S DIK="^DIST(.403,",DA=DDSNFRM
85 D IX1^DIK
86 ;
87 D EN^DDSZ(DDSNFRM)
88 Q
89 ;
90ASKCONT ;Final chance to abort
91 K DIR S DIR(0)="Y"
92 S DIR("A",1)=""
93 S DIR("A")="Ready to clone form"
94 S DIR("?")=" Enter 'Y' to clone form. Enter 'N' to exit."
95 D ^DIR K DIR
96 S:$D(DIRUT)!'Y DDSQUIT=1
97 Q
Note: See TracBrowser for help on using the repository browser.