- 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 Mar 13, 2025@21:43:15 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
