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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPDEM1 4540 printed Apr 09, 2024@21:40:47 Page 2
QAPDEM1 ;557/THM-INPUT OF PARTICIPANT DEMOGRAPHIC DATA [ 08/22/96 9:08 AM ]
+1 ;;2.0;Survey Generator;**6**;Jun 20, 1995
+2 ;called by QAPSCRN1
+3 ;
DEMO SET PRESPON=""
SET QAPHDR=TITLE_" - Demographics Entry"
+1 DO FILE
SET (QAPOUT,RESPCNT)=0
SET DEMERR="Entry of demographic information is mandatory "
+2 FOR DEMQUES=0:0
SET DEMQUES=$ORDER(^QA(748,SURVEY,1,DEMQUES))
if DEMQUES=""!(+DEMQUES=0)!($DATA(DSTOP))!($DATA(STOP))!(QAPOUT=1)!($DATA(FSTOP))
QUIT
Begin DoDot:1
+3 SET DEMDTA=^QA(748,SURVEY,1,DEMQUES,0)
SET DEMTYPE=$PIECE(DEMDTA,U,2)
SET QAPFILE=$PIECE(DEMDTA,U,3)
SET QAPFILE=$PIECE($GET(^QA(748.2,+QAPFILE,0)),U,1)
+4 ;if 'all demographics required' not YES, check each question
+5 IF DMANMSTR="y"
SET DMAN=DMANMSTR
+6 IF DMANMSTR=""!(DMANMSTR="n")
SET DMAN=$PIECE(DEMDTA,U,4)
BEGIN WRITE @IOF,!
XECUTE QAPBAR
KILL RESUME
+1 SET RESPCNT=RESPCNT+1
WRITE !!?5,RESPCNT,". ",$PIECE(DEMDTA,U),!!
SET QLINE=$Y
+2 IF DEMTYPE="p"
IF QAPFILE=""
WRITE !!,*7,"Pointed-to file information is missing for this question!",!!
SET FSTOP=1
HANG 3
QUIT
+3 IF DEMTYPE="s"
IF $ORDER(^QA(748,SURVEY,1,DEMQUES,0))=""
WRITE !!,*7,"Codes are missing for this 'set of codes' question!",!!
SET FSTOP=1
HANG 3
QUIT
+4 IF $DATA(EDIT)
SET RESPONDA=$ORDER(^QA(748.3,FILEDA,2,"B",DEMQUES,0))
+5 IF $DATA(EDIT)
IF RESPONDA]""
SET PRESPON=$PIECE(^QA(748.3,FILEDA,2,RESPONDA,0),U,2)
if DEMTYPE="d"
Begin DoDot:2
+6 SET Y=PRESPON
XECUTE ^DD("DD")
SET PRESPON=Y
End DoDot:2
WRITE "Previous response: ",PRESPON,!
+7 IF $DATA(RESPONDA)
IF RESPONDA=""
SET PRESPON=""
+8 IF DEMTYPE="p"
DO POINTER
+9 IF DEMTYPE="p"
IF $DATA(X)
IF X["?"
if $DATA(DSTOP)
WRITE @IOF,!
if $DATA(DSTOP)
QUIT
SET RESPCNT=RESPCNT-1
GOTO BEGIN
if $DATA(DSTOP)
QUIT
+10 IF DEMTYPE="p"
IF $DATA(Y)
IF +Y<0
IF X'=U
IF X'=""
WRITE " ",*7,"Invalid entry "
HANG 2
SET RESPCNT=RESPCNT-1
GOTO BEGIN
+11 IF DEMTYPE="d"
DO DATE
+12 IF DEMTYPE="f"
DO FREETXT
+13 IF DEMTYPE="s"
DO SETCODE
End DoDot:1
if $DATA(STOP)!(QAPOUT=1)!($DATA(DSTOP))!($DATA(FSTOP))
QUIT
SET PRESPON=""
+14 KILL ANS,ANSW,INSERT,DIC,DIE,X,DX,DY,QLINE,QANS,QAPFILE,DEMTYPE,DEMQUES
+15 QUIT
+16 ;
POINTER ;file error stop
IF QAPFILE=""!('$DATA(^DIC(+QAPFILE)))
WRITE !!,*7,"There is no file associated with the pointer in this answer.",!
HANG 3
SET FSTOP=1
QUIT
+1 ;
POINTER1 ; use DIR reader to enforce 'pointed-to' field limits, transforms.
+1 SET DIR(0)="P^"_QAPFILE_":EQMZ"
SET DIR("A")="Please enter your answer"
+2 if PRESPON]""
SET DIR("B")=PRESPON
+3 KILL DTOUT,DUOUT,DD
DO ^DIR
+4 IF $DATA(DTOUT)
IF $DATA(EDIT)
SET STOP=1
QUIT
+5 IF $DATA(DTOUT)
IF '$DATA(EDIT)
SET DSTOP=1
QUIT
+6 IF $DATA(EDIT)
IF X[U
SET QAPOUT=1
QUIT
+7 IF $DATA(EDIT)
IF X=""
QUIT
+8 IF X=""!(X[U)
IF DMAN'="y"
SET ANSW="<no answer>"
XECUTE MSSG0
HANG 1
DO D2
QUIT
+9 ;QAPOUT=1=^ ; STOP=timeout
IF X=""!(X[U)
IF DMAN="y"
WRITE !!,*7,DEMERR
HANG 2
DO ABORT0^QAPSCRN1
if QAPOUT=1!($DATA(STOP))
QUIT
SET DEMQUES=DEMQUES-.1
SET RESPCNT=RESPCNT-1
QUIT
+10 SET ANSW=$PIECE(Y(0,0),U,1)
DO D2
HANG 1
QUIT
+11 QUIT
+12 ;
DATE IF $DATA(PRESPON)
IF PRESPON]""
IF PRESPON'=" "
SET %DT("B")=PRESPON
+1 KILL DTOUT
+2 SET %DT="AE"
SET %DT("A")="Please enter a date: "
DO ^%DT
SET ANSW=Y
+3 IF $DATA(DTOUT)
IF '$DATA(EDIT)
SET DSTOP=1
QUIT
+4 IF $DATA(X)
IF $DATA(EDIT)
IF X[U
SET QAPOUT=1
QUIT
+5 IF $DATA(X)
IF $DATA(EDIT)
IF X=""
QUIT
+6 IF Y<0
IF DMAN'="y"
SET ANSW="<no answer>"
XECUTE MSSG0
DO D2
QUIT
+7 IF Y<0
IF DMAN="y"
WRITE !!,*7,DEMERR
HANG 2
DO ABORT0^QAPSCRN1
if QAPOUT=1!($DATA(STOP))
QUIT
SET DEMQUES=DEMQUES-.1
SET RESPCNT=RESPCNT-1
QUIT
+8 IF Y>0
SET ANSW=Y
DO D2
QUIT
+9 HANG 1
QUIT
+10 ;
FREETXT if $DATA(EDIT)
SET QLINE=QLINE+2
+1 IF $DATA(PRESPON)
IF PRESPON]""
IF PRESPON'=" "
SET DIR("B")=PRESPON
+2 XECUTE CLEOP1
+3 SET DIR("?")="Enter a free text response from 1 to 40 characters"
+4 SET DIR("A")="Enter your response"
SET DIR(0)="F^1:40"
DO ^DIR
SET ANSW=X
KILL DIR
+5 IF $DATA(DTOUT)
IF '$DATA(EDIT)
SET DSTOP=1
QUIT
+6 IF ANSW[U
IF $DATA(EDIT)
SET QAPOUT=1
QUIT
+7 IF ANSW=""
IF $DATA(EDIT)
QUIT
+8 SET ANSW=$TRANSLATE(ANSW,"_{}|\~`","")
+9 IF ANSW[U!(ANSW="")
IF DMAN'="y"
SET ANSW="<no answer>"
XECUTE MSSG0
HANG 1
DO D2
QUIT
+10 IF ANSW[U!(ANSW="")
IF DMAN="y"
WRITE !!,*7,DEMERR
HANG 2
DO ABORT0^QAPSCRN1
if QAPOUT=1!($DATA(STOP))
QUIT
SET DEMQUES=DEMQUES-.1
SET RESPCNT=RESPCNT-1
QUIT
+11 IF ANSW]""
DO D2
QUIT
+12 QUIT
+13 ;
SETCODE KILL DIR
SET DIR(0)="S^"
+1 IF $DATA(PRESPON)
IF PRESPON]""
SET DIR("B")=PRESPON
+2 FOR DAX=0:0
SET DAX=$ORDER(^QA(748,SURVEY,1,DEMQUES,1,DAX))
if DAX=""!(+DAX=0)
QUIT
SET QDTA=^QA(748,SURVEY,1,DEMQUES,1,DAX,0)
SET QCODE=$PIECE(QDTA,U,1)
SET DIR(0)=DIR(0)_QCODE_":"_$PIECE(QDTA,U,2)_";"
+3 KILL QDTA,QCODE
DO ^DIR
IF $DATA(DTOUT)
IF '$DATA(EDIT)
SET DSTOP=1
QUIT
+4 IF $DATA(DUOUT)
IF $DATA(EDIT)
SET QAPOUT=1
QUIT
+5 IF X=""
IF $DATA(EDIT)
SET QAPOUT=1
QUIT
+6 IF $DATA(DUOUT)!(X="")
IF DMAN'="y"
SET QAPOUT=1
XECUTE MSSG0
QUIT
+7 IF $DATA(DUOUT)!(X="")
IF DMAN="y"
WRITE !!,*7,DEMERR
HANG 2
DO ABORT0^QAPSCRN1
if $DATA(STOP)
QUIT
SET DEMQUES=DEMQUES-.1
SET RESPCNT=RESPCNT-1
QUIT
+8 SET ANSW=Y(0)
SET DA=Y
HANG 1
+9 ;
D2 SET (DIC,DIE)="^QA(748.3,DA(1),2,"
SET X=DEMQUES
SET DIC(0)="LM"
+1 IF '$DATA(EDIT)
SET DIC("DR")="1////^S X=ANSW"
KILL DO,DD
DO FILE^DICN
QUIT
+2 IF $DATA(EDIT)
IF RESPONDA=""
SET DIC("DR")="1////^S X=ANSW"
KILL DO,DD
DO FILE^DICN
QUIT
+3 IF $DATA(EDIT)
IF RESPONDA]""
SET DA=RESPONDA
SET DR="1////^S X=ANSW"
DO ^DIE
+4 QUIT
+5 ;
FILE ;node for FILE^DICN
KILL DA,DIC,DIE,X,DO,DD
SET DA=FILEDA
IF '$DATA(^QA(748.3,DA,2,0))
SET ^QA(748.3,DA,2,0)="^748.36A^^"
+1 SET DA(1)=FILEDA
+2 QUIT
