| [613] | 1 | DDSCLONF ;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 | ;
|
|---|
| 12 | CREATBK ;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 | ;
|
|---|
| 31 | CREATFM ;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 | ;
|
|---|
| 57 | EDITFM ;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 | ;
|
|---|
| 81 | INDEXFM ;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 | ;
|
|---|
| 90 | ASKCONT ;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
|
|---|
