- QAPSTAT1 ;557/THM-SURVEY GENERATOR STATISTICS, PART 2 [ 08/28/95 2:16 PM ]
- ;;2.0;Survey Generator;;Jun 20, 1995
- Q ;enter properly
- ;
- PRINT K ^TMP($J),TOTPART,TOTANS
- U IO S (QAPOUT,PG,TOTPART,TOTANS)=0
- S BANNER="S T A T I S T I C S"
- S QAPDATE=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),$P(LINE,"-",IOM)="",QAPDATE=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
- I IOST?1"P-".E!(IOST?1"PK-".E) S TOF="I $Y>(IOSL-8) W !!,""Continued on next page"",! D HDR Q:$D(DIRUT)"
- I IOST?1"C-".E S TOF="I $Y>(IOSL-4) D PAUSE Q:$D(DIRUT) D HDR"
- 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 ;is a VA hosp or other?
- F PART=0:0 S PART=$O(^QA(748.3,"B",SURVEY,PART)) Q:PART="" I $P(^QA(748.3,PART,0),U,3)="c" DO S TOTPART=TOTPART+1,LPART=PART,^TMP($J,"QAPZ",PART)="" ;only completed responses
- .F QNUM=0:0 S QNUM=$O(^QA(748.3,PART,1,QNUM)) Q:QNUM=""!(+QNUM=0) S ANS=$P(^QA(748.3,PART,1,QNUM,0),U,2) DO
- ..I ANS="",$O(^QA(748.3,PART,1,QNUM,0))="" Q ;aborted WP response
- ..I ANS="",$O(^QA(748.3,PART,1,QNUM,0))]"" S ^TMP($J,QNUM,"WP")="WP"_U_QNUM Q
- ..I ANS]"" S:'$D(^TMP($J,QNUM,ANS)) ^TMP($J,QNUM,ANS)="0^" S $P(^TMP($J,QNUM,ANS),U,1)=$P(^TMP($J,QNUM,ANS),U,1)+1,PQUES=$P(^QA(748.3,PART,1,QNUM,0),U) ;PQUES is the question pointer
- ..K ^XTMP($J) S (ANSX,CNTR)=0 F S ANSX=$O(^QA(748.25,SURVEY,1,PQUES,3,ANSX)) Q:ANSX=""!(+ANSX=0) S CNTR=CNTR+1,^XTMP($J,SURVEY,1,PQUES,3,CNTR,0)=^QA(748.25,SURVEY,1,PQUES,3,ANSX,0) ;put in answer order to compare
- ..I +ANS>0 S $P(^TMP($J,QNUM,ANS),U,2)=$S($P($G(^XTMP($J,SURVEY,1,PQUES,3,ANS,0)),U)]"":$P(^(0),U),1:ANS)
- ..I +ANS=0 S $P(^TMP($J,QNUM,ANS),U,2)=$S($P($G(^XTMP($J,SURVEY,1,PQUES,3,($A(ANS)-96),0)),U)]"":$P(^(0),U),1:ANS)
- ;LPART is the ifn of the last participant examined. It is kept
- ;as a link to file 748.3
- I TOTPART=0 D HDR W !!!?20,"No one has yet participated in this survey.",! D:IOST?1"C-".E PAUSE G EXIT
- ;print the question
- D HDR F DISP=0:0 S DISP=$O(^QA(748.25,"E",SURVEY,DISP)) Q:DISP=""!($D(DIRUT)) F QNUM=0:0 S QNUM=$O(^QA(748.25,"E",SURVEY,DISP,QNUM)) Q:QNUM="" DO
- .W ! X TOF W ! X TOF
- .W DISP,". " F I=0:0 S I=$O(^QA(748.25,SURVEY,1,QNUM,2,I)) D:I=""!(+I=0) Q:I=""!(+I=0)!($D(DIRUT)) S X=$P(^QA(748.25,SURVEY,1,QNUM,2,I,0),U,1) W X,! X TOF
- ..S ANSTYPE=$P(^QA(748.25,SURVEY,1,QNUM,0),U,3),GRADIENT=$P(^(0),U,4) I ANSTYPE="l" S QUES=QNUM D LIKRTLAB^QAPCHX W ! K QUES
- ..S QUES=$O(^QA(748.3,LPART,1,"B",QNUM,0)) Q:QUES=""!($D(DIRUT)) W ! X TOF
- ..S ANS="" F S ANS=$O(^TMP($J,QUES,ANS)) Q:ANS=""!($D(DIRUT)) S DTA=$G(^TMP($J,QUES,ANS)) Q:DTA="" S TOTANS=$P(DTA,U,1),ANSTEXT=$P(^TMP($J,QUES,ANS),U,2) DO
- ...;reduce participants by # of skipped or n/a questions
- ...S BLANKS=0 I BYPASS=2,ANS'=" " S BLANKS=+$P($G(^TMP($J,QUES," ")),U,1),TOTPART=TOTPART-BLANKS
- ...S BLANKNA=0 I BYPASSNA=2,ANS'="NA" S BLANKNA=+$P($G(^TMP($J,QUES,"NA")),U,1),TOTPART=TOTPART-BLANKNA
- ...I ANS="WP" S QUES1=$P(DTA,U,2) D WP Q
- ...I ANSTEXT]"","^ ^T^F^Y^N^NA^"[ANS S ANSTEXT=$S(ANS="NA":"Not applicable",ANS="T":"True",ANS="F":"False",ANS="Y":"Yes",ANS="N":"No",ANS=" ":"did not respond",1:"???")
- ...S PCNT=0 I TOTPART>0 S PCNT=$J((TOTANS/TOTPART)*100,4,1)
- ...S RESPD=" participant"_$S(TOTANS=1:"",1:"s")
- ...W ?9,TOTANS,$S(ANS=" "&(BYPASS=2):RESPD_" ",ANS="NA"&(BYPASSNA=2):RESPD_" ",1:" or "_PCNT_"% "),$S(ANS'=" ":"responded ",1:""),ANSTEXT,! X TOF
- ...I BYPASS=2,ANS'=" " S TOTPART=TOTPART+BLANKS ;add back skipped questions
- ...I BYPASSNA=2,ANS'="NA" S TOTPART=TOTPART+BLANKNA ;add back NA questions
- I '$D(DIRUT),IOST?1"C-".E K DIR,DIRUT S DIR(0)="E" D ^DIR
- ;
- EXIT K ^XTMP($J),ANSX,CNTR G EXIT^QAPUTIL
- ;
- WP ;WP responses
- I $D(WPPRT),WPPRT=2 Q
- F PART1=0:0 S PART1=$O(^TMP($J,"QAPZ",PART1)) Q:PART1=""!($D(DIRUT)) W:$O(^QA(748.3,PART1,1,QUES1,1,0))]"" !?3,"----------",! X TOF DO
- .F QZ=0:0 S QZ=$O(^QA(748.3,PART1,1,QUES1,1,QZ)) Q:QZ=""!($D(DIRUT)) S QY=^QA(748.3,PART1,1,QUES1,1,QZ,0) W ?3,QY,! X TOF
- 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,!,?(IOM-$L(BANNER)\2),BANNER,!
- W:PG=1 !,"Total responses: ",TOTPART,?49,$S(BYPASSNA=2:"Not including",1:"Including")_" 'NA' answers",!?49,$S(BYPASS=2:"Not including",1:"Including")_" bypassed answers"
- W !,LINE,!
- Q
- ;
- PAUSE I IOST?1"C-".E W ! K DIR,DIRUT S DIR(0)="E" D ^DIR Q:$D(DIRUT)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPSTAT1 4406 printed Jan 18, 2025@03:39:42 Page 2
- QAPSTAT1 ;557/THM-SURVEY GENERATOR STATISTICS, PART 2 [ 08/28/95 2:16 PM ]
- +1 ;;2.0;Survey Generator;;Jun 20, 1995
- +2 ;enter properly
- QUIT
- +3 ;
- PRINT KILL ^TMP($JOB),TOTPART,TOTANS
- +1 USE IO
- SET (QAPOUT,PG,TOTPART,TOTANS)=0
- +2 SET BANNER="S T A T I S T I C S"
- +3 SET QAPDATE=$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
- SET $PIECE(LINE,"-",IOM)=""
- SET QAPDATE=$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
- +4 IF IOST?1"P-".E!(IOST?1"PK-".E)
- SET TOF="I $Y>(IOSL-8) W !!,""Continued on next page"",! D HDR Q:$D(DIRUT)"
- +5 IF IOST?1"C-".E
- SET TOF="I $Y>(IOSL-4) D PAUSE Q:$D(DIRUT) D HDR"
- +6 ;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
- +7 ;only completed responses
- FOR PART=0:0
- SET PART=$ORDER(^QA(748.3,"B",SURVEY,PART))
- if PART=""
- QUIT
- IF $PIECE(^QA(748.3,PART,0),U,3)="c"
- Begin DoDot:1
- +8 FOR QNUM=0:0
- SET QNUM=$ORDER(^QA(748.3,PART,1,QNUM))
- if QNUM=""!(+QNUM=0)
- QUIT
- SET ANS=$PIECE(^QA(748.3,PART,1,QNUM,0),U,2)
- Begin DoDot:2
- +9 ;aborted WP response
- IF ANS=""
- IF $ORDER(^QA(748.3,PART,1,QNUM,0))=""
- QUIT
- +10 IF ANS=""
- IF $ORDER(^QA(748.3,PART,1,QNUM,0))]""
- SET ^TMP($JOB,QNUM,"WP")="WP"_U_QNUM
- QUIT
- +11 ;PQUES is the question pointer
- IF ANS]""
- if '$DATA(^TMP($JOB,QNUM,ANS))
- SET ^TMP($JOB,QNUM,ANS)="0^"
- SET $PIECE(^TMP($JOB,QNUM,ANS),U,1)=$PIECE(^TMP($JOB,QNUM,ANS),U,1)+1
- SET PQUES=$PIECE(^QA(748.3,PART,1,QNUM,0),U)
- +12 ;put in answer order to compare
- KILL ^XTMP($JOB)
- SET (ANSX,CNTR)=0
- FOR
- SET ANSX=$ORDER(^QA(748.25,SURVEY,1,PQUES,3,ANSX))
- if ANSX=""!(+ANSX=0)
- QUIT
- SET CNTR=CNTR+1
- SET ^XTMP($JOB,SURVEY,1,PQUES,3,CNTR,0)=^QA(748.25,SURVEY,1,PQUES,3,ANSX,0)
- +13 IF +ANS>0
- SET $PIECE(^TMP($JOB,QNUM,ANS),U,2)=$SELECT($PIECE($GET(^XTMP($JOB,SURVEY,1,PQUES,3,ANS,0)),U)]"":$PIECE(^(0),U),1:ANS)
- +14 IF +ANS=0
- SET $PIECE(^TMP($JOB,QNUM,ANS),U,2)=$SELECT($PIECE($GET(^XTMP($JOB,SURVEY,1,PQUES,3,($ASCII(ANS)-96),0)),U)]"":$PIECE(^(0),U),1:ANS)
- End DoDot:2
- End DoDot:1
- SET TOTPART=TOTPART+1
- SET LPART=PART
- SET ^TMP($JOB,"QAPZ",PART)=""
- +15 ;LPART is the ifn of the last participant examined. It is kept
- +16 ;as a link to file 748.3
- +17 IF TOTPART=0
- DO HDR
- WRITE !!!?20,"No one has yet participated in this survey.",!
- if IOST?1"C-".E
- DO PAUSE
- GOTO EXIT
- +18 ;print the question
- +19 DO HDR
- FOR DISP=0:0
- SET DISP=$ORDER(^QA(748.25,"E",SURVEY,DISP))
- if DISP=""!($DATA(DIRUT))
- QUIT
- FOR QNUM=0:0
- SET QNUM=$ORDER(^QA(748.25,"E",SURVEY,DISP,QNUM))
- if QNUM=""
- QUIT
- Begin DoDot:1
- +20 WRITE !
- XECUTE TOF
- WRITE !
- XECUTE TOF
- +21 WRITE DISP,". "
- FOR I=0:0
- SET I=$ORDER(^QA(748.25,SURVEY,1,QNUM,2,I))
- if I=""!(+I=0)
- Begin DoDot:2
- +22 SET ANSTYPE=$PIECE(^QA(748.25,SURVEY,1,QNUM,0),U,3)
- SET GRADIENT=$PIECE(^(0),U,4)
- IF ANSTYPE="l"
- SET QUES=QNUM
- DO LIKRTLAB^QAPCHX
- WRITE !
- KILL QUES
- +23 SET QUES=$ORDER(^QA(748.3,LPART,1,"B",QNUM,0))
- if QUES=""!($DATA(DIRUT))
- QUIT
- WRITE !
- XECUTE TOF
- +24 SET ANS=""
- FOR
- SET ANS=$ORDER(^TMP($JOB,QUES,ANS))
- if ANS=""!($DATA(DIRUT))
- QUIT
- SET DTA=$GET(^TMP($JOB,QUES,ANS))
- if DTA=""
- QUIT
- SET TOTANS=$PIECE(DTA,U,1)
- SET ANSTEXT=$PIECE(^TMP($JOB,QUES,ANS),U,2)
- Begin DoDot:3
- +25 ;reduce participants by # of skipped or n/a questions
- +26 SET BLANKS=0
- IF BYPASS=2
- IF ANS'=" "
- SET BLANKS=+$PIECE($GET(^TMP($JOB,QUES," ")),U,1)
- SET TOTPART=TOTPART-BLANKS
- +27 SET BLANKNA=0
- IF BYPASSNA=2
- IF ANS'="NA"
- SET BLANKNA=+$PIECE($GET(^TMP($JOB,QUES,"NA")),U,1)
- SET TOTPART=TOTPART-BLANKNA
- +28 IF ANS="WP"
- SET QUES1=$PIECE(DTA,U,2)
- DO WP
- QUIT
- +29 IF ANSTEXT]""
- IF "^ ^T^F^Y^N^NA^"[ANS
- SET ANSTEXT=$SELECT(ANS="NA":"Not applicable",ANS="T":"True",ANS="F":"False",ANS="Y":"Yes",ANS="N":"No",ANS=" ":"did not respond",1:"???")
- +30 SET PCNT=0
- IF TOTPART>0
- SET PCNT=$JUSTIFY((TOTANS/TOTPART)*100,4,1)
- +31 SET RESPD=" participant"_$SELECT(TOTANS=1:"",1:"s")
- +32 WRITE ?9,TOTANS,$SELECT(ANS=" "&(BYPASS=2):RESPD_" ",ANS="NA"&(BYPASSNA=2):RESPD_" ",1:" or "_PCNT_"% "),$SELECT(ANS'=" ":"responded ",1:""),ANSTEXT,!
- XECUTE TOF
- +33 ;add back skipped questions
- IF BYPASS=2
- IF ANS'=" "
- SET TOTPART=TOTPART+BLANKS
- +34 ;add back NA questions
- IF BYPASSNA=2
- IF ANS'="NA"
- SET TOTPART=TOTPART+BLANKNA
- End DoDot:3
- End DoDot:2
- if I=""!(+I=0)!($DATA(DIRUT))
- QUIT
- SET X=$PIECE(^QA(748.25,SURVEY,1,QNUM,2,I,0),U,1)
- WRITE X,!
- XECUTE TOF
- End DoDot:1
- +35 IF '$DATA(DIRUT)
- IF IOST?1"C-".E
- KILL DIR,DIRUT
- SET DIR(0)="E"
- DO ^DIR
- +36 ;
- EXIT KILL ^XTMP($JOB),ANSX,CNTR
- GOTO EXIT^QAPUTIL
- +1 ;
- WP ;WP responses
- +1 IF $DATA(WPPRT)
- IF WPPRT=2
- QUIT
- +2 FOR PART1=0:0
- SET PART1=$ORDER(^TMP($JOB,"QAPZ",PART1))
- if PART1=""!($DATA(DIRUT))
- QUIT
- if $ORDER(^QA(748.3,PART1,1,QUES1,1,0))]""
- WRITE !?3,"----------",!
- XECUTE TOF
- Begin DoDot:1
- +3 FOR QZ=0:0
- SET QZ=$ORDER(^QA(748.3,PART1,1,QUES1,1,QZ))
- if QZ=""!($DATA(DIRUT))
- QUIT
- SET QY=^QA(748.3,PART1,1,QUES1,1,QZ,0)
- WRITE ?3,QY,!
- XECUTE TOF
- End DoDot:1
- +4 QUIT
- +5 ;
- 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,!,?(IOM-$LENGTH(BANNER)\2),BANNER,!
- +1 if PG=1
- WRITE !,"Total responses: ",TOTPART,?49,$SELECT(BYPASSNA=2:"Not including",1:"Including")_" 'NA' answers",!?49,$SELECT(BYPASS=2:"Not including",1:"Including")_" bypassed answers"
- +2 WRITE !,LINE,!
- +3 QUIT
- +4 ;
- PAUSE IF IOST?1"C-".E
- WRITE !
- KILL DIR,DIRUT
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +1 QUIT