- 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 Jan 18, 2025@03:39:14 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