QAPDEMS1 ;557/THM-DEMOGRAPHICAL STATISTICS,PART 2 [ 08/28/95 2:16 PM ]
;;2.0;Survey Generator;;Jun 20, 1995
;
PRINT K ^TMP($J),TOTPART,LPART,DEMOG,TOTANS
U IO S (QAPOUT,PG,TOTPART)=0
S BANNER="Demographical Statistics",BANNER1="Sorting on: "_SORTTXT
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-8) 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 VA hosp or other?
F PART=0:0 S PART=$O(^QA(748.3,"B",SURVEY,PART)) Q:PART="" DO
.S DEMPTR=$O(^QA(748.3,PART,2,"B",SORT,0)) Q:DEMPTR=""!($P(^QA(748.3,PART,0),U,3)'="c")
.S TOTPART=TOTPART+1,LPART=PART ;count responses
.S DEMOG=$P(^QA(748.3,PART,2,DEMPTR,0),U,2)
.I DEMTYPE="d" S Y=DEMOG X ^DD("DD") S DEMOG=Y
.I '$D(TOTPART(DEMOG)) S TOTPART(DEMOG)=0
.S ^TMP($J,DEMOG,"ZZ",PART)=""
.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
..I ANS="",$O(^QA(748.3,PART,1,QNUM,0))]"" S ^TMP($J,DEMOG,QNUM,"WP")="WP"_U_QNUM Q
..I ANS]"" S:'$D(^TMP($J,DEMOG,QNUM,ANS)) ^TMP($J,DEMOG,QNUM,ANS)="0^"
..I ANS]"" S $P(^TMP($J,DEMOG,QNUM,ANS),U,1)=$P(^TMP($J,DEMOG,QNUM,ANS),U,1)+1,PQUES=$P(^QA(748.3,PART,1,QNUM,0),U)
..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,DEMOG,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,DEMOG,QNUM,ANS),U,2)=$S($P($G(^XTMP($J,SURVEY,1,PQUES,3,($A(ANS)-96),0)),U)]"":$P(^(0),U),1:ANS)
.S TOTPART(DEMOG)=TOTPART(DEMOG)+1
;LPART is the ifn of the last participant examined.
I TOTPART=0 D HDR W !!!?20,"No one has yet participated in this survey.",!! R:IOST?1"C-".E "Press RETURN ",ANS:DTIME G EXIT^QAPUTIL
;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" N QUES S QUES=QNUM D LIKRTLAB^QAPCHX W !
..S QUES=$O(^QA(748.3,LPART,1,"B",QNUM,0)) Q:QUES=""!($D(DIRUT))
..S (ANS,DEMOG)="" W !!
..F S DEMOG=$O(^TMP($J,DEMOG)) Q:DEMOG="" F S ANS=$O(^TMP($J,DEMOG,QUES,ANS)) Q:ANS="" S DTA=$G(^TMP($J,DEMOG,QUES,ANS)) Q:DTA="" S TOTANS=$P(DTA,U,1),ANSTEXT=$P(^TMP($J,DEMOG,QUES,ANS),U,2) DO I $D(DIRUT) S (ANS,QUES,DEMOG)="ZZ"
...;reduce participants by skipped or NA questions
...S BLANKS=0 I BYPASS=2,ANS'=" " S BLANKS=+$P($G(^TMP($J,DEMOG,QUES," ")),U,1),TOTPART(DEMOG)=TOTPART(DEMOG)-BLANKS
...S BLANKNA=0 I BYPASSNA=2,ANS'="NA" S BLANKNA=+$P($G(^TMP($J,DEMOG,QUES,"NA")),U,1),TOTPART(DEMOG)=TOTPART(DEMOG)-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:"???")
...I DEMTYPE="d" S Y=DEMOG X ^DD("DD") S DEMOG=Y
...S PCNT=0 I TOTPART(DEMOG)>0 S PCNT=$J((TOTANS/TOTPART(DEMOG))*100,4,1)
...S RESPD=" participant"_$S(TOTANS=1:"",1:"s")
...W ?2,TOTANS,$S(ANS=" "&(BYPASS=2):RESPD_" of '",ANS="NA"&(BYPASSNA=2):RESPD_" of ",1:" or "_PCNT_"% of '"),$E(DEMOG,1,35),$S(ANS'=" ":"' responded ",1:""),ANSTEXT,! X TOF
...I BYPASS=2,ANS'=" " S TOTPART(DEMOG)=TOTPART(DEMOG)+BLANKS ;add back skipped questions
...I BYPASSNA=2,ANS'="NA" S TOTPART(DEMOG)=TOTPART(DEMOG)+BLANKNA ;add back NA questions
I '$D(DIRUT),IOST?1"C-".E K DIR,DIRUT S DIR(0)="E" D ^DIR G:X[U EXIT^QAPUTIL G EN^QAPDEMS
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,DEMOG,"ZZ",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,!,?(IOM-$L(BANNER1)\2),BANNER1,!
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[HQAPDEMS1 4968 printed Apr 09, 2024@21:41:04 Page 2
QAPDEMS1 ;557/THM-DEMOGRAPHICAL STATISTICS,PART 2 [ 08/28/95 2:16 PM ]
+1 ;;2.0;Survey Generator;;Jun 20, 1995
+2 ;
PRINT KILL ^TMP($JOB),TOTPART,LPART,DEMOG,TOTANS
+1 USE IO
SET (QAPOUT,PG,TOTPART)=0
+2 SET BANNER="Demographical Statistics"
SET BANNER1="Sorting on: "_SORTTXT
+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-8) D PAUSE Q:$D(DIRUT) D HDR"
+6 ;is 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 FOR PART=0:0
SET PART=$ORDER(^QA(748.3,"B",SURVEY,PART))
if PART=""
QUIT
Begin DoDot:1
+8 SET DEMPTR=$ORDER(^QA(748.3,PART,2,"B",SORT,0))
if DEMPTR=""!($PIECE(^QA(748.3,PART,0),U,3)'="c")
QUIT
+9 ;count responses
SET TOTPART=TOTPART+1
SET LPART=PART
+10 SET DEMOG=$PIECE(^QA(748.3,PART,2,DEMPTR,0),U,2)
+11 IF DEMTYPE="d"
SET Y=DEMOG
XECUTE ^DD("DD")
SET DEMOG=Y
+12 IF '$DATA(TOTPART(DEMOG))
SET TOTPART(DEMOG)=0
+13 SET ^TMP($JOB,DEMOG,"ZZ",PART)=""
+14 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
+15 ;aborted wp
IF ANS=""
IF $ORDER(^QA(748.3,PART,1,QNUM,0))=""
QUIT
+16 IF ANS=""
IF $ORDER(^QA(748.3,PART,1,QNUM,0))]""
SET ^TMP($JOB,DEMOG,QNUM,"WP")="WP"_U_QNUM
QUIT
+17 IF ANS]""
if '$DATA(^TMP($JOB,DEMOG,QNUM,ANS))
SET ^TMP($JOB,DEMOG,QNUM,ANS)="0^"
+18 IF ANS]""
SET $PIECE(^TMP($JOB,DEMOG,QNUM,ANS),U,1)=$PIECE(^TMP($JOB,DEMOG,QNUM,ANS),U,1)+1
SET PQUES=$PIECE(^QA(748.3,PART,1,QNUM,0),U)
+19 ;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)
+20 IF +ANS>0
SET $PIECE(^TMP($JOB,DEMOG,QNUM,ANS),U,2)=$SELECT($PIECE($GET(^XTMP($JOB,SURVEY,1,PQUES,3,ANS,0)),U)]"":$PIECE(^(0),U),1:ANS)
+21 IF +ANS=0
SET $PIECE(^TMP($JOB,DEMOG,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
+22 SET TOTPART(DEMOG)=TOTPART(DEMOG)+1
End DoDot:1
+23 ;LPART is the ifn of the last participant examined.
+24 IF TOTPART=0
DO HDR
WRITE !!!?20,"No one has yet participated in this survey.",!!
if IOST?1"C-".E
READ "Press RETURN ",ANS:DTIME
GOTO EXIT^QAPUTIL
+25 ;print the question
+26 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
+27 WRITE !
XECUTE TOF
WRITE !
XECUTE TOF
+28 WRITE DISP,". "
FOR I=0:0
SET I=$ORDER(^QA(748.25,SURVEY,1,QNUM,2,I))
if I=""!(+I=0)
Begin DoDot:2
+29 SET ANSTYPE=$PIECE(^QA(748.25,SURVEY,1,QNUM,0),U,3)
SET GRADIENT=$PIECE(^(0),U,4)
IF ANSTYPE="l"
NEW QUES
SET QUES=QNUM
DO LIKRTLAB^QAPCHX
WRITE !
+30 SET QUES=$ORDER(^QA(748.3,LPART,1,"B",QNUM,0))
if QUES=""!($DATA(DIRUT))
QUIT
+31 SET (ANS,DEMOG)=""
WRITE !!
+32 FOR
SET DEMOG=$ORDER(^TMP($JOB,DEMOG))
if DEMOG=""
QUIT
FOR
SET ANS=$ORDER(^TMP($JOB,DEMOG,QUES,ANS))
if ANS=""
QUIT
SET DTA=$GET(^TMP($JOB,DEMOG,QUES,ANS))
if DTA=""
QUIT
SET TOTANS=$PIECE(DTA,U,1)
SET ANSTEXT=$PIECE(^TMP($JOB,DEMOG,QUES,ANS),U,2)
Begin DoDot:3
+33 ;reduce participants by skipped or NA questions
+34 SET BLANKS=0
IF BYPASS=2
IF ANS'=" "
SET BLANKS=+$PIECE($GET(^TMP($JOB,DEMOG,QUES," ")),U,1)
SET TOTPART(DEMOG)=TOTPART(DEMOG)-BLANKS
+35 SET BLANKNA=0
IF BYPASSNA=2
IF ANS'="NA"
SET BLANKNA=+$PIECE($GET(^TMP($JOB,DEMOG,QUES,"NA")),U,1)
SET TOTPART(DEMOG)=TOTPART(DEMOG)-BLANKNA
+36 IF ANS="WP"
SET QUES1=$PIECE(DTA,U,2)
DO WP
QUIT
+37 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:"???")
+38 IF DEMTYPE="d"
SET Y=DEMOG
XECUTE ^DD("DD")
SET DEMOG=Y
+39 SET PCNT=0
IF TOTPART(DEMOG)>0
SET PCNT=$JUSTIFY((TOTANS/TOTPART(DEMOG))*100,4,1)
+40 SET RESPD=" participant"_$SELECT(TOTANS=1:"",1:"s")
+41 WRITE ?2,TOTANS,$SELECT(ANS=" "&(BYPASS=2):RESPD_" of '",ANS="NA"&(BYPASSNA=2):RESPD_" of ",1:" or "_PCNT_"% of '"),$EXTRACT(DEMOG,1,35),$SELECT(ANS'=" ":"' responded ",1:""),ANSTEXT,!
XECUTE TOF
+42 ;add back skipped questions
IF BYPASS=2
IF ANS'=" "
SET TOTPART(DEMOG)=TOTPART(DEMOG)+BLANKS
+43 ;add back NA questions
IF BYPASSNA=2
IF ANS'="NA"
SET TOTPART(DEMOG)=TOTPART(DEMOG)+BLANKNA
End DoDot:3
IF $DATA(DIRUT)
SET (ANS,QUES,DEMOG)="ZZ"
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
+44 IF '$DATA(DIRUT)
IF IOST?1"C-".E
KILL DIR,DIRUT
SET DIR(0)="E"
DO ^DIR
if X[U
GOTO EXIT^QAPUTIL
GOTO EN^QAPDEMS
+45 KILL ^XTMP($JOB),ANSX,CNTR
GOTO EXIT^QAPUTIL
+46 ;
WP ;WP responses
+1 IF $DATA(WPPRT)
IF WPPRT=2
QUIT
+2 FOR PART1=0:0
SET PART1=$ORDER(^TMP($JOB,DEMOG,"ZZ",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,!,?(IOM-$LENGTH(BANNER1)\2),BANNER1,!
+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"
WRITE !,LINE,!
+2 QUIT
+3 ;
PAUSE IF IOST?1"C-".E
WRITE !
KILL DIR,DIRUT
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
QUIT
+1 QUIT
