- 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 Jan 18, 2025@03:39:16 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