- 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 Feb 19, 2025@00:04:55 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