source: WorldVistAEHR/trunk/r/SURVEY_GENERATOR-QAP/QAPPT1.m@ 1739

Last change on this file since 1739 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1QAPPT1 ;557/THM-PRINT DRAFT/FINAL COPY, PART 2 [ 08/23/96 8:48 AM ]
2 ;;2.0;Survey Generator;**4,6**;Jun 20, 1995
3 ;
4PRINT U IO S (QAPOUT,PG)=0,BANNER=" * DRAFT COPY * "
5 I IOST?1"P-".E!(IOST?1"PK-".E) S TOF="I $Y>(IOSL-10) W !!,""Continued on next page"",! D HDR^QAPPT1"
6 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"
7 S MSGSKP="Question skipped",$P(LINE,"-",IOM)="",QAPDATE=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
8 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?
9 G:$D(OUT) EXIT D DEMLST^QAPUTIL2 G:QAPOUT=1 EXIT
10 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
11 .S QAPX=$P(^QA(748.25,SURVEY,1,QNUM,1),U)
12 .I ACTION="D" X TOF Q:QAPOUT=1 W:QAPX="w" " [Word Processing]"
13 .;print header
14 .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
15 .I $O(^QA(748.25,SURVEY,1,QNUM,4,0))]"" W !!
16 .;print question
17 .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
18 ..D USINPT:QAPX="m",QATF:QAPX="t",QAYN:QAPX="y",WP:QAPX="w" Q:'$T!(QAPOUT=1)
19 Q:$D(USERPRT)
20 I '$D(OUT),QAPOUT=0,IOST?1"C-".E W !!,"Press RETURN to end " R ANS:DTIME
21 G EXIT
22 ;
23EXIT D ^%ZISC Q:$D(USERPRT)
24 Q:$D(CREATE) G EXIT^QAPUTIL
25 ;
26USINPT K ANS S ANSTYPE=$P(^QA(748.25,SURVEY,1,QNUM,0),U,3),GRADIENT=$P(^(0),U,4)
27 S INSERT=$S(ANSTYPE="a":"letter",1:"number"),CNTA=0
28 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)
29 I ANSTYPE="l" N QUES S QUES=QNUM D LIKRTLAB^QAPCHX X TOF Q:QAPOUT=1 K ANS,QANS
30 I ANSTYPE'="l" W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
31 I ANSTYPE'="l" DO
32 .S (X,Y,CNTA)=0 F S X=$O(ANS(X)) Q:X="" S CNTA=CNTA+1 ;count answers
33 .S REM=CNTA#2,CNTA=(CNTA\2)+REM
34 .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),!
35 I $D(REM),REM>0 W ! X TOF Q:QAPOUT=1
36 W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
37 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
38 Q
39 ;
40QAYN W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
41 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)
42 W ?15,"Yes",?28,"No",?40,"Not applicable",! X TOF Q:QAPOUT=1 W ! X TOF W ! X TOF Q:QAPOUT=1
43 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
44 K ANSW,DIC,DIE,X
45 Q
46 ;
47QATF W ! X TOF W ! X TOF Q:QAPOUT=1
48 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)
49 W ?15,"True",?30,"False",?43,"NA",! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
50 I $D(USERPRT) W ?5,"Response: ",PRESPON,! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
51 Q
52 ;
53WP W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
54 I $D(USERPRT) S QUES=$O(^QA(748.3,FILEDA,1,"B",QNUM,0)) Q:QUES=""
55 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
56 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
57 W ! X TOF Q:QAPOUT=1 W ! X TOF Q:QAPOUT=1
58 Q
59 ;
60HDR 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",!
61 W !,LINE,!
62 Q
63 ;
64USERPRT ;from QAPEDI1
65 S TITLE=$P(^QA(748,SURVEY,0),U,6),ACTION="F",STATUS=$P(^QA(748.3,FILEDA,0),U,3)
66 I '$D(USERPRT),(STATUS'="c") Q ;not individual & not complete
67 ;Q:STATUS'="c" ;no in-progress or suspended surveys
68 D PRINT I IOST?1"C-".E I QAPOUT=0 W !!,"Press Return " R ANS:DTIME I '$T S QAPOUT=1
69 Q
Note: See TracBrowser for help on using the repository browser.