QAPQCOPY ;557/THM-COPY SURVEY QUESTIONS [ 06/19/95 2:26 PM ]
;;2.0;Survey Generator;;Jun 20, 1995
;
Q ;enter properly
;
EN W " Copy a question " H 1
K DIC,DR,DIE,X,Y
I $O(^QA(748.25,"E",SURVEY,0))="" W !!,"There are no questions on this survey.",!!,"Press RETURN " R ANS:DTIME S:'$T STOP=1 G EXIT
N QAPHDR
;
START S QAPOUT=0 W @IOF,! S QAPHDR="Copy Survey Questions" X QAPBAR W !!,"Enter the question number to copy: " R DQUES:DTIME I '$T S STOP=1 G EXIT
I DQUES["?" D HELPLKE^QAPUTIL1 I QAPQN]"" S DQUES=QAPQN W @IOF,! X QAPBAR
I DQUES[U!(DQUES="")!(QAPQN="")!(QAPQN[U) S QAPOUT=1 G EXIT
X CLEOP S DA=$O(^QA(748.25,"E",SURVEY,DQUES,0)) I DA]"" F I=0:0 S I=$O(^QA(748.25,SURVEY,1,DA,2,I)) D:I=""!(+I=0) Q:I=""!(+I=0) S X=$P(^QA(748.25,SURVEY,1,DA,2,I,0),U,1) W X,!
I DQUES?1.3N,DA="" W *7,!!,"There is no question number ",DQUES,! H 2 G START
I DQUES'?1.3N,DQUES'?1.3N1"."1.2N W !!,*7,"Your entry must be numeric and also an existing question number. " H 3 G START
W !! S QLINE=15
;
SEL W "Is this correct question" S %=2 D YN^DICN G:%=2 START G:%<0 EXIT
I $D(%Y),%Y["?" W *7,!!,"Enter Y to proceed, N to go back and reselect",!,"""^"" to exit",!! H 2 X CLEOP1 G SEL
;
QAPQN I $D(NUM) S QAPQN=NUM G QAPQN1
S QLINE=4 X CLEOP1 W *7,!,"You must enter a new number for this ",BLDON,"NEW",BLDOFF," question.",!!,"QUESTION NUMBER: ",*7 R QAPQN:DTIME I '$T S STOP=1 Q
Q:QAPQN[U I QAPQN'?1.3N!(QAPQN<0)!(QAPQN>999) W !!,*7,"Entry must be 1-3 numbers (1-999) and must be unique. Enter ^ to exit.",! H 2 G QAPQN
I $O(^QA(748.25,"E",SURVEY,QAPQN,0))]"",QAPOUT=0 W !!,*7,"You must enter a different question number.",!,"That one has been used." H 3 G QAPQN
;
QAPQN1 S X=$P(^QA(748.25,SURVEY,1,0),U,3)+1,DA(1)=SURVEY,DIC(0)="QM",(DIC,DIE)="^QA(748.25,"_SURVEY_",1," K DO,DD D FILE^DICN
S XDA=+Y,%X="^QA(748.25,DA(1),1,DA,",%Y="^QA(748.25,DA(1),1,XDA,"
D %XY^%RCR N DR S DA(1)=SURVEY,DA=XDA,DR=".015////"_QAPQN,(DIC,DIE)="^QA(748.25,"_DA(1)_",1," D ^DIE ;reset name, set new question number
S $P(^QA(748.25,DA(1),1,DA,0),U,1)=DA ;reset .01 for reindex
S DIK="^QA(748.25,",DA=SURVEY D IX^DIK W " Copied " H 1 ;reindex entire record
;
EDIT W @IOF,! X QAPBAR S (DIE,DIC)="^QA(748.25,DA(1),1,",DA=XDA,DR=".055;.05" W *7,!!,"Now you may edit the question header and text.",!,"The rest of the question definition will remain",!,"the same unless you change it specifically.",!! D ^DIE
;
EXIT Q ;kill variables in calling program
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPQCOPY 2486 printed Nov 22, 2024@17:48:25 Page 2
QAPQCOPY ;557/THM-COPY SURVEY QUESTIONS [ 06/19/95 2:26 PM ]
+1 ;;2.0;Survey Generator;;Jun 20, 1995
+2 ;
+3 ;enter properly
QUIT
+4 ;
EN WRITE " Copy a question "
HANG 1
+1 KILL DIC,DR,DIE,X,Y
+2 IF $ORDER(^QA(748.25,"E",SURVEY,0))=""
WRITE !!,"There are no questions on this survey.",!!,"Press RETURN "
READ ANS:DTIME
if '$TEST
SET STOP=1
GOTO EXIT
+3 NEW QAPHDR
+4 ;
START SET QAPOUT=0
WRITE @IOF,!
SET QAPHDR="Copy Survey Questions"
XECUTE QAPBAR
WRITE !!,"Enter the question number to copy: "
READ DQUES:DTIME
IF '$TEST
SET STOP=1
GOTO EXIT
+1 IF DQUES["?"
DO HELPLKE^QAPUTIL1
IF QAPQN]""
SET DQUES=QAPQN
WRITE @IOF,!
XECUTE QAPBAR
+2 IF DQUES[U!(DQUES="")!(QAPQN="")!(QAPQN[U)
SET QAPOUT=1
GOTO EXIT
+3 XECUTE CLEOP
SET DA=$ORDER(^QA(748.25,"E",SURVEY,DQUES,0))
IF DA]""
FOR I=0:0
SET I=$ORDER(^QA(748.25,SURVEY,1,DA,2,I))
if I=""!(+I=0)
Begin DoDot:1
End DoDot:1
if I=""!(+I=0)
QUIT
SET X=$PIECE(^QA(748.25,SURVEY,1,DA,2,I,0),U,1)
WRITE X,!
+4 IF DQUES?1.3N
IF DA=""
WRITE *7,!!,"There is no question number ",DQUES,!
HANG 2
GOTO START
+5 IF DQUES'?1.3N
IF DQUES'?1.3N1"."1.2N
WRITE !!,*7,"Your entry must be numeric and also an existing question number. "
HANG 3
GOTO START
+6 WRITE !!
SET QLINE=15
+7 ;
SEL WRITE "Is this correct question"
SET %=2
DO YN^DICN
if %=2
GOTO START
if %<0
GOTO EXIT
+1 IF $DATA(%Y)
IF %Y["?"
WRITE *7,!!,"Enter Y to proceed, N to go back and reselect",!,"""^"" to exit",!!
HANG 2
XECUTE CLEOP1
GOTO SEL
+2 ;
QAPQN IF $DATA(NUM)
SET QAPQN=NUM
GOTO QAPQN1
+1 SET QLINE=4
XECUTE CLEOP1
WRITE *7,!,"You must enter a new number for this ",BLDON,"NEW",BLDOFF," question.",!!,"QUESTION NUMBER: ",*7
READ QAPQN:DTIME
IF '$TEST
SET STOP=1
QUIT
+2 if QAPQN[U
QUIT
IF QAPQN'?1.3N!(QAPQN<0)!(QAPQN>999)
WRITE !!,*7,"Entry must be 1-3 numbers (1-999) and must be unique. Enter ^ to exit.",!
HANG 2
GOTO QAPQN
+3 IF $ORDER(^QA(748.25,"E",SURVEY,QAPQN,0))]""
IF QAPOUT=0
WRITE !!,*7,"You must enter a different question number.",!,"That one has been used."
HANG 3
GOTO QAPQN
+4 ;
QAPQN1 SET X=$PIECE(^QA(748.25,SURVEY,1,0),U,3)+1
SET DA(1)=SURVEY
SET DIC(0)="QM"
SET (DIC,DIE)="^QA(748.25,"_SURVEY_",1,"
KILL DO,DD
DO FILE^DICN
+1 SET XDA=+Y
SET %X="^QA(748.25,DA(1),1,DA,"
SET %Y="^QA(748.25,DA(1),1,XDA,"
+2 ;reset name, set new question number
DO %XY^%RCR
NEW DR
SET DA(1)=SURVEY
SET DA=XDA
SET DR=".015////"_QAPQN
SET (DIC,DIE)="^QA(748.25,"_DA(1)_",1,"
DO ^DIE
+3 ;reset .01 for reindex
SET $PIECE(^QA(748.25,DA(1),1,DA,0),U,1)=DA
+4 ;reindex entire record
SET DIK="^QA(748.25,"
SET DA=SURVEY
DO IX^DIK
WRITE " Copied "
HANG 1
+5 ;
EDIT WRITE @IOF,!
XECUTE QAPBAR
SET (DIE,DIC)="^QA(748.25,DA(1),1,"
SET DA=XDA
SET DR=".055;.05"
WRITE *7,!!,"Now you may edit the question header and text.",!,"The rest of the question definition will remain",!,"the same unless you change it specifically.",!!
DO ^DIE
+1 ;
EXIT ;kill variables in calling program
QUIT
