source: WorldVistAEHR/trunk/r/SURVEY_GENERATOR-QAP/QAPDEM1.m@ 1639

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

initial load of WorldVistAEHR
File size: 4.3 KB
RevLine 
[613]1QAPDEM1 ;557/THM-INPUT OF PARTICIPANT DEMOGRAPHIC DATA [ 08/22/96 9:08 AM ]
2 ;;2.0;Survey Generator;**6**;Jun 20, 1995
3 ;called by QAPSCRN1
4 ;
5DEMO S PRESPON="",QAPHDR=TITLE_" - Demographics Entry"
6 D FILE S (QAPOUT,RESPCNT)=0,DEMERR="Entry of demographic information is mandatory "
7 F DEMQUES=0:0 S DEMQUES=$O(^QA(748,SURVEY,1,DEMQUES)) Q:DEMQUES=""!(+DEMQUES=0)!($D(DSTOP))!($D(STOP))!(QAPOUT=1)!($D(FSTOP)) DO Q:$D(STOP)!(QAPOUT=1)!($D(DSTOP))!($D(FSTOP)) S PRESPON=""
8 .S DEMDTA=^QA(748,SURVEY,1,DEMQUES,0),DEMTYPE=$P(DEMDTA,U,2),QAPFILE=$P(DEMDTA,U,3),QAPFILE=$P($G(^QA(748.2,+QAPFILE,0)),U,1)
9 .;if 'all demographics required' not YES, check each question
10 .I DMANMSTR="y" S DMAN=DMANMSTR
11 .I DMANMSTR=""!(DMANMSTR="n") S DMAN=$P(DEMDTA,U,4)
12BEGIN .W @IOF,! X QAPBAR K RESUME
13 .S RESPCNT=RESPCNT+1 W !!?5,RESPCNT,". ",$P(DEMDTA,U),!! S QLINE=$Y
14 .I DEMTYPE="p",QAPFILE="" W !!,*7,"Pointed-to file information is missing for this question!",!! S FSTOP=1 H 3 Q
15 .I DEMTYPE="s",$O(^QA(748,SURVEY,1,DEMQUES,0))="" W !!,*7,"Codes are missing for this 'set of codes' question!",!! S FSTOP=1 H 3 Q
16 .I $D(EDIT) S RESPONDA=$O(^QA(748.3,FILEDA,2,"B",DEMQUES,0))
17 .I $D(EDIT),RESPONDA]"" S PRESPON=$P(^QA(748.3,FILEDA,2,RESPONDA,0),U,2) D:DEMTYPE="d" W "Previous response: ",PRESPON,!
18 ..S Y=PRESPON X ^DD("DD") S PRESPON=Y
19 .I $D(RESPONDA),RESPONDA="" S PRESPON=""
20 .I DEMTYPE="p" D POINTER
21 .I DEMTYPE="p",$D(X),X["?" W:$D(DSTOP) @IOF,! Q:$D(DSTOP) S RESPCNT=RESPCNT-1 G BEGIN Q:$D(DSTOP)
22 .I DEMTYPE="p",$D(Y),+Y<0,X'=U,X'="" W " ",*7,"Invalid entry " H 2 S RESPCNT=RESPCNT-1 G BEGIN
23 .I DEMTYPE="d" D DATE
24 .I DEMTYPE="f" D FREETXT
25 .I DEMTYPE="s" D SETCODE
26 K ANS,ANSW,INSERT,DIC,DIE,X,DX,DY,QLINE,QANS,QAPFILE,DEMTYPE,DEMQUES
27 Q
28 ;
29POINTER I QAPFILE=""!('$D(^DIC(+QAPFILE))) W !!,*7,"There is no file associated with the pointer in this answer.",! H 3 S FSTOP=1 Q ;file error stop
30 ;
31POINTER1 ; use DIR reader to enforce 'pointed-to' field limits, transforms.
32 S DIR(0)="P^"_QAPFILE_":EQMZ",DIR("A")="Please enter your answer"
33 S:PRESPON]"" DIR("B")=PRESPON
34 K DTOUT,DUOUT,DD D ^DIR
35 I $D(DTOUT),$D(EDIT) S STOP=1 Q
36 I $D(DTOUT),'$D(EDIT) S DSTOP=1 Q
37 I $D(EDIT),X[U S QAPOUT=1 Q
38 I $D(EDIT),X="" Q
39 I X=""!(X[U),DMAN'="y" S ANSW="<no answer>" X MSSG0 H 1 D D2 Q
40 I X=""!(X[U),DMAN="y" W !!,*7,DEMERR H 2 D ABORT0^QAPSCRN1 Q:QAPOUT=1!($D(STOP)) S DEMQUES=DEMQUES-.1,RESPCNT=RESPCNT-1 Q ;QAPOUT=1=^ ; STOP=timeout
41 S ANSW=$P(Y(0,0),U,1) D D2 H 1 Q
42 Q
43 ;
44DATE I $D(PRESPON) I PRESPON]"",PRESPON'=" " S %DT("B")=PRESPON
45 K DTOUT
46 S %DT="AE",%DT("A")="Please enter a date: " D ^%DT S ANSW=Y
47 I $D(DTOUT),'$D(EDIT) S DSTOP=1 Q
48 I $D(X),$D(EDIT),X[U S QAPOUT=1 Q
49 I $D(X),$D(EDIT),X="" Q
50 I Y<0,DMAN'="y" S ANSW="<no answer>" X MSSG0 D D2 Q
51 I Y<0,DMAN="y" W !!,*7,DEMERR H 2 D ABORT0^QAPSCRN1 Q:QAPOUT=1!($D(STOP)) S DEMQUES=DEMQUES-.1,RESPCNT=RESPCNT-1 Q
52 I Y>0 S ANSW=Y D D2 Q
53 H 1 Q
54 ;
55FREETXT S:$D(EDIT) QLINE=QLINE+2
56 I $D(PRESPON) I PRESPON]"",PRESPON'=" " S DIR("B")=PRESPON
57 X CLEOP1
58 S DIR("?")="Enter a free text response from 1 to 40 characters"
59 S DIR("A")="Enter your response",DIR(0)="F^1:40" D ^DIR S ANSW=X K DIR
60 I $D(DTOUT),'$D(EDIT) S DSTOP=1 Q
61 I ANSW[U,$D(EDIT) S QAPOUT=1 Q
62 I ANSW="",$D(EDIT) Q
63 S ANSW=$TR(ANSW,"_{}|\~`","")
64 I ANSW[U!(ANSW=""),DMAN'="y" S ANSW="<no answer>" X MSSG0 H 1 D D2 Q
65 I ANSW[U!(ANSW=""),DMAN="y" W !!,*7,DEMERR H 2 D ABORT0^QAPSCRN1 Q:QAPOUT=1!($D(STOP)) S DEMQUES=DEMQUES-.1,RESPCNT=RESPCNT-1 Q
66 I ANSW]"" D D2 Q
67 Q
68 ;
69SETCODE K DIR S DIR(0)="S^"
70 I $D(PRESPON) I PRESPON]"" S DIR("B")=PRESPON
71 F DAX=0:0 S DAX=$O(^QA(748,SURVEY,1,DEMQUES,1,DAX)) Q:DAX=""!(+DAX=0) S QDTA=^QA(748,SURVEY,1,DEMQUES,1,DAX,0),QCODE=$P(QDTA,U,1),DIR(0)=DIR(0)_QCODE_":"_$P(QDTA,U,2)_";"
72 K QDTA,QCODE D ^DIR I $D(DTOUT),'$D(EDIT) S DSTOP=1 Q
73 I $D(DUOUT),$D(EDIT) S QAPOUT=1 Q
74 I X="",$D(EDIT) S QAPOUT=1 Q
75 I $D(DUOUT)!(X=""),DMAN'="y" S QAPOUT=1 X MSSG0 Q
76 I $D(DUOUT)!(X=""),DMAN="y" W !!,*7,DEMERR H 2 D ABORT0^QAPSCRN1 Q:$D(STOP) S DEMQUES=DEMQUES-.1,RESPCNT=RESPCNT-1 Q
77 S ANSW=Y(0),DA=Y H 1
78 ;
79D2 S (DIC,DIE)="^QA(748.3,DA(1),2,",X=DEMQUES,DIC(0)="LM"
80 I '$D(EDIT) S DIC("DR")="1////^S X=ANSW" K DO,DD D FILE^DICN Q
81 I $D(EDIT),RESPONDA="" S DIC("DR")="1////^S X=ANSW" K DO,DD D FILE^DICN Q
82 I $D(EDIT),RESPONDA]"" S DA=RESPONDA,DR="1////^S X=ANSW" D ^DIE
83 Q
84 ;
85FILE K DA,DIC,DIE,X,DO,DD S DA=FILEDA I '$D(^QA(748.3,DA,2,0)) S ^QA(748.3,DA,2,0)="^748.36A^^" ;node for FILE^DICN
86 S DA(1)=FILEDA
87 Q
Note: See TracBrowser for help on using the repository browser.