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