source: FOIAVistA/trunk/r/SURVEY_GENERATOR-QAP/QAPCHX.m@ 1764

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

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1QAPCHX ;557/THM-INPUT OF ANSWERS [ 06/22/95 8:14 AM ]
2 ;;2.0;Survey Generator;;Jun 20, 1995
3 ;called by OUT3^QAPSCRN
4 ;
5USINPT ;multiple choice
6 K ANS
7 S ANSTYPE=$P(^QA(748.25,SURVEY,1,QUES,0),U,3),GRADIENT=$P(^(0),U,4)
8 S INSERT=$S(ANSTYPE="a":"letter",1:"number"),CNTA=0
9 I "^a^n^"[ANSTYPE F QANS=0:0 S QANS=$O(^QA(748.25,SURVEY,1,QUES,3,QANS)) Q:QANS=""!(+QANS=0) S CNTA=CNTA+1,ANS($S(ANSTYPE="a":$C(CNTA+96),1:CNTA))=$P(^QA(748.25,SURVEY,1,QUES,3,QANS,0),U)
10 ;Likert scale
11 I ANSTYPE="l" K QANS,ANS D LIKRTLAB
12 I ANSTYPE'="l" W !! DO
13 .S (X,Y,CNTA)=0 F S X=$O(ANS(X)) Q:X="" S CNTA=CNTA+1 ;count answers
14 .S REM=CNTA#2,CNTA=(CNTA\2)+REM
15 .F XX=1:1:CNTA S X=XX S:ANSTYPE="a" X=$C(X+96) W X,". ",ANS(X) S:ANSTYPE="a" X=$C($A(X)+CNTA) S:ANSTYPE'="a" X=X+CNTA W:$D(ANS(X)) ?40,X,". ",ANS(X),!
16 I $D(REM),REM>0 W !
17 ;
18A1 D FILE W !! S QLINE=$Y
19A1A W ?10,"Enter the ",INSERT," of your response: "
20 R ANSW:DTIME I '$T!(ANSW[U) S QAPOUT=1 Q
21 I ANSTYPE="a" S ANSW=$TR(ANSW,"ABCDEFGHIJKLMNOPQRSTUVWXYZ ","abcdefghijklmnopqrstuvwxyz")
22 I ANSW="" S ANSW=" " X MSSG0 H 1 G A2
23 I '$D(ANS(ANSW)) W *7,!!,"You must enter a ",$S(ANSTYPE="a":"letter",1:"number")," from the selection given. " H 2 X CLEOP1 W ! G A1A
24 ;file answer
25A2 S (DIC,DIE)="^QA(748.3,DA(1),1,",X=QUES,DIC(0)="LM",DIC("DR")="1////"_ANSW K DO,DD D FILE^DICN
26 K ANS,ANSW,INSERT,DIC,DIE,X,DX,DY,QLINE,QANS,ANSTYPE,GRADIENT,XCOL
27 Q
28 ;
29QAYN ;yes/no/na
30 D FILE W !! S QLINE=$Y
31 ;
32QAYNA W ?5,"Enter Yes, No, or Not applicable (Y/N/NA): " R ANSW:DTIME I '$T!(ANSW[U) S QAPOUT=1 Q
33 S ANSW=$TR(ANSW,"any ","ANY"),ANSW=$E(ANSW,1,2)
34 I ANSW="" S ANSW=" " X MSSG0 H 1 G B2
35 I ANSW'="N",ANSW'="Y",ANSW'="NA" W *7 W !!,"Enter Y for Yes or N for No or NA for not applicable. " H 2 X CLEOP1 W ! G QAYNA
36 ;file answer
37 ;
38B2 S (DIC,DIE)="^QA(748.3,DA(1),1,",X=QUES,DIC(0)="LM",DIC("DR")="1////"_ANSW K DO,DD D FILE^DICN
39 K ANSW,DIC,DIE,X
40 Q
41 ;
42QATF ;true/false/na
43 D FILE W !! S QLINE=$Y
44 ;
45QATFA W ?10,"True, False, or Not applicable (T/F/NA): "
46 R ANSW:DTIME I '$T!(ANSW[U) S QAPOUT=1 Q
47 S ANSW=$TR(ANSW,"anft ","ANFT"),ANSW=$E(ANSW,1,2)
48 I ANSW="" S ANSW=" " X MSSG0 H 1 G C2
49 I ANSW'="T",ANSW'="F",ANSW'="NA" W *7,!!,"Enter T for True, F for False, or NA for not applicable." H 2 X CLEOP1 W ! G QATFA
50 ;file answer
51C2 S (DIC,DIE)="^QA(748.3,DA(1),1,",X=QUES,DIC(0)="LM",DIC("DR")="1////"_ANSW K DO,DD D FILE^DICN
52 K ANSW,DIC,DIE,X
53 Q
54 ;
55WP ;wp response
56 D FILE S QAPEDTR=$P($G(^VA(200,+DUZ,1)),U,5),QAPEDTR=$S(QAPEDTR=2:"SCREENMAN",1:"LINE EDITOR") ;see which wp editor they use
57 I $D(^QA(748.3,FILEDA,1,"B",QUES)) S (DIC,DIE)="^QA(748.3,DA(1),1,",DA=$O(^QA(748.3,FILEDA,1,"B",QUES,0))
58 I '$D(^QA(748.3,FILEDA,1,"B",QUES)) S (DIC,DIE)="^QA(748.3,DA(1),1,",X=QUES,DIC(0)="LM" K DO,DD D FILE^DICN S DA=+Y
59 W !! S QLINE=$Y
60WP1 W "This will be a word processing response.",!!,"Press RETURN to enter a response,",!?6,"^ to skip response entry or Q to QUIT RETURN// " R ANS:DTIME I '$T S QAPOUT=1 Q
61 I ANS["?" X CLEOP1 W " ^ will skip entering any response to this question",!," RETURN will allow you to enter a response",!," Q will allow you to abort or suspend",!!,"Press RETURN " R ANS:DTIME S:'$T QAPOUT=1 Q:'$T X CLEOP1 G WP1
62 I ANS[U Q
63 S ANS=$TR(ANS,"q","Q") I ANS="Q" S QAPOUT=1 Q
64 I ANS'="",ANS'="^" W *7,!!,"Invalid answer - must be Q, ^, or RETURN" H 3 X CLEOP1 W ! G WP1
65 I QAPEDTR'["SCREENMAN" W @IOF,!
66 S (DIC,DIE)="^QA(748.3,DA(1),1,",X=QUES,DIC(0)="LM",DR=2 D ^DIE
67 K DIC,DIE,X,QAPEDTR
68 Q
69 ;
70FILE K DA,DIC,DIE,X S DA=FILEDA I '$D(^QA(748.3,DA,1,0)) S ^QA(748.3,DA,1,0)="^748.31^^" ;question node for FILE^DICN
71 S DA(1)=FILEDA
72 Q
73 ;
74LIKRTLAB ;print Likert labels and gradient
75 S LKDTA=$G(^QA(748.25,SURVEY,1,QUES,0))
76 S LFTLBL=$P(LKDTA,U,5),RGTLBL=$P(LKDTA,U,6),LDIRECT=$P(LKDTA,U,7) S:LDIRECT="" LDIRECT="a" ;default
77 S:LDIRECT="a" LDIRECT="F Y=1:1:GRADIENT" S:LDIRECT="d" LDIRECT="F Y=GRADIENT:-1:1" S LDIRECT=LDIRECT_" S X=X_Y_"" "",ANS(Y)="""""
78 S:LFTLBL="" LFTLBL="Poor" S:RGTLBL="" RGTLBL="Excellent" ;default
79 S X="("_LFTLBL_") " X LDIRECT
80 S X=X_"("_RGTLBL_")"
81 W !!,?(IOM-($L(X))\2),X,!!
82 K LKDTA,LDIRECT,X,Y
83 Q
Note: See TracBrowser for help on using the repository browser.