source: WorldVistAEHR/trunk/r/SURVEY_GENERATOR-QAP/QAPADD1.m@ 770

Last change on this file since 770 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.4 KB
RevLine 
[613]1QAPADD1 ;557/THM-CREATE A NEW SURVEY, PART 2 [ 05/19/95 7:22 AM ]
2 ;;2.0;Survey Generator;;Jun 20, 1995
3 ;
4 ;called by QAPADD
5LINES W @IOF,! S QAPHDR="Survey Name: "_SUBJ X QAPBAR S QAPHDR="(Adding Questions)" X QAPBAR
6 ;
7Q1 S INCMSG="W !,*7,""The increment must be numeric, non-decimal, between 1 and 10."",! H 2"
8 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
9 I $D(%),%<0 S SKIP=1 G INCR
10 I $D(%Y),%Y["?" W !!,"Enter Y to see the help text or N to skip. " H 2 G Q1
11 ;
12INCR 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
13 I X["?" W !!,"Enter the number to skip between questions.",! X INCMSG
14 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",!
15 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
16 G:X["?" INCR
17 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
18 I X<1!(X>10) W !! X INCMSG G INCR
19 K SKIP I NUM'=X S NUM=X
20 I X'?1.2N,X'>0 X INCMSG G INCR ;force non-decimal numbers
21 S INCREM=X,DA(1)=SURVEY K STOP,OUT,X
22 I '$D(^QA(748.25,DA(1),1,0)) S ^QA(748.25,DA(1),1,0)="^748.26I^0^0"
23 ;
24INCR1 K DTOUT,DUOUT,STOP,OUT
25 F DO G:$D(DTOUT)!($D(STOP)) EXIT G:$D(DUOUT)!($D(OUT)) FIN G:$D(STOP) EXIT
26 .;
27DIS .W @IOF,! S QAPHDR="Survey Name: "_SUBJ X QAPBAR S QAPHDR="Adding Questions" X QAPBAR
28 .D REORD
29 .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
30 .I QAPQN="?" D HELPLKE^QAPUTIL1 Q:$D(STOP) I QAPQN="" G DIS
31 .I QAPQN[U S OUT=1 Q
32 .I QAPQN="" S QAPQN=NUM
33 .S QAPQN=$TR(QAPQN,"cr","CR")
34 .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
35 .I QAPQN?1"R" W " Resequence question numbers " H 1 D R1^QAPRSEQ S NUM=LSTNUM+INCREM G DIS
36 .I QAPQN?1"C" D EN^QAPQCOPY DO Q:$D(STOP) G DIS
37 ..I NUM>QAPQN Q
38 ..I NUM<QAPQN S NUM=(QAPQN\1)+INCREM Q
39 ..I NUM=QAPQN S NUM=NUM+INCREM Q
40 .I +QAPQN<1!(+QAPQN>999) W !!,*7,"This number must be between 1 and 999. " H 2 G DIS
41 .S DA=$O(^QA(748.25,"E",DA(1),QAPQN,0)) I DA="" S CHOICE="A"
42 .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
43 .I CHOICE=""!(CHOICE[U) S OUT=1 Q
44 .S (DIC,DIE)="^QA(748.25,"_DA(1)_",1," X CLEOP
45 .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
46 ..I NUM>QAPQN Q
47 ..I NUM<QAPQN S NUM=(QAPQN\1)+INCREM Q
48 ..I NUM=QAPQN S NUM=NUM+INCREM Q
49 .I CHOICE="C" S DR=".015;.055;.05;.02;" D ^DIE I $D(DTOUT) S STOP=1 Q
50 .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
51 .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
52 .I CHOICE="D" DO Q
53Q2 ..W !!,*7,"Are you sure you want to remove this question" S %=2 D YN^DICN
54 ..I $D(DTOUT) S STOP=1 Q
55 ..I $D(DUOUT) S QUIT=1 Q
56 ..I $D(%Y),%Y["?" W !!,"Entering Y will delete this question completely.",! G Q2
57 ..I %=1 S DIK="^QA(748.25,"_DA(1)_",1," D ^DIK W !!,">> Question removed << " H 2 Q
58 ..I %'=1 W !!,">> Nothing deleted <<" H 1
59 X CLEOP K DIR
60 ;
61FIN K DIR S DIR(0)="Y",DIR("A")="Are you finished entering questions for this survey"
62 S DIR("?",1)="Enter Y if you are finished or N if you have more questions"
63 S DIR("?",2)="to add. If you answer Yes, any further questions will have"
64 S DIR("?",3)="to be put in via the 'Add/Edit Individual Questions' option"
65 S DIR("?")="because this option only for new surveys."
66 W !!,*7 D ^DIR S:$D(DTOUT) STOP=1 G:$D(DIRUT)!($D(STOP)) EXIT
67 I Y=0 G INCR1
68 G EN^QAPADD
69 ;
70EXIT Q ;kill variables in calling program
71 ;
72REORD 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
73 Q
Note: See TracBrowser for help on using the repository browser.