QAPCHX ;557/THM-INPUT OF ANSWERS [ 06/22/95 8:14 AM ]
;;2.0;Survey Generator;;Jun 20, 1995
;called by OUT3^QAPSCRN
;
USINPT ;multiple choice
K ANS
S ANSTYPE=$P(^QA(748.25,SURVEY,1,QUES,0),U,3),GRADIENT=$P(^(0),U,4)
S INSERT=$S(ANSTYPE="a":"letter",1:"number"),CNTA=0
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)
;Likert scale
I ANSTYPE="l" K QANS,ANS D LIKRTLAB
I ANSTYPE'="l" W !! DO
.S (X,Y,CNTA)=0 F S X=$O(ANS(X)) Q:X="" S CNTA=CNTA+1 ;count answers
.S REM=CNTA#2,CNTA=(CNTA\2)+REM
.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),!
I $D(REM),REM>0 W !
;
A1 D FILE W !! S QLINE=$Y
A1A W ?10,"Enter the ",INSERT," of your response: "
R ANSW:DTIME I '$T!(ANSW[U) S QAPOUT=1 Q
I ANSTYPE="a" S ANSW=$TR(ANSW,"ABCDEFGHIJKLMNOPQRSTUVWXYZ ","abcdefghijklmnopqrstuvwxyz")
I ANSW="" S ANSW=" " X MSSG0 H 1 G A2
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
;file answer
A2 S (DIC,DIE)="^QA(748.3,DA(1),1,",X=QUES,DIC(0)="LM",DIC("DR")="1////"_ANSW K DO,DD D FILE^DICN
K ANS,ANSW,INSERT,DIC,DIE,X,DX,DY,QLINE,QANS,ANSTYPE,GRADIENT,XCOL
Q
;
QAYN ;yes/no/na
D FILE W !! S QLINE=$Y
;
QAYNA W ?5,"Enter Yes, No, or Not applicable (Y/N/NA): " R ANSW:DTIME I '$T!(ANSW[U) S QAPOUT=1 Q
S ANSW=$TR(ANSW,"any ","ANY"),ANSW=$E(ANSW,1,2)
I ANSW="" S ANSW=" " X MSSG0 H 1 G B2
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
;file answer
;
B2 S (DIC,DIE)="^QA(748.3,DA(1),1,",X=QUES,DIC(0)="LM",DIC("DR")="1////"_ANSW K DO,DD D FILE^DICN
K ANSW,DIC,DIE,X
Q
;
QATF ;true/false/na
D FILE W !! S QLINE=$Y
;
QATFA W ?10,"True, False, or Not applicable (T/F/NA): "
R ANSW:DTIME I '$T!(ANSW[U) S QAPOUT=1 Q
S ANSW=$TR(ANSW,"anft ","ANFT"),ANSW=$E(ANSW,1,2)
I ANSW="" S ANSW=" " X MSSG0 H 1 G C2
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
;file answer
C2 S (DIC,DIE)="^QA(748.3,DA(1),1,",X=QUES,DIC(0)="LM",DIC("DR")="1////"_ANSW K DO,DD D FILE^DICN
K ANSW,DIC,DIE,X
Q
;
WP ;wp response
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
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))
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
W !! S QLINE=$Y
WP1 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
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
I ANS[U Q
S ANS=$TR(ANS,"q","Q") I ANS="Q" S QAPOUT=1 Q
I ANS'="",ANS'="^" W *7,!!,"Invalid answer - must be Q, ^, or RETURN" H 3 X CLEOP1 W ! G WP1
I QAPEDTR'["SCREENMAN" W @IOF,!
S (DIC,DIE)="^QA(748.3,DA(1),1,",X=QUES,DIC(0)="LM",DR=2 D ^DIE
K DIC,DIE,X,QAPEDTR
Q
;
FILE 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
S DA(1)=FILEDA
Q
;
LIKRTLAB ;print Likert labels and gradient
S LKDTA=$G(^QA(748.25,SURVEY,1,QUES,0))
S LFTLBL=$P(LKDTA,U,5),RGTLBL=$P(LKDTA,U,6),LDIRECT=$P(LKDTA,U,7) S:LDIRECT="" LDIRECT="a" ;default
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)="""""
S:LFTLBL="" LFTLBL="Poor" S:RGTLBL="" RGTLBL="Excellent" ;default
S X="("_LFTLBL_") " X LDIRECT
S X=X_"("_RGTLBL_")"
W !!,?(IOM-($L(X))\2),X,!!
K LKDTA,LDIRECT,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPCHX 4170 printed Dec 13, 2024@02:38:09 Page 2
QAPCHX ;557/THM-INPUT OF ANSWERS [ 06/22/95 8:14 AM ]
+1 ;;2.0;Survey Generator;;Jun 20, 1995
+2 ;called by OUT3^QAPSCRN
+3 ;
USINPT ;multiple choice
+1 KILL ANS
+2 SET ANSTYPE=$PIECE(^QA(748.25,SURVEY,1,QUES,0),U,3)
SET GRADIENT=$PIECE(^(0),U,4)
+3 SET INSERT=$SELECT(ANSTYPE="a":"letter",1:"number")
SET CNTA=0
+4 IF "^a^n^"[ANSTYPE
FOR QANS=0:0
SET QANS=$ORDER(^QA(748.25,SURVEY,1,QUES,3,QANS))
if QANS=""!(+QANS=0)
QUIT
SET CNTA=CNTA+1
SET ANS($SELECT(ANSTYPE="a":$CHAR(CNTA+96),1:CNTA))=$PIECE(^QA(748.25,SURVEY,1,QUES,3,QANS,0),U)
+5 ;Likert scale
+6 IF ANSTYPE="l"
KILL QANS,ANS
DO LIKRTLAB
+7 IF ANSTYPE'="l"
WRITE !!
Begin DoDot:1
+8 ;count answers
SET (X,Y,CNTA)=0
FOR
SET X=$ORDER(ANS(X))
if X=""
QUIT
SET CNTA=CNTA+1
+9 SET REM=CNTA#2
SET CNTA=(CNTA\2)+REM
+10 FOR XX=1:1:CNTA
SET X=XX
if ANSTYPE="a"
SET X=$CHAR(X+96)
WRITE X,". ",ANS(X)
if ANSTYPE="a"
SET X=$CHAR($ASCII(X)+CNTA)
if ANSTYPE'="a"
SET X=X+CNTA
if $DATA(ANS(X))
WRITE ?40,X,". ",ANS(X),!
End DoDot:1
+11 IF $DATA(REM)
IF REM>0
WRITE !
+12 ;
A1 DO FILE
WRITE !!
SET QLINE=$Y
A1A WRITE ?10,"Enter the ",INSERT," of your response: "
+1 READ ANSW:DTIME
IF '$TEST!(ANSW[U)
SET QAPOUT=1
QUIT
+2 IF ANSTYPE="a"
SET ANSW=$TRANSLATE(ANSW,"ABCDEFGHIJKLMNOPQRSTUVWXYZ ","abcdefghijklmnopqrstuvwxyz")
+3 IF ANSW=""
SET ANSW=" "
XECUTE MSSG0
HANG 1
GOTO A2
+4 IF '$DATA(ANS(ANSW))
WRITE *7,!!,"You must enter a ",$SELECT(ANSTYPE="a":"letter",1:"number")," from the selection given. "
HANG 2
XECUTE CLEOP1
WRITE !
GOTO A1A
+5 ;file answer
A2 SET (DIC,DIE)="^QA(748.3,DA(1),1,"
SET X=QUES
SET DIC(0)="LM"
SET DIC("DR")="1////"_ANSW
KILL DO,DD
DO FILE^DICN
+1 KILL ANS,ANSW,INSERT,DIC,DIE,X,DX,DY,QLINE,QANS,ANSTYPE,GRADIENT,XCOL
+2 QUIT
+3 ;
QAYN ;yes/no/na
+1 DO FILE
WRITE !!
SET QLINE=$Y
+2 ;
QAYNA WRITE ?5,"Enter Yes, No, or Not applicable (Y/N/NA): "
READ ANSW:DTIME
IF '$TEST!(ANSW[U)
SET QAPOUT=1
QUIT
+1 SET ANSW=$TRANSLATE(ANSW,"any ","ANY")
SET ANSW=$EXTRACT(ANSW,1,2)
+2 IF ANSW=""
SET ANSW=" "
XECUTE MSSG0
HANG 1
GOTO B2
+3 IF ANSW'="N"
IF ANSW'="Y"
IF ANSW'="NA"
WRITE *7
WRITE !!,"Enter Y for Yes or N for No or NA for not applicable. "
HANG 2
XECUTE CLEOP1
WRITE !
GOTO QAYNA
+4 ;file answer
+5 ;
B2 SET (DIC,DIE)="^QA(748.3,DA(1),1,"
SET X=QUES
SET DIC(0)="LM"
SET DIC("DR")="1////"_ANSW
KILL DO,DD
DO FILE^DICN
+1 KILL ANSW,DIC,DIE,X
+2 QUIT
+3 ;
QATF ;true/false/na
+1 DO FILE
WRITE !!
SET QLINE=$Y
+2 ;
QATFA WRITE ?10,"True, False, or Not applicable (T/F/NA): "
+1 READ ANSW:DTIME
IF '$TEST!(ANSW[U)
SET QAPOUT=1
QUIT
+2 SET ANSW=$TRANSLATE(ANSW,"anft ","ANFT")
SET ANSW=$EXTRACT(ANSW,1,2)
+3 IF ANSW=""
SET ANSW=" "
XECUTE MSSG0
HANG 1
GOTO C2
+4 IF ANSW'="T"
IF ANSW'="F"
IF ANSW'="NA"
WRITE *7,!!,"Enter T for True, F for False, or NA for not applicable."
HANG 2
XECUTE CLEOP1
WRITE !
GOTO QATFA
+5 ;file answer
C2 SET (DIC,DIE)="^QA(748.3,DA(1),1,"
SET X=QUES
SET DIC(0)="LM"
SET DIC("DR")="1////"_ANSW
KILL DO,DD
DO FILE^DICN
+1 KILL ANSW,DIC,DIE,X
+2 QUIT
+3 ;
WP ;wp response
+1 ;see which wp editor they use
DO FILE
SET QAPEDTR=$PIECE($GET(^VA(200,+DUZ,1)),U,5)
SET QAPEDTR=$SELECT(QAPEDTR=2:"SCREENMAN",1:"LINE EDITOR")
+2 IF $DATA(^QA(748.3,FILEDA,1,"B",QUES))
SET (DIC,DIE)="^QA(748.3,DA(1),1,"
SET DA=$ORDER(^QA(748.3,FILEDA,1,"B",QUES,0))
+3 IF '$DATA(^QA(748.3,FILEDA,1,"B",QUES))
SET (DIC,DIE)="^QA(748.3,DA(1),1,"
SET X=QUES
SET DIC(0)="LM"
KILL DO,DD
DO FILE^DICN
SET DA=+Y
+4 WRITE !!
SET QLINE=$Y
WP1 WRITE "This will be a word processing response.",!!,"Press RETURN to enter a response,",!?6,"^ to skip response entry or Q to QUIT RETURN// "
READ ANS:DTIME
IF '$TEST
SET QAPOUT=1
QUIT
+1 IF ANS["?"
XECUTE CLEOP1
WRITE " ^ 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 "
READ ANS:DTIME
if '$TEST
SET QAPOUT=1
if '$TEST
QUIT
XECUTE CLEOP1
GOTO WP1
+2 IF ANS[U
QUIT
+3 SET ANS=$TRANSLATE(ANS,"q","Q")
IF ANS="Q"
SET QAPOUT=1
QUIT
+4 IF ANS'=""
IF ANS'="^"
WRITE *7,!!,"Invalid answer - must be Q, ^, or RETURN"
HANG 3
XECUTE CLEOP1
WRITE !
GOTO WP1
+5 IF QAPEDTR'["SCREENMAN"
WRITE @IOF,!
+6 SET (DIC,DIE)="^QA(748.3,DA(1),1,"
SET X=QUES
SET DIC(0)="LM"
SET DR=2
DO ^DIE
+7 KILL DIC,DIE,X,QAPEDTR
+8 QUIT
+9 ;
FILE ;question node for FILE^DICN
KILL DA,DIC,DIE,X
SET DA=FILEDA
IF '$DATA(^QA(748.3,DA,1,0))
SET ^QA(748.3,DA,1,0)="^748.31^^"
+1 SET DA(1)=FILEDA
+2 QUIT
+3 ;
LIKRTLAB ;print Likert labels and gradient
+1 SET LKDTA=$GET(^QA(748.25,SURVEY,1,QUES,0))
+2 ;default
SET LFTLBL=$PIECE(LKDTA,U,5)
SET RGTLBL=$PIECE(LKDTA,U,6)
SET LDIRECT=$PIECE(LKDTA,U,7)
if LDIRECT=""
SET LDIRECT="a"
+3 if LDIRECT="a"
SET LDIRECT="F Y=1:1:GRADIENT"
if LDIRECT="d"
SET LDIRECT="F Y=GRADIENT:-1:1"
SET LDIRECT=LDIRECT_" S X=X_Y_"" "",ANS(Y)="""""
+4 ;default
if LFTLBL=""
SET LFTLBL="Poor"
if RGTLBL=""
SET RGTLBL="Excellent"
+5 SET X="("_LFTLBL_") "
XECUTE LDIRECT
+6 SET X=X_"("_RGTLBL_")"
+7 WRITE !!,?(IOM-($LENGTH(X))\2),X,!!
+8 KILL LKDTA,LDIRECT,X,Y
+9 QUIT
