88 lines
4.3 KiB
Mathematica
88 lines
4.3 KiB
Mathematica
QAPDEM1 ;557/THM-INPUT OF PARTICIPANT DEMOGRAPHIC DATA [ 08/22/96 9:08 AM ]
|
|
;;2.0;Survey Generator;**6**;Jun 20, 1995
|
|
;called by QAPSCRN1
|
|
;
|
|
DEMO S PRESPON="",QAPHDR=TITLE_" - Demographics Entry"
|
|
D FILE S (QAPOUT,RESPCNT)=0,DEMERR="Entry of demographic information is mandatory "
|
|
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=""
|
|
.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)
|
|
.;if 'all demographics required' not YES, check each question
|
|
.I DMANMSTR="y" S DMAN=DMANMSTR
|
|
.I DMANMSTR=""!(DMANMSTR="n") S DMAN=$P(DEMDTA,U,4)
|
|
BEGIN .W @IOF,! X QAPBAR K RESUME
|
|
.S RESPCNT=RESPCNT+1 W !!?5,RESPCNT,". ",$P(DEMDTA,U),!! S QLINE=$Y
|
|
.I DEMTYPE="p",QAPFILE="" W !!,*7,"Pointed-to file information is missing for this question!",!! S FSTOP=1 H 3 Q
|
|
.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
|
|
.I $D(EDIT) S RESPONDA=$O(^QA(748.3,FILEDA,2,"B",DEMQUES,0))
|
|
.I $D(EDIT),RESPONDA]"" S PRESPON=$P(^QA(748.3,FILEDA,2,RESPONDA,0),U,2) D:DEMTYPE="d" W "Previous response: ",PRESPON,!
|
|
..S Y=PRESPON X ^DD("DD") S PRESPON=Y
|
|
.I $D(RESPONDA),RESPONDA="" S PRESPON=""
|
|
.I DEMTYPE="p" D POINTER
|
|
.I DEMTYPE="p",$D(X),X["?" W:$D(DSTOP) @IOF,! Q:$D(DSTOP) S RESPCNT=RESPCNT-1 G BEGIN Q:$D(DSTOP)
|
|
.I DEMTYPE="p",$D(Y),+Y<0,X'=U,X'="" W " ",*7,"Invalid entry " H 2 S RESPCNT=RESPCNT-1 G BEGIN
|
|
.I DEMTYPE="d" D DATE
|
|
.I DEMTYPE="f" D FREETXT
|
|
.I DEMTYPE="s" D SETCODE
|
|
K ANS,ANSW,INSERT,DIC,DIE,X,DX,DY,QLINE,QANS,QAPFILE,DEMTYPE,DEMQUES
|
|
Q
|
|
;
|
|
POINTER 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
|
|
;
|
|
POINTER1 ; use DIR reader to enforce 'pointed-to' field limits, transforms.
|
|
S DIR(0)="P^"_QAPFILE_":EQMZ",DIR("A")="Please enter your answer"
|
|
S:PRESPON]"" DIR("B")=PRESPON
|
|
K DTOUT,DUOUT,DD D ^DIR
|
|
I $D(DTOUT),$D(EDIT) S STOP=1 Q
|
|
I $D(DTOUT),'$D(EDIT) S DSTOP=1 Q
|
|
I $D(EDIT),X[U S QAPOUT=1 Q
|
|
I $D(EDIT),X="" Q
|
|
I X=""!(X[U),DMAN'="y" S ANSW="<no answer>" X MSSG0 H 1 D D2 Q
|
|
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
|
|
S ANSW=$P(Y(0,0),U,1) D D2 H 1 Q
|
|
Q
|
|
;
|
|
DATE I $D(PRESPON) I PRESPON]"",PRESPON'=" " S %DT("B")=PRESPON
|
|
K DTOUT
|
|
S %DT="AE",%DT("A")="Please enter a date: " D ^%DT S ANSW=Y
|
|
I $D(DTOUT),'$D(EDIT) S DSTOP=1 Q
|
|
I $D(X),$D(EDIT),X[U S QAPOUT=1 Q
|
|
I $D(X),$D(EDIT),X="" Q
|
|
I Y<0,DMAN'="y" S ANSW="<no answer>" X MSSG0 D D2 Q
|
|
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
|
|
I Y>0 S ANSW=Y D D2 Q
|
|
H 1 Q
|
|
;
|
|
FREETXT S:$D(EDIT) QLINE=QLINE+2
|
|
I $D(PRESPON) I PRESPON]"",PRESPON'=" " S DIR("B")=PRESPON
|
|
X CLEOP1
|
|
S DIR("?")="Enter a free text response from 1 to 40 characters"
|
|
S DIR("A")="Enter your response",DIR(0)="F^1:40" D ^DIR S ANSW=X K DIR
|
|
I $D(DTOUT),'$D(EDIT) S DSTOP=1 Q
|
|
I ANSW[U,$D(EDIT) S QAPOUT=1 Q
|
|
I ANSW="",$D(EDIT) Q
|
|
S ANSW=$TR(ANSW,"_{}|\~`","")
|
|
I ANSW[U!(ANSW=""),DMAN'="y" S ANSW="<no answer>" X MSSG0 H 1 D D2 Q
|
|
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
|
|
I ANSW]"" D D2 Q
|
|
Q
|
|
;
|
|
SETCODE K DIR S DIR(0)="S^"
|
|
I $D(PRESPON) I PRESPON]"" S DIR("B")=PRESPON
|
|
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)_";"
|
|
K QDTA,QCODE D ^DIR I $D(DTOUT),'$D(EDIT) S DSTOP=1 Q
|
|
I $D(DUOUT),$D(EDIT) S QAPOUT=1 Q
|
|
I X="",$D(EDIT) S QAPOUT=1 Q
|
|
I $D(DUOUT)!(X=""),DMAN'="y" S QAPOUT=1 X MSSG0 Q
|
|
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
|
|
S ANSW=Y(0),DA=Y H 1
|
|
;
|
|
D2 S (DIC,DIE)="^QA(748.3,DA(1),2,",X=DEMQUES,DIC(0)="LM"
|
|
I '$D(EDIT) S DIC("DR")="1////^S X=ANSW" K DO,DD D FILE^DICN Q
|
|
I $D(EDIT),RESPONDA="" S DIC("DR")="1////^S X=ANSW" K DO,DD D FILE^DICN Q
|
|
I $D(EDIT),RESPONDA]"" S DA=RESPONDA,DR="1////^S X=ANSW" D ^DIE
|
|
Q
|
|
;
|
|
FILE 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
|
|
S DA(1)=FILEDA
|
|
Q
|