QAPSCRN ;557/THM-USER INPUT FOR SURVEYS [ 07/07/95 9:27 AM ]
;;2.0;Survey Generator;;Jun 20, 1995
;
D SCREEN^QAPUTIL S X="TRAP^QAPUTIL2",@^%ZOSF("TRAP")
EN S QAPOUT=0,MSSG=">> Question skipped <<",MSSG0="W *7,!!,?(IOM-$L(MSSG)\2),MSSG"
W @IOF,! S QAPHDR="Survey Data Entry" X QAPBAR
;DIC("S") screens out all but "ready for use" statuses
K DIC S DIC="^QA(748,",DIC(0)="AEQMZ",DIC("A")="Select a survey: ",DIC("S")="I $P(^(0),U,4)=""r""" D ^DIC K DIC G:X=""!(X[U) QUIT^QAPSCRN1
;change status automatically when expired
S LASTDATE=$P(Y(0),U,3) I LASTDATE]"",DT>LASTDATE W *7,!!,"This survey is no longer active.",!! S:$P(Y(0),U,4)'="d" $P(^QA(748,+Y,0),U,4)="e" H 2 G EN
;
CONT S SURVEY=+Y,QAPNAME=$P(Y(0),U),TITLE=$P(Y(0),U,6),X="`"_DUZ D HASH^XUSHSHP S USER=X
S DMANMSTR=$P(Y(0),U,8) ;are ALL demographics required?
S (SVST,LQUES)="" K IFN,QUIT
;find any suspended response
F DA=0:0 S DA=$O(^QA(748.3,"AC",USER,SURVEY,DA)) Q:DA=""!($D(QUIT)) I $P(^QA(748.3,DA,0),U,3)="s" S IFN=DA S QUIT=1 Q
;if no suspended response, see if one completed
K DA,QUIT I '$D(IFN) S IFN=$O(^QA(748.3,"AC",USER,SURVEY,0))
I IFN]"" S X=$G(^QA(748.3,IFN,0)),SVST=$P(X,U,3),LQUES=$P(X,U,4),LORD=+$P(X,U,5) I +LQUES=0 S LQUES="<no questions answered>"
S CNT=0,PASSX=$P(Y(0),U,9) ;for multi-participation
S PASSX=$TR(PASSX,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
W @IOF,! X QAPBAR S QAPHDR="Survey: "_TITLE X QAPBAR W !! S QLINE=$Y X CLEOP1
I SVST="c",PASSX="" W !!,*7,"You may not participate more than once in this survey.",!!,"Press RETURN " R ANS:DTIME G EXIT^QAPUTIL
I SVST="c",PASSX]"" W !!,*7,"You have already taken and completed this survey.",!,"You may participate again only if you know the correct password.",!!
I PASSX=""!(SVST'="c") G PASSN
S QLINE=$Y-1
PASSM X ^%ZOSF("EOFF")
W BLDON,"Enter ^ to exit",BLDOFF W !!
W "Enter MULTI-PARTICIPATION PASSWORD: " R X:DTIME G:'$T!(X[U) QUIT^QAPSCRN1
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I X'=PASSX W *7,!!,"Incorrect password " H 2 S CNT=CNT+1 X CLEOP1
I X=PASSX G STR1
I CNT>2 W !!,*7,"You don't know the password !",! X ^%ZOSF("EON") H 2 G QUIT^QAPSCRN1
I PASSX]"",X'=PASSX G PASSM
;
PASSN I SVST="s" W !!,"This is a restart of a previous session.",!,"The last question answered was # ",LQUES,".",!!,"Press RETURN " R ANS:DTIME G:'$T!(ANS[U) QUIT^QAPSCRN1
I SVST="s" S:LORD=99999 LORD=0 S (DISP,CQUES)=LORD,QAPCNT=+LQUES G HELPINS
I SVST="i" W !!,"You appear to be already working on this survey at another terminal.",!! H 3 G QUIT^QAPSCRN1
S CNT=0,PASSX=$P(Y(0),U,7)
;
PASSR I PASSX="" G STR1
S PASSX=$P(Y(0),U,7) X ^%ZOSF("EOFF") X CLEOP W !,"Enter SURVEY PASSWORD: " R X:DTIME G:'$T!(X[U) QUIT^QAPSCRN1
S PASSX=$TR(PASSX,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I X'=PASSX W *7,!!,"Incorrect password " H 2 S CNT=CNT+1
I X=PASSX G STR1
I CNT>2 W !!,*7,"You do not know the password !",! X ^%ZOSF("EON") H 2 G QUIT^QAPSCRN1
I PASSX]"",X'=PASSX G PASSR
;
STR1 K NEWREC X ^%ZOSF("EON") S (DIC,DIE)="^QA(748.3,",DLAYGO=748.3,DIC(0)="LM",X=SURVEY,DIC("DR")="2///^S X=""`""_DUZ" K DO,DD D FILE^DICN S FILEDA=+Y K DIC,DO,X,Y,DLAYGO,DA S NEWREC=1 ;must use /// to force encryption of DUZ via input xform
S (DISP,QUES)=""
;
HELPINS G:+LQUES>0 EN1^QAPSCRN1 S QLINE=4 X CLEOP1 W !!,"Do you want to see instructions" S %=1 D YN^DICN I %=1 X CLEOP D INSTRUCT^QAPUTIL W !!,"Press RETURN " R ANS:DTIME K ANS I '$T S DSTOP=1 G KILL^QAPSCRN1
I $D(DTOUT) S DSTOP=1 K EDIT G KILL^QAPSCRN1
I $D(%Y),%Y["?" W !!,"Enter Y to see instructions or N to skip them. " H 3 X CLEOP1 W ! G HELPINS
I %<1,$D(NEWREC) D ABORT^QAPSCRN1 G:$D(STOP) QUIT^QAPSCRN1
I %<1,'$D(NEWREC) G QUIT^QAPSCRN1
;
G EN1^QAPSCRN1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPSCRN 3870 printed Apr 09, 2024@21:40:34 Page 2
QAPSCRN ;557/THM-USER INPUT FOR SURVEYS [ 07/07/95 9:27 AM ]
+1 ;;2.0;Survey Generator;;Jun 20, 1995
+2 ;
+3 DO SCREEN^QAPUTIL
SET X="TRAP^QAPUTIL2"
SET @^%ZOSF("TRAP")
EN SET QAPOUT=0
SET MSSG=">> Question skipped <<"
SET MSSG0="W *7,!!,?(IOM-$L(MSSG)\2),MSSG"
+1 WRITE @IOF,!
SET QAPHDR="Survey Data Entry"
XECUTE QAPBAR
+2 ;DIC("S") screens out all but "ready for use" statuses
+3 KILL DIC
SET DIC="^QA(748,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select a survey: "
SET DIC("S")="I $P(^(0),U,4)=""r"""
DO ^DIC
KILL DIC
if X=""!(X[U)
GOTO QUIT^QAPSCRN1
+4 ;change status automatically when expired
+5 SET LASTDATE=$PIECE(Y(0),U,3)
IF LASTDATE]""
IF DT>LASTDATE
WRITE *7,!!,"This survey is no longer active.",!!
if $PIECE(Y(0),U,4)'="d"
SET $PIECE(^QA(748,+Y,0),U,4)="e"
HANG 2
GOTO EN
+6 ;
CONT SET SURVEY=+Y
SET QAPNAME=$PIECE(Y(0),U)
SET TITLE=$PIECE(Y(0),U,6)
SET X="`"_DUZ
DO HASH^XUSHSHP
SET USER=X
+1 ;are ALL demographics required?
SET DMANMSTR=$PIECE(Y(0),U,8)
+2 SET (SVST,LQUES)=""
KILL IFN,QUIT
+3 ;find any suspended response
+4 FOR DA=0:0
SET DA=$ORDER(^QA(748.3,"AC",USER,SURVEY,DA))
if DA=""!($DATA(QUIT))
QUIT
IF $PIECE(^QA(748.3,DA,0),U,3)="s"
SET IFN=DA
SET QUIT=1
QUIT
+5 ;if no suspended response, see if one completed
+6 KILL DA,QUIT
IF '$DATA(IFN)
SET IFN=$ORDER(^QA(748.3,"AC",USER,SURVEY,0))
+7 IF IFN]""
SET X=$GET(^QA(748.3,IFN,0))
SET SVST=$PIECE(X,U,3)
SET LQUES=$PIECE(X,U,4)
SET LORD=+$PIECE(X,U,5)
IF +LQUES=0
SET LQUES="<no questions answered>"
+8 ;for multi-participation
SET CNT=0
SET PASSX=$PIECE(Y(0),U,9)
+9 SET PASSX=$TRANSLATE(PASSX,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+10 WRITE @IOF,!
XECUTE QAPBAR
SET QAPHDR="Survey: "_TITLE
XECUTE QAPBAR
WRITE !!
SET QLINE=$Y
XECUTE CLEOP1
+11 IF SVST="c"
IF PASSX=""
WRITE !!,*7,"You may not participate more than once in this survey.",!!,"Press RETURN "
READ ANS:DTIME
GOTO EXIT^QAPUTIL
+12 IF SVST="c"
IF PASSX]""
WRITE !!,*7,"You have already taken and completed this survey.",!,"You may participate again only if you know the correct password.",!!
+13 IF PASSX=""!(SVST'="c")
GOTO PASSN
+14 SET QLINE=$Y-1
PASSM XECUTE ^%ZOSF("EOFF")
+1 WRITE BLDON,"Enter ^ to exit",BLDOFF
WRITE !!
+2 WRITE "Enter MULTI-PARTICIPATION PASSWORD: "
READ X:DTIME
if '$TEST!(X[U)
GOTO QUIT^QAPSCRN1
+3 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+4 IF X'=PASSX
WRITE *7,!!,"Incorrect password "
HANG 2
SET CNT=CNT+1
XECUTE CLEOP1
+5 IF X=PASSX
GOTO STR1
+6 IF CNT>2
WRITE !!,*7,"You don't know the password !",!
XECUTE ^%ZOSF("EON")
HANG 2
GOTO QUIT^QAPSCRN1
+7 IF PASSX]""
IF X'=PASSX
GOTO PASSM
+8 ;
PASSN IF SVST="s"
WRITE !!,"This is a restart of a previous session.",!,"The last question answered was # ",LQUES,".",!!,"Press RETURN "
READ ANS:DTIME
if '$TEST!(ANS[U)
GOTO QUIT^QAPSCRN1
+1 IF SVST="s"
if LORD=99999
SET LORD=0
SET (DISP,CQUES)=LORD
SET QAPCNT=+LQUES
GOTO HELPINS
+2 IF SVST="i"
WRITE !!,"You appear to be already working on this survey at another terminal.",!!
HANG 3
GOTO QUIT^QAPSCRN1
+3 SET CNT=0
SET PASSX=$PIECE(Y(0),U,7)
+4 ;
PASSR IF PASSX=""
GOTO STR1
+1 SET PASSX=$PIECE(Y(0),U,7)
XECUTE ^%ZOSF("EOFF")
XECUTE CLEOP
WRITE !,"Enter SURVEY PASSWORD: "
READ X:DTIME
if '$TEST!(X[U)
GOTO QUIT^QAPSCRN1
+2 SET PASSX=$TRANSLATE(PASSX,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+4 IF X'=PASSX
WRITE *7,!!,"Incorrect password "
HANG 2
SET CNT=CNT+1
+5 IF X=PASSX
GOTO STR1
+6 IF CNT>2
WRITE !!,*7,"You do not know the password !",!
XECUTE ^%ZOSF("EON")
HANG 2
GOTO QUIT^QAPSCRN1
+7 IF PASSX]""
IF X'=PASSX
GOTO PASSR
+8 ;
STR1 ;must use /// to force encryption of DUZ via input xform
KILL NEWREC
XECUTE ^%ZOSF("EON")
SET (DIC,DIE)="^QA(748.3,"
SET DLAYGO=748.3
SET DIC(0)="LM"
SET X=SURVEY
SET DIC("DR")="2///^S X=""`""_DUZ"
KILL DO,DD
DO FILE^DICN
SET FILEDA=+Y
KILL DIC,DO,X,Y,DLAYGO,DA
SET NEWREC=1
+1 SET (DISP,QUES)=""
+2 ;
HELPINS if +LQUES>0
GOTO EN1^QAPSCRN1
SET QLINE=4
XECUTE CLEOP1
WRITE !!,"Do you want to see instructions"
SET %=1
DO YN^DICN
IF %=1
XECUTE CLEOP
DO INSTRUCT^QAPUTIL
WRITE !!,"Press RETURN "
READ ANS:DTIME
KILL ANS
IF '$TEST
SET DSTOP=1
GOTO KILL^QAPSCRN1
+1 IF $DATA(DTOUT)
SET DSTOP=1
KILL EDIT
GOTO KILL^QAPSCRN1
+2 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to see instructions or N to skip them. "
HANG 3
XECUTE CLEOP1
WRITE !
GOTO HELPINS
+3 IF %<1
IF $DATA(NEWREC)
DO ABORT^QAPSCRN1
if $DATA(STOP)
GOTO QUIT^QAPSCRN1
+4 IF %<1
IF '$DATA(NEWREC)
GOTO QUIT^QAPSCRN1
+5 ;
+6 GOTO EN1^QAPSCRN1
