- 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 Feb 19, 2025@00:04:57 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