QAPPT1 ;557/THM-PRINT DRAFT/FINAL COPY, PART 2 [ 08/23/96 8:48 AM ]
;;2.0;Survey Generator;**4,6**;Jun 20, 1995
;
PRINT U IO S (QAPOUT,PG)=0,BANNER=" * DRAFT COPY * "
I IOST?1"P-".E!(IOST?1"PK-".E) S TOF="I $Y>(IOSL-10) W !!,""Continued on next page"",! D HDR^QAPPT1"
I IOST?1"C-".E S TOF="I $Y>(IOSL-6) W !!,""Press RETURN to continue or '^' to exit "" R ANS:DTIME S:'$T!(ANS[U) QAPOUT=1 Q:QAPOUT=1 I QAPOUT'=1 D HDR^QAPPT1"
S MSGSKP="Question skipped",$P(LINE,"-",IOM)="",QAPDATE=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
S SITE=$P($$SITE^VASITE,U),SITE=$P($G(^DIC(4,+SITE,0)),U,1),SITE=$S(+SITE>10000:"",1:"V A Medical Center ")_SITE S:ACTION="D" SITE=BANNER_SITE_BANNER D HDR,INSTRUCT^QAPUTIL ;is a VA hosp or other?
G:$D(OUT) EXIT D DEMLST^QAPUTIL2 G:QAPOUT=1 EXIT
F QAPQN=0:0 S QAPQN=$O(^QA(748.25,"E",SURVEY,QAPQN)) Q:QAPQN=""!(QAPOUT=1) F QNUM=0:0 S QNUM=$O(^QA(748.25,"E",SURVEY,QAPQN,QNUM)) Q:QNUM="" DO
.S QAPX=$P(^QA(748.25,SURVEY,1,QNUM,1),U)
.I ACTION="D" X TOF Q:QAPOUT=1 W:QAPX="w" " [Word Processing]"
.;print header
.I $O(^QA(748.25,SURVEY,1,QNUM,4,0))]"" W ! X TOF Q:QAPOUT=1 F I=0:0 S I=$O(^QA(748.25,SURVEY,1,QNUM,4,I)) D:I=""!(+I=0) Q:I=""!(+I=0)!(QAPOUT=1) S X=$P(^QA(748.25,SURVEY,1,QNUM,4,I,0),U,1) W X,! X TOF Q:QAPOUT=1
.I $O(^QA(748.25,SURVEY,1,QNUM,4,0))]"" W !!
.;print question
.W ! X TOF Q:QAPOUT=1 W QAPQN,". " F I=0:0 S I=$O(^QA(748.25,SURVEY,1,QNUM,2,I)) D:I=""!(+I=0) Q:I=""!(+I=0)!(QAPOUT=1) S X=$P(^QA(748.25,SURVEY,1,QNUM,2,I,0),U,1) W X,! X TOF Q:QAPOUT=1
..D USINPT:QAPX="m",QATF:QAPX="t",QAYN:QAPX="y",WP:QAPX="w" Q:'$T!(QAPOUT=1)
Q:$D(USERPRT)
I '$D(OUT),QAPOUT=0,IOST?1"C-".E W !!,"Press RETURN to end " R ANS:DTIME
G EXIT
;
EXIT D ^%ZISC Q:$D(USERPRT)
Q:$D(CREATE) G EXIT^QAPUTIL
;
USINPT K ANS S ANSTYPE=$P(^QA(748.25,SURVEY,1,QNUM,0),U,3),GRADIENT=$P(^(0),U,4)
S INSERT=$S(ANSTYPE="a":"letter",1:"number"),CNTA=0
F QANS=0:0 S QANS=$O(^QA(748.25,SURVEY,1,QNUM,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,QNUM,3,QANS,0),U)
I ANSTYPE="l" N QUES S QUES=QNUM D LIKRTLAB^QAPCHX X TOF Q:QAPOUT=1 K ANS,QANS
I ANSTYPE'="l" W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
I ANSTYPE'="l" 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 ?2,X,". ",ANS(X) S:ANSTYPE="a" X=$C($A(X)+CNTA) S:ANSTYPE'="a" X=X+CNTA W:$D(ANS(X)) ?42,X,". ",ANS(X),!
I $D(REM),REM>0 W ! X TOF Q:QAPOUT=1
W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
I $D(USERPRT) S QUES=$O(^QA(748.3,FILEDA,1,"B",QNUM,0)) Q:QUES="" S PRESPON=$P(^QA(748.3,FILEDA,1,QUES,0),U,2) S:PRESPON=" " PRESPON=MSGSKP W ?5,"Response: ",PRESPON,! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
Q
;
QAYN W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
I $D(USERPRT) S QUES=$O(^QA(748.3,FILEDA,1,"B",QNUM,0)) Q:QUES="" S PRESPON=$P(^QA(748.3,FILEDA,1,QUES,0),U,2)
W ?15,"Yes",?28,"No",?40,"Not applicable",! X TOF Q:QAPOUT=1 W ! X TOF W ! X TOF Q:QAPOUT=1
I $D(USERPRT) S PRESPON=$S(PRESPON="Y":"Yes",PRESPON="N":"No",PRESPON="NA":"Not applicable",1:MSGSKP) W ?5,"Response: ",PRESPON,! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
K ANSW,DIC,DIE,X
Q
;
QATF W ! X TOF W ! X TOF Q:QAPOUT=1
I $D(USERPRT) S QUES=$O(^QA(748.3,FILEDA,1,"B",QNUM,0)) Q:QUES="" S PRESPON=$P(^QA(748.3,FILEDA,1,QUES,0),U,2),PRESPON=$S(PRESPON="T":"True",PRESPON="F":"False",1:MSGSKP)
W ?15,"True",?30,"False",?43,"NA",! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
I $D(USERPRT) W ?5,"Response: ",PRESPON,! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
Q
;
WP W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
I $D(USERPRT) S QUES=$O(^QA(748.3,FILEDA,1,"B",QNUM,0)) Q:QUES=""
I $D(USERPRT) F QZ=0:0 S QZ=$O(^QA(748.3,FILEDA,1,QUES,1,QZ)) Q:QZ="" S QY=^QA(748.3,FILEDA,1,QUES,1,QZ,0) W ?3,QY,! X TOF Q:QAPOUT=1
F QZ=0:0 S QZ=$O(^QA(748.25,SURVEY,1,QNUM,1,QZ)) Q:QZ="" S QY=^QA(748.3,FILEDA,1,QUES,1,QZ,0) W ?3,QY,! X TOF Q:QAPOUT=1
W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
Q
;
HDR S PG=PG+1 W:PG>1!(IOST?1"C-".E) @IOF W !,QAPDATE,?(IOM-$L(TITLE)\2),TITLE,?(IOM-12),"Page: ",PG,!,?(IOM-$L(SITE)\2),SITE,! W:$D(USERPRT) ?33,"User Response",!
W !,LINE,!
Q
;
USERPRT ;from QAPEDI1
S TITLE=$P(^QA(748,SURVEY,0),U,6),ACTION="F",STATUS=$P(^QA(748.3,FILEDA,0),U,3)
I '$D(USERPRT),(STATUS'="c") Q ;not individual & not complete
;Q:STATUS'="c" ;no in-progress or suspended surveys
D PRINT I IOST?1"C-".E I QAPOUT=0 W !!,"Press Return " R ANS:DTIME I '$T S QAPOUT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPPT1 4615 printed Apr 09, 2024@21:40:43 Page 2
QAPPT1 ;557/THM-PRINT DRAFT/FINAL COPY, PART 2 [ 08/23/96 8:48 AM ]
+1 ;;2.0;Survey Generator;**4,6**;Jun 20, 1995
+2 ;
PRINT USE IO
SET (QAPOUT,PG)=0
SET BANNER=" * DRAFT COPY * "
+1 IF IOST?1"P-".E!(IOST?1"PK-".E)
SET TOF="I $Y>(IOSL-10) W !!,""Continued on next page"",! D HDR^QAPPT1"
+2 IF IOST?1"C-".E
SET TOF="I $Y>(IOSL-6) W !!,""Press RETURN to continue or '^' to exit "" R ANS:DTIME S:'$T!(ANS[U) QAPOUT=1 Q:QAPOUT=1 I QAPOUT'=1 D HDR^QAPPT1"
+3 SET MSGSKP="Question skipped"
SET $PIECE(LINE,"-",IOM)=""
SET QAPDATE=$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+4 ;is a VA hosp or other?
SET SITE=$PIECE($$SITE^VASITE,U)
SET SITE=$PIECE($GET(^DIC(4,+SITE,0)),U,1)
SET SITE=$SELECT(+SITE>10000:"",1:"V A Medical Center ")_SITE
if ACTION="D"
SET SITE=BANNER_SITE_BANNER
DO HDR
DO INSTRUCT^QAPUTIL
+5 if $DATA(OUT)
GOTO EXIT
DO DEMLST^QAPUTIL2
if QAPOUT=1
GOTO EXIT
+6 FOR QAPQN=0:0
SET QAPQN=$ORDER(^QA(748.25,"E",SURVEY,QAPQN))
if QAPQN=""!(QAPOUT=1)
QUIT
FOR QNUM=0:0
SET QNUM=$ORDER(^QA(748.25,"E",SURVEY,QAPQN,QNUM))
if QNUM=""
QUIT
Begin DoDot:1
+7 SET QAPX=$PIECE(^QA(748.25,SURVEY,1,QNUM,1),U)
+8 IF ACTION="D"
XECUTE TOF
if QAPOUT=1
QUIT
if QAPX="w"
WRITE " [Word Processing]"
+9 ;print header
+10 IF $ORDER(^QA(748.25,SURVEY,1,QNUM,4,0))]""
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
FOR I=0:0
SET I=$ORDER(^QA(748.25,SURVEY,1,QNUM,4,I))
if I=""!(+I=0)
Begin DoDot:2
End DoDot:2
if I=""!(+I=0)!(QAPOUT=1)
QUIT
SET X=$PIECE(^QA(748.25,SURVEY,1,QNUM,4,I,0),U,1)
WRITE X,!
XECUTE TOF
if QAPOUT=1
QUIT
+11 IF $ORDER(^QA(748.25,SURVEY,1,QNUM,4,0))]""
WRITE !!
+12 ;print question
+13 WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
WRITE QAPQN,". "
FOR I=0:0
SET I=$ORDER(^QA(748.25,SURVEY,1,QNUM,2,I))
if I=""!(+I=0)
Begin DoDot:2
+14 if QAPX="m"
DO USINPT
if QAPX="t"
DO QATF
if QAPX="y"
DO QAYN
if QAPX="w"
DO WP
if '$TEST!(QAPOUT=1)
QUIT
End DoDot:2
if I=""!(+I=0)!(QAPOUT=1)
QUIT
SET X=$PIECE(^QA(748.25,SURVEY,1,QNUM,2,I,0),U,1)
WRITE X,!
XECUTE TOF
if QAPOUT=1
QUIT
End DoDot:1
+15 if $DATA(USERPRT)
QUIT
+16 IF '$DATA(OUT)
IF QAPOUT=0
IF IOST?1"C-".E
WRITE !!,"Press RETURN to end "
READ ANS:DTIME
+17 GOTO EXIT
+18 ;
EXIT DO ^%ZISC
if $DATA(USERPRT)
QUIT
+1 if $DATA(CREATE)
QUIT
GOTO EXIT^QAPUTIL
+2 ;
USINPT KILL ANS
SET ANSTYPE=$PIECE(^QA(748.25,SURVEY,1,QNUM,0),U,3)
SET GRADIENT=$PIECE(^(0),U,4)
+1 SET INSERT=$SELECT(ANSTYPE="a":"letter",1:"number")
SET CNTA=0
+2 FOR QANS=0:0
SET QANS=$ORDER(^QA(748.25,SURVEY,1,QNUM,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,QNUM,3,QANS,0),U)
+3 IF ANSTYPE="l"
NEW QUES
SET QUES=QNUM
DO LIKRTLAB^QAPCHX
XECUTE TOF
if QAPOUT=1
QUIT
KILL ANS,QANS
+4 IF ANSTYPE'="l"
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+5 IF ANSTYPE'="l"
Begin DoDot:1
+6 ;count answers
SET (X,Y,CNTA)=0
FOR
SET X=$ORDER(ANS(X))
if X=""
QUIT
SET CNTA=CNTA+1
+7 SET REM=CNTA#2
SET CNTA=(CNTA\2)+REM
+8 FOR XX=1:1:CNTA
SET X=XX
if ANSTYPE="a"
SET X=$CHAR(X+96)
WRITE ?2,X,". ",ANS(X)
if ANSTYPE="a"
SET X=$CHAR($ASCII(X)+CNTA)
if ANSTYPE'="a"
SET X=X+CNTA
if $DATA(ANS(X))
WRITE ?42,X,". ",ANS(X),!
End DoDot:1
+9 IF $DATA(REM)
IF REM>0
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+10 WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+11 IF $DATA(USERPRT)
SET QUES=$ORDER(^QA(748.3,FILEDA,1,"B",QNUM,0))
if QUES=""
QUIT
SET PRESPON=$PIECE(^QA(748.3,FILEDA,1,QUES,0),U,2)
if PRESPON=" "
SET PRESPON=MSGSKP
WRITE ?5,"Response: ",PRESPON,!
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+12 QUIT
+13 ;
QAYN WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+1 IF $DATA(USERPRT)
SET QUES=$ORDER(^QA(748.3,FILEDA,1,"B",QNUM,0))
if QUES=""
QUIT
SET PRESPON=$PIECE(^QA(748.3,FILEDA,1,QUES,0),U,2)
+2 WRITE ?15,"Yes",?28,"No",?40,"Not applicable",!
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+3 IF $DATA(USERPRT)
SET PRESPON=$SELECT(PRESPON="Y":"Yes",PRESPON="N":"No",PRESPON="NA":"Not applicable",1:MSGSKP)
WRITE ?5,"Response: ",PRESPON,!
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+4 KILL ANSW,DIC,DIE,X
+5 QUIT
+6 ;
QATF WRITE !
XECUTE TOF
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+1 IF $DATA(USERPRT)
SET QUES=$ORDER(^QA(748.3,FILEDA,1,"B",QNUM,0))
if QUES=""
QUIT
SET PRESPON=$PIECE(^QA(748.3,FILEDA,1,QUES,0),U,2)
SET PRESPON=$SELECT(PRESPON="T":"True",PRESPON="F":"False",1:MSGSKP)
+2 WRITE ?15,"True",?30,"False",?43,"NA",!
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+3 IF $DATA(USERPRT)
WRITE ?5,"Response: ",PRESPON,!
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+4 QUIT
+5 ;
WP WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+1 IF $DATA(USERPRT)
SET QUES=$ORDER(^QA(748.3,FILEDA,1,"B",QNUM,0))
if QUES=""
QUIT
+2 IF $DATA(USERPRT)
FOR QZ=0:0
SET QZ=$ORDER(^QA(748.3,FILEDA,1,QUES,1,QZ))
if QZ=""
QUIT
SET QY=^QA(748.3,FILEDA,1,QUES,1,QZ,0)
WRITE ?3,QY,!
XECUTE TOF
if QAPOUT=1
QUIT
+3 FOR QZ=0:0
SET QZ=$ORDER(^QA(748.25,SURVEY,1,QNUM,1,QZ))
if QZ=""
QUIT
SET QY=^QA(748.3,FILEDA,1,QUES,1,QZ,0)
WRITE ?3,QY,!
XECUTE TOF
if QAPOUT=1
QUIT
+4 WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
WRITE !
XECUTE TOF
if QAPOUT=1
QUIT
+5 QUIT
+6 ;
HDR SET PG=PG+1
if PG>1!(IOST?1"C-".E)
WRITE @IOF
WRITE !,QAPDATE,?(IOM-$LENGTH(TITLE)\2),TITLE,?(IOM-12),"Page: ",PG,!,?(IOM-$LENGTH(SITE)\2),SITE,!
if $DATA(USERPRT)
WRITE ?33,"User Response",!
+1 WRITE !,LINE,!
+2 QUIT
+3 ;
USERPRT ;from QAPEDI1
+1 SET TITLE=$PIECE(^QA(748,SURVEY,0),U,6)
SET ACTION="F"
SET STATUS=$PIECE(^QA(748.3,FILEDA,0),U,3)
+2 ;not individual & not complete
IF '$DATA(USERPRT)
IF (STATUS'="c")
QUIT
+3 ;Q:STATUS'="c" ;no in-progress or suspended surveys
+4 DO PRINT
IF IOST?1"C-".E
IF QAPOUT=0
WRITE !!,"Press Return "
READ ANS:DTIME
IF '$TEST
SET QAPOUT=1
+5 QUIT
