98 lines
2.6 KiB
Mathematica
98 lines
2.6 KiB
Mathematica
DDSCLONF ;SFISC/MKO-CLONE A FORM ;1:35 PM 4 Sep 1998
|
|
;;22.0;VA FileMan;;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
D ASKCONT Q:DDSQUIT
|
|
D CREATBK Q:DDSQUIT
|
|
D CREATFM Q:DDSQUIT
|
|
D EDITFM
|
|
D INDEXFM
|
|
K DDSNFRM
|
|
Q
|
|
;
|
|
CREATBK ;Create blocks
|
|
N DA,DIC
|
|
W !!,"Creating new blocks ...",!
|
|
S DDSBKDA=0
|
|
F S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT D
|
|
. S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
|
|
. W !?2,$P(DDSBK,U,2)
|
|
. K DIC,DD,DO
|
|
. S DIC="^DIST(.404,",DIC(0)="QL",X=$P(DDSBK,U,2)
|
|
. D FILE^DICN K DIC
|
|
. I Y=-1 D Q
|
|
.. W !,$C(7)_"Attempt to create block "_$P(DDSBK,U,2)_" failed."
|
|
.. S DDSQUIT=1
|
|
. M ^DIST(.404,+Y)=^DIST(.404,DDSBKDA)
|
|
. S $P(^DIST(.404,+Y,0),U)=$P(DDSBK,U,2)
|
|
. W ?35,"#"_+Y
|
|
. S $P(^TMP("DDSCLONE",$J,DDSBKDA),U,3)=+Y
|
|
Q
|
|
;
|
|
CREATFM ;Create form
|
|
N DA,DIC,DDSI,DDSJ
|
|
W !!,"Creating new form ..."
|
|
W !?2,$P(DDSFORM,U,3)
|
|
K DIC
|
|
S DIC="^DIST(.403,",DIC(0)="QL",X=$P(DDSFORM,U,3)
|
|
D FILE^DICN K DIC
|
|
I Y=-1 D Q
|
|
. W !,$C(7)_"Attempt to create form "_$P(DDSFORM,U,3)_" failed."
|
|
. S DDSQUIT=1
|
|
M ^DIST(.403,+Y)=^DIST(.403,+DDSFORM)
|
|
;
|
|
;Kill page and block multiple indexes
|
|
S DDSJ=" " F S DDSJ=$O(^DIST(.403,+Y,40,DDSJ)) Q:DDSJ="" D
|
|
. K ^DIST(.403,+Y,40,DDSJ)
|
|
S DDSI=0 F S DDSI=$O(^DIST(.403,+Y,40,DDSI)) Q:'DDSI D
|
|
. S DDSJ=" "
|
|
. F S DDSJ=$O(^DIST(.403,+Y,40,DDSI,40,DDSJ)) Q:DDSJ="" D
|
|
.. K ^DIST(.403,+Y,40,DDSI,40,DDSJ)
|
|
K @$$REF^DDS0(+Y)
|
|
;
|
|
S $P(^DIST(.403,+Y,0),U)=$P(DDSFORM,U,3)
|
|
W ?35,"#"_+Y
|
|
S DDSNFRM=+Y
|
|
Q
|
|
;
|
|
EDITFM ;Edit blocks used on new form
|
|
W !!,"Repointing to new blocks ..."
|
|
N DDSBK,DDSNBK,DDSPG
|
|
S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSNFRM,40,DDSPG)) Q:'DDSPG D
|
|
. S DDSBK=$P(^DIST(.403,DDSNFRM,40,DDSPG,0),U,2)
|
|
. I DDSBK]"" D
|
|
.. N DIE,DA,DR
|
|
.. S DIE="^DIST(.403,"_DDSNFRM_",40,"
|
|
.. S DA(1)=DDSNFRM,DA=DDSPG
|
|
.. S DR="1////"_$P(^TMP("DDSCLONE",$J,DDSBK),U,3)
|
|
.. D ^DIE
|
|
. ;
|
|
. N DA,DIK
|
|
. S DIK="^DIST(.403,"_DDSNFRM_",40,"_DDSPG_",40,"
|
|
. S DA(2)=DDSNFRM,DA(1)=DDSPG
|
|
. S DDSBK=0
|
|
. F S DDSBK=$O(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)) Q:'DDSBK D
|
|
.. Q:$D(^TMP("DDSCLONE",$J,DDSBK))[0 S DDSNBK=$P(^(DDSBK),U,3)
|
|
.. M ^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK)=^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)
|
|
.. S $P(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK,0),U)=DDSNBK
|
|
.. S DA=DDSBK
|
|
.. D ^DIK
|
|
Q
|
|
;
|
|
INDEXFM ;Index new form
|
|
W !,"Reindexing new form ..."
|
|
N DIK,DA
|
|
S DIK="^DIST(.403,",DA=DDSNFRM
|
|
D IX1^DIK
|
|
;
|
|
D EN^DDSZ(DDSNFRM)
|
|
Q
|
|
;
|
|
ASKCONT ;Final chance to abort
|
|
K DIR S DIR(0)="Y"
|
|
S DIR("A",1)=""
|
|
S DIR("A")="Ready to clone form"
|
|
S DIR("?")=" Enter 'Y' to clone form. Enter 'N' to exit."
|
|
D ^DIR K DIR
|
|
S:$D(DIRUT)!'Y DDSQUIT=1
|
|
Q
|