| 1 | QAPCOPY ;557/THM-COPY A SURVEY [ 06/20/96 10:02 AM ]
|
|---|
| 2 | ;;2.0;Survey Generator;**5**;Jun 20, 1995
|
|---|
| 3 | ;
|
|---|
| 4 | D SCREEN^QAPUTIL
|
|---|
| 5 | EN W @IOF,! S QAPHDR="Copy a Survey" X QAPBAR W !,BLDON,"Type RETURN or ^ to exit",BLDOFF,!!
|
|---|
| 6 | S QAPCOPY=1,DIC("S")="I $P(^(0),U,5)=DUZ!($D(^XUSEC(""QAP MANAGER"",DUZ)))!($D(^QA(748,""AB"",DUZ,+Y)))" ;only authors or editors
|
|---|
| 7 | S DIC="^QA(748,",DIC(0)="AEQMZ",DIC("A")="Select survey to copy: " D ^DIC G:X=""!(X[U) EXIT S OSRVDA=+Y,OSRVNAM=$P(Y(0),U)
|
|---|
| 8 | S DA=OSRVDA D ^QAPCHKST G:$D(STOP) EXIT K DA
|
|---|
| 9 | I $D(NOPEN)!($D(CANCEL)) W !!,*7,"The survey COPY may need editing before it can be used.",! H 2 K NOPEN,CANCEL
|
|---|
| 10 | ;
|
|---|
| 11 | NEWN W !!,"Enter NEW survey name: " R NWNAM:DTIME G:NWNAM=""!(NWNAM[U)!('$T) EXIT
|
|---|
| 12 | S NWNAM=$TR(NWNAM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 13 | I NWNAM["?" W !!,"Enter the new name for this survey copy." G NEWN
|
|---|
| 14 | I NWNAM'?1.65AE W !!,*7,"The new name must be from 1-65 alpha characters." G NEWN
|
|---|
| 15 | X CLEOP W "Survey to copy: ",OSRVNAM,!?6,"New name: ",NWNAM,!!
|
|---|
| 16 | W !! K DIR S DIR("A")="Is everything Ok",DIR("B")="NO",DIR(0)="Y" D ^DIR G:$D(DIRUT) EXIT G:Y'=1 EN
|
|---|
| 17 | S OSRVQDA=$O(^QA(748.25,"B",OSRVDA,0))
|
|---|
| 18 | I OSRVQDA="" W !!,*7,"Survey questions not found for "_OSRVNAM_"!",!! H 2 G EXIT
|
|---|
| 19 | ;create the new survey record
|
|---|
| 20 | K X,%X,%Y,%Z,DIC
|
|---|
| 21 | S DIC(0)="EQM",(DIC,DIE)="^QA(748,",X=NWNAM,DIC("DR")=".055////"_DUZ
|
|---|
| 22 | K DO,DD D FILE^DICN S NSRVDA=+Y
|
|---|
| 23 | I NSRVDA<0 W !!,"New survey creation error !",! D DEL G EXIT
|
|---|
| 24 | ;create the new question record
|
|---|
| 25 | K DINUM,X K DIC
|
|---|
| 26 | S DIC(0)="EQM",(DIC,DIE)="^QA(748.25,",(DINUM,X)=NSRVDA K DO,DD D FILE^DICN
|
|---|
| 27 | W !!,"Copying ",OSRVNAM," . . . " H 1
|
|---|
| 28 | S %X="^QA(748,OSRVDA,",%Y="^QA(748,NSRVDA," D %XY^%RCR
|
|---|
| 29 | I $D(^QA(748,NSRVDA))<10 W !!,*7,"An error occurred while copying the main survey data",!,"from "_OSRVNAM W *7 D DEL G EXIT ;possible zero node, nothing else
|
|---|
| 30 | W !!,"Copying the questions . . . " H 1
|
|---|
| 31 | S %X="^QA(748.25,OSRVDA,",%Y="^QA(748.25,NSRVDA," D %XY^%RCR
|
|---|
| 32 | I $D(^QA(748.25,NSRVDA))<10 W !!,*7,"An error occurred while copying the questions",!,"from "_OSRVNAM W *7 D DEL G EXIT ;possible zero node, nothing else
|
|---|
| 33 | K DIC,DA S DA=NSRVDA,DIC(0)="EQM",(DIC,DIE)="^QA(748,",DR=".01///"_NWNAM_";.05////d;.055////"_DUZ D ^DIE ;reset name of copy, status, make copier the developer
|
|---|
| 34 | S $P(^QA(748.25,NSRVDA,0),U,1)=NSRVDA S DIK="^QA(748.25,",DA=NSRVDA D IX^DIK
|
|---|
| 35 | S DIK="^QA(748,",DA=NSRVDA D IX^DIK K DA,DIK
|
|---|
| 36 | W !!,"Finished.",! H 1
|
|---|
| 37 | W !!,"Press RETURN to continue " R ANS:DTIME
|
|---|
| 38 | ;
|
|---|
| 39 | EXIT K QAPCOPY G EXIT^QAPUTIL
|
|---|
| 40 | ;
|
|---|
| 41 | DEL S DIK="^QA(748," S DA=NSRVDA D ^DIK
|
|---|
| 42 | S DIK="^QA(748.25," S DA=NSRVDA D ^DIK
|
|---|
| 43 | W !!,"The partial records have been deleted. " H 2
|
|---|
| 44 | K DIK Q
|
|---|
