DDSCLONF ;SFISC/MKO-CLONE A FORM ;15OCT2003
;;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.
;
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)
S $P(^DIST(.403,+Y,0),U,5)=DT ;GFT CREATE DATE IS TODAY!
;
;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSCLONF 2994 printed Nov 22, 2024@17:53:09 Page 2
DDSCLONF ;SFISC/MKO-CLONE A FORM ;15OCT2003
+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 DO ASKCONT
if DDSQUIT
QUIT
+8 DO CREATBK
if DDSQUIT
QUIT
+9 DO CREATFM
if DDSQUIT
QUIT
+10 DO EDITFM
+11 DO INDEXFM
+12 KILL DDSNFRM
+13 QUIT
+14 ;
CREATBK ;Create blocks
+1 NEW DA,DIC
+2 WRITE !!,"Creating new blocks ...",!
+3 SET DDSBKDA=0
+4 FOR
SET DDSBKDA=$ORDER(^TMP("DDSCLONE",$JOB,DDSBKDA))
if 'DDSBKDA!DDSQUIT
QUIT
Begin DoDot:1
+5 SET DDSBK=^TMP("DDSCLONE",$JOB,DDSBKDA)
+6 WRITE !?2,$PIECE(DDSBK,U,2)
+7 KILL DIC,DD,DO
+8 SET DIC="^DIST(.404,"
SET DIC(0)="QL"
SET X=$PIECE(DDSBK,U,2)
+9 DO FILE^DICN
KILL DIC
+10 IF Y=-1
Begin DoDot:2
+11 WRITE !,$CHAR(7)_"Attempt to create block "_$PIECE(DDSBK,U,2)_" failed."
+12 SET DDSQUIT=1
End DoDot:2
QUIT
+13 MERGE ^DIST(.404,+Y)=^DIST(.404,DDSBKDA)
+14 SET $PIECE(^DIST(.404,+Y,0),U)=$PIECE(DDSBK,U,2)
+15 WRITE ?35,"#"_+Y
+16 SET $PIECE(^TMP("DDSCLONE",$JOB,DDSBKDA),U,3)=+Y
End DoDot:1
+17 QUIT
+18 ;
CREATFM ;Create form
+1 NEW DA,DIC,DDSI,DDSJ
+2 WRITE !!,"Creating new form ..."
+3 WRITE !?2,$PIECE(DDSFORM,U,3)
+4 KILL DIC
+5 SET DIC="^DIST(.403,"
SET DIC(0)="QL"
SET X=$PIECE(DDSFORM,U,3)
+6 DO FILE^DICN
KILL DIC
+7 IF Y=-1
Begin DoDot:1
+8 WRITE !,$CHAR(7)_"Attempt to create form "_$PIECE(DDSFORM,U,3)_" failed."
+9 SET DDSQUIT=1
End DoDot:1
QUIT
+10 MERGE ^DIST(.403,+Y)=^DIST(.403,+DDSFORM)
+11 ;GFT CREATE DATE IS TODAY!
SET $PIECE(^DIST(.403,+Y,0),U,5)=DT
+12 ;
+13 ;Kill page and block multiple indexes
+14 SET DDSJ=" "
FOR
SET DDSJ=$ORDER(^DIST(.403,+Y,40,DDSJ))
if DDSJ=""
QUIT
Begin DoDot:1
+15 KILL ^DIST(.403,+Y,40,DDSJ)
End DoDot:1
+16 SET DDSI=0
FOR
SET DDSI=$ORDER(^DIST(.403,+Y,40,DDSI))
if 'DDSI
QUIT
Begin DoDot:1
+17 SET DDSJ=" "
+18 FOR
SET DDSJ=$ORDER(^DIST(.403,+Y,40,DDSI,40,DDSJ))
if DDSJ=""
QUIT
Begin DoDot:2
+19 KILL ^DIST(.403,+Y,40,DDSI,40,DDSJ)
End DoDot:2
End DoDot:1
+20 KILL @$$REF^DDS0(+Y)
+21 ;
+22 SET $PIECE(^DIST(.403,+Y,0),U)=$PIECE(DDSFORM,U,3)
+23 WRITE ?35,"#"_+Y
+24 SET DDSNFRM=+Y
+25 QUIT
+26 ;
EDITFM ;Edit blocks used on new form
+1 WRITE !!,"Repointing to new blocks ..."
+2 NEW DDSBK,DDSNBK,DDSPG
+3 SET DDSPG=0
FOR
SET DDSPG=$ORDER(^DIST(.403,DDSNFRM,40,DDSPG))
if 'DDSPG
QUIT
Begin DoDot:1
+4 SET DDSBK=$PIECE(^DIST(.403,DDSNFRM,40,DDSPG,0),U,2)
+5 IF DDSBK]""
Begin DoDot:2
+6 NEW DIE,DA,DR
+7 SET DIE="^DIST(.403,"_DDSNFRM_",40,"
+8 SET DA(1)=DDSNFRM
SET DA=DDSPG
+9 SET DR="1////"_$PIECE(^TMP("DDSCLONE",$JOB,DDSBK),U,3)
+10 DO ^DIE
End DoDot:2
+11 ;
+12 NEW DA,DIK
+13 SET DIK="^DIST(.403,"_DDSNFRM_",40,"_DDSPG_",40,"
+14 SET DA(2)=DDSNFRM
SET DA(1)=DDSPG
+15 SET DDSBK=0
+16 FOR
SET DDSBK=$ORDER(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK))
if 'DDSBK
QUIT
Begin DoDot:2
+17 if $DATA(^TMP("DDSCLONE",$JOB,DDSBK))[0
QUIT
SET DDSNBK=$PIECE(^(DDSBK),U,3)
+18 MERGE ^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK)=^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)
+19 SET $PIECE(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK,0),U)=DDSNBK
+20 SET DA=DDSBK
+21 DO ^DIK
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
INDEXFM ;Index new form
+1 WRITE !,"Reindexing new form ..."
+2 NEW DIK,DA
+3 SET DIK="^DIST(.403,"
SET DA=DDSNFRM
+4 DO IX1^DIK
+5 ;
+6 DO EN^DDSZ(DDSNFRM)
+7 QUIT
+8 ;
ASKCONT ;Final chance to abort
+1 KILL DIR
SET DIR(0)="Y"
+2 SET DIR("A",1)=""
+3 SET DIR("A")="Ready to clone form"
+4 SET DIR("?")=" Enter 'Y' to clone form. Enter 'N' to exit."
+5 DO ^DIR
KILL DIR
+6 if $DATA(DIRUT)!'Y
SET DDSQUIT=1
+7 QUIT
