QAPADD1 ;557/THM-CREATE A NEW SURVEY, PART 2 [ 05/19/95 7:22 AM ]
;;2.0;Survey Generator;;Jun 20, 1995
;
;called by QAPADD
LINES W @IOF,! S QAPHDR="Survey Name: "_SUBJ X QAPBAR S QAPHDR="(Adding Questions)" X QAPBAR
;
Q1 S INCMSG="W !,*7,""The increment must be numeric, non-decimal, between 1 and 10."",! H 2"
K DTOUT,DUOUT,SKIP X CLEOP W !,"Do you want help on question entry" S %=2 D YN^DICN G:$D(DTOUT) EXIT I %=1 K STOP D HELP^QAPUTIL1 I $D(STOP) G EXIT
I $D(%),%<0 S SKIP=1 G INCR
I $D(%Y),%Y["?" W !!,"Enter Y to see the help text or N to skip. " H 2 G Q1
;
INCR I '$D(SKIP) S NUM=1 X CLEOP W !,"What increment value do you wish your questions use? 1 // " R X:DTIME S:X="" X=1 I '$T S STOP=1 G EXIT
I X["?" W !!,"Enter the number to skip between questions.",! X INCMSG
I X[U!(X["?")!($D(SKIP)) W !!,"If you exit without entering any questions, you will have to use the",!,"'Add/edit Individual Questions' option to add them without benefit",!
I X[U!(X["?")!($D(SKIP)) W "of automatic question numbering.",!! I X["?" W "Press RETURN " R ANS:DTIME I '$T S (STOP,QAPOUT)=1 G EXIT
G:X["?" INCR
I X[U!($D(SKIP)) W "Is this OK" S %=2 D YN^DICN S:$D(DTOUT) STOP=1 G:%=1!($D(DTOUT))!($D(STOP)) EXIT G:%'=1&($D(SKIP)) LINES G:%'=1 INCR
I X<1!(X>10) W !! X INCMSG G INCR
K SKIP I NUM'=X S NUM=X
I X'?1.2N,X'>0 X INCMSG G INCR ;force non-decimal numbers
S INCREM=X,DA(1)=SURVEY K STOP,OUT,X
I '$D(^QA(748.25,DA(1),1,0)) S ^QA(748.25,DA(1),1,0)="^748.26I^0^0"
;
INCR1 K DTOUT,DUOUT,STOP,OUT
F DO G:$D(DTOUT)!($D(STOP)) EXIT G:$D(DUOUT)!($D(OUT)) FIN G:$D(STOP) EXIT
.;
DIS .W @IOF,! S QAPHDR="Survey Name: "_SUBJ X QAPBAR S QAPHDR="Adding Questions" X QAPBAR
.D REORD
.X CLEOP W BLDON,"Type ^ to exit",BLDOFF W:$D(LSTNUM) ?45,"Last question number: ",LSTNUM W !!,">> Question number: ",NUM,"//" R QAPQN:DTIME I '$T S STOP=1 Q
.I QAPQN="?" D HELPLKE^QAPUTIL1 Q:$D(STOP) I QAPQN="" G DIS
.I QAPQN[U S OUT=1 Q
.I QAPQN="" S QAPQN=NUM
.S QAPQN=$TR(QAPQN,"cr","CR")
.I QAPQN'?1.3N,QAPQN'?1.3N1"."1.2N,QAPQN'?1"C",QAPQN'?1"R",+QAPQN'=QAPQN W !!,"Question number entry must be numeric,'R' to resequence",!,"the question numbers, or 'C' to copy a question.",*7 H 2 G DIS
.I QAPQN?1"R" W " Resequence question numbers " H 1 D R1^QAPRSEQ S NUM=LSTNUM+INCREM G DIS
.I QAPQN?1"C" D EN^QAPQCOPY DO Q:$D(STOP) G DIS
..I NUM>QAPQN Q
..I NUM<QAPQN S NUM=(QAPQN\1)+INCREM Q
..I NUM=QAPQN S NUM=NUM+INCREM Q
.I +QAPQN<1!(+QAPQN>999) W !!,*7,"This number must be between 1 and 999. " H 2 G DIS
.S DA=$O(^QA(748.25,"E",DA(1),QAPQN,0)) I DA="" S CHOICE="A"
.I DA]"" K DIR S DIR("A")="Select option",DIR(0)="S^C:Change;D:Delete",DIR("B")="Change" D ^DIR S CHOICE=Y S:$D(DTOUT) STOP=1 S:$D(DUOUT) OUT=1 I $D(STOP)!($D(OUT)) Q
.I CHOICE=""!(CHOICE[U) S OUT=1 Q
.S (DIC,DIE)="^QA(748.25,"_DA(1)_",1," X CLEOP
.I CHOICE="A" S DIC(0)="QM",DIC("DR")=".015////"_QAPQN_";.055;.05;.02;",X=+$P(^QA(748.25,DA(1),1,0),U,3)+1 K DO,DD D FILE^DICN S DA=+Y G:DA<0 DIS DO
..I NUM>QAPQN Q
..I NUM<QAPQN S NUM=(QAPQN\1)+INCREM Q
..I NUM=QAPQN S NUM=NUM+INCREM Q
.I CHOICE="C" S DR=".015;.055;.05;.02;" D ^DIE I $D(DTOUT) S STOP=1 Q
.I CHOICE="C",$P(^QA(748.25,DA(1),1,DA,1),U)'="m" D KANS^QAPUTIL2 S DR=".025///@;.027///@;3///@;1///@;2///@" D ^DIE
.I CHOICE="A"!(CHOICE="C"),$P(^QA(748.25,DA(1),1,DA,1),U)="m" S DR=".025;I X'=""l"" S Y=""@1"";D KANS^QAPUTIL2;.027;3;1;2;S Y=""@99"";@1;.027///@;3///@;1///@;2///@;.03;@99" D ^DIE
.I CHOICE="D" DO Q
Q2 ..W !!,*7,"Are you sure you want to remove this question" S %=2 D YN^DICN
..I $D(DTOUT) S STOP=1 Q
..I $D(DUOUT) S QUIT=1 Q
..I $D(%Y),%Y["?" W !!,"Entering Y will delete this question completely.",! G Q2
..I %=1 S DIK="^QA(748.25,"_DA(1)_",1," D ^DIK W !!,">> Question removed << " H 2 Q
..I %'=1 W !!,">> Nothing deleted <<" H 1
X CLEOP K DIR
;
FIN K DIR S DIR(0)="Y",DIR("A")="Are you finished entering questions for this survey"
S DIR("?",1)="Enter Y if you are finished or N if you have more questions"
S DIR("?",2)="to add. If you answer Yes, any further questions will have"
S DIR("?",3)="to be put in via the 'Add/Edit Individual Questions' option"
S DIR("?")="because this option only for new surveys."
W !!,*7 D ^DIR S:$D(DTOUT) STOP=1 G:$D(DIRUT)!($D(STOP)) EXIT
I Y=0 G INCR1
G EN^QAPADD
;
EXIT Q ;kill variables in calling program
;
REORD K DANS S LSTNUM="" F I=0:0 S I=$O(^QA(748.25,"E",SURVEY,I)) Q:I="" F J=0:0 S J=$O(^QA(748.25,"E",SURVEY,I,J)) Q:J="" S DANS(I,J)=I,DANS(I)=I,LSTNUM=I
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPADD1 4568 printed Oct 16, 2024@18:38:44 Page 2
QAPADD1 ;557/THM-CREATE A NEW SURVEY, PART 2 [ 05/19/95 7:22 AM ]
+1 ;;2.0;Survey Generator;;Jun 20, 1995
+2 ;
+3 ;called by QAPADD
LINES WRITE @IOF,!
SET QAPHDR="Survey Name: "_SUBJ
XECUTE QAPBAR
SET QAPHDR="(Adding Questions)"
XECUTE QAPBAR
+1 ;
Q1 SET INCMSG="W !,*7,""The increment must be numeric, non-decimal, between 1 and 10."",! H 2"
+1 KILL DTOUT,DUOUT,SKIP
XECUTE CLEOP
WRITE !,"Do you want help on question entry"
SET %=2
DO YN^DICN
if $DATA(DTOUT)
GOTO EXIT
IF %=1
KILL STOP
DO HELP^QAPUTIL1
IF $DATA(STOP)
GOTO EXIT
+2 IF $DATA(%)
IF %<0
SET SKIP=1
GOTO INCR
+3 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to see the help text or N to skip. "
HANG 2
GOTO Q1
+4 ;
INCR IF '$DATA(SKIP)
SET NUM=1
XECUTE CLEOP
WRITE !,"What increment value do you wish your questions use? 1 // "
READ X:DTIME
if X=""
SET X=1
IF '$TEST
SET STOP=1
GOTO EXIT
+1 IF X["?"
WRITE !!,"Enter the number to skip between questions.",!
XECUTE INCMSG
+2 IF X[U!(X["?")!($DATA(SKIP))
WRITE !!,"If you exit without entering any questions, you will have to use the",!,"'Add/edit Individual Questions' option to add them without benefit",!
+3 IF X[U!(X["?")!($DATA(SKIP))
WRITE "of automatic question numbering.",!!
IF X["?"
WRITE "Press RETURN "
READ ANS:DTIME
IF '$TEST
SET (STOP,QAPOUT)=1
GOTO EXIT
+4 if X["?"
GOTO INCR
+5 IF X[U!($DATA(SKIP))
WRITE "Is this OK"
SET %=2
DO YN^DICN
if $DATA(DTOUT)
SET STOP=1
if %=1!($DATA(DTOUT))!($DATA(STOP))
GOTO EXIT
if %'=1&($DATA(SKIP))
GOTO LINES
if %'=1
GOTO INCR
+6 IF X<1!(X>10)
WRITE !!
XECUTE INCMSG
GOTO INCR
+7 KILL SKIP
IF NUM'=X
SET NUM=X
+8 ;force non-decimal numbers
IF X'?1.2N
IF X'>0
XECUTE INCMSG
GOTO INCR
+9 SET INCREM=X
SET DA(1)=SURVEY
KILL STOP,OUT,X
+10 IF '$DATA(^QA(748.25,DA(1),1,0))
SET ^QA(748.25,DA(1),1,0)="^748.26I^0^0"
+11 ;
INCR1 KILL DTOUT,DUOUT,STOP,OUT
+1 FOR
Begin DoDot:1
+2 ;
DIS WRITE @IOF,!
SET QAPHDR="Survey Name: "_SUBJ
XECUTE QAPBAR
SET QAPHDR="Adding Questions"
XECUTE QAPBAR
+1 DO REORD
+2 XECUTE CLEOP
WRITE BLDON,"Type ^ to exit",BLDOFF
if $DATA(LSTNUM)
WRITE ?45,"Last question number: ",LSTNUM
WRITE !!,">> Question number: ",NUM,"//"
READ QAPQN:DTIME
IF '$TEST
SET STOP=1
QUIT
+3 IF QAPQN="?"
DO HELPLKE^QAPUTIL1
if $DATA(STOP)
QUIT
IF QAPQN=""
GOTO DIS
+4 IF QAPQN[U
SET OUT=1
QUIT
+5 IF QAPQN=""
SET QAPQN=NUM
+6 SET QAPQN=$TRANSLATE(QAPQN,"cr","CR")
+7 IF QAPQN'?1.3N
IF QAPQN'?1.3N1"."1.2N
IF QAPQN'?1"C"
IF QAPQN'?1"R"
IF +QAPQN'=QAPQN
WRITE !!,"Question number entry must be numeric,'R' to resequence",!,"the question numbers, or 'C' to copy a question.",*7
HANG 2
GOTO DIS
+8 IF QAPQN?1"R"
WRITE " Resequence question numbers "
HANG 1
DO R1^QAPRSEQ
SET NUM=LSTNUM+INCREM
GOTO DIS
+9 IF QAPQN?1"C"
DO EN^QAPQCOPY
Begin DoDot:2
+10 IF NUM>QAPQN
QUIT
+11 IF NUM<QAPQN
SET NUM=(QAPQN\1)+INCREM
QUIT
+12 IF NUM=QAPQN
SET NUM=NUM+INCREM
QUIT
End DoDot:2
if $DATA(STOP)
QUIT
GOTO DIS
+13 IF +QAPQN<1!(+QAPQN>999)
WRITE !!,*7,"This number must be between 1 and 999. "
HANG 2
GOTO DIS
+14 SET DA=$ORDER(^QA(748.25,"E",DA(1),QAPQN,0))
IF DA=""
SET CHOICE="A"
+15 IF DA]""
KILL DIR
SET DIR("A")="Select option"
SET DIR(0)="S^C:Change;D:Delete"
SET DIR("B")="Change"
DO ^DIR
SET CHOICE=Y
if $DATA(DTOUT)
SET STOP=1
if $DATA(DUOUT)
SET OUT=1
IF $DATA(STOP)!($DATA(OUT))
QUIT
+16 IF CHOICE=""!(CHOICE[U)
SET OUT=1
QUIT
+17 SET (DIC,DIE)="^QA(748.25,"_DA(1)_",1,"
XECUTE CLEOP
+18 IF CHOICE="A"
SET DIC(0)="QM"
SET DIC("DR")=".015////"_QAPQN_";.055;.05;.02;"
SET X=+$PIECE(^QA(748.25,DA(1),1,0),U,3)+1
KILL DO,DD
DO FILE^DICN
SET DA=+Y
if DA<0
GOTO DIS
Begin DoDot:2
+19 IF NUM>QAPQN
QUIT
+20 IF NUM<QAPQN
SET NUM=(QAPQN\1)+INCREM
QUIT
+21 IF NUM=QAPQN
SET NUM=NUM+INCREM
QUIT
End DoDot:2
+22 IF CHOICE="C"
SET DR=".015;.055;.05;.02;"
DO ^DIE
IF $DATA(DTOUT)
SET STOP=1
QUIT
+23 IF CHOICE="C"
IF $PIECE(^QA(748.25,DA(1),1,DA,1),U)'="m"
DO KANS^QAPUTIL2
SET DR=".025///@;.027///@;3///@;1///@;2///@"
DO ^DIE
+24 IF CHOICE="A"!(CHOICE="C")
IF $PIECE(^QA(748.25,DA(1),1,DA,1),U)="m"
SET DR=".025;I X'=""l"" S Y=""@1"";D KANS^QAPUTIL2;.027;3;1;2;S Y=""@99"";@1;.027///@;3///@;1///@;2///@;.03;@99"
DO ^DIE
+25 IF CHOICE="D"
Begin DoDot:2
Q2 WRITE !!,*7,"Are you sure you want to remove this question"
SET %=2
DO YN^DICN
+1 IF $DATA(DTOUT)
SET STOP=1
QUIT
+2 IF $DATA(DUOUT)
SET QUIT=1
QUIT
+3 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Entering Y will delete this question completely.",!
GOTO Q2
+4 IF %=1
SET DIK="^QA(748.25,"_DA(1)_",1,"
DO ^DIK
WRITE !!,">> Question removed << "
HANG 2
QUIT
+5 IF %'=1
WRITE !!,">> Nothing deleted <<"
HANG 1
End DoDot:2
QUIT
End DoDot:1
if $DATA(DTOUT)!($DATA(STOP))
GOTO EXIT
if $DATA(DUOUT)!($DATA(OUT))
GOTO FIN
if $DATA(STOP)
GOTO EXIT
+6 XECUTE CLEOP
KILL DIR
+7 ;
FIN KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you finished entering questions for this survey"
+1 SET DIR("?",1)="Enter Y if you are finished or N if you have more questions"
+2 SET DIR("?",2)="to add. If you answer Yes, any further questions will have"
+3 SET DIR("?",3)="to be put in via the 'Add/Edit Individual Questions' option"
+4 SET DIR("?")="because this option only for new surveys."
+5 WRITE !!,*7
DO ^DIR
if $DATA(DTOUT)
SET STOP=1
if $DATA(DIRUT)!($DATA(STOP))
GOTO EXIT
+6 IF Y=0
GOTO INCR1
+7 GOTO EN^QAPADD
+8 ;
EXIT ;kill variables in calling program
QUIT
+1 ;
REORD KILL DANS
SET LSTNUM=""
FOR I=0:0
SET I=$ORDER(^QA(748.25,"E",SURVEY,I))
if I=""
QUIT
FOR J=0:0
SET J=$ORDER(^QA(748.25,"E",SURVEY,I,J))
if J=""
QUIT
SET DANS(I,J)=I
SET DANS(I)=I
SET LSTNUM=I
+1 QUIT
