QAPEDIT1 ;557/THM-CREATE/EDIT/MAINTAIN SURVEY INFORMATION, PART 2 [ 05/18/95 7:28 AM ]
;;2.0;Survey Generator;;Jun 20, 1995
;
INDIV I $O(^QA(748.3,"B",SURVEY,0))]"" W *7,!!,"This survey has data associated with it and the question content",!,"may not be changed.",!!,"Press RETURN " R ANS:DTIME S:'$T STOP=1 G:$D(STOP) EXIT G EN^QAPEDIT
I ACTION="I" K STOP,OUT S DA(1)=SURVEY DO G:$D(STOP) EXIT
.;
DIS .K DA S DA(1)=SURVEY
.K DANS S LSTNUM="" F I=0:0 S I=$O(^QA(748.25,"E",SURVEY,I)) Q:I="" F J=0:0 S J=$O(^QA(748.25,"E",SURVEY,I,J)) Q:J="" S DANS(I,J)=I,DANS(I)=I,LSTNUM=I
.W @IOF,! S QAPHDR="Survey Name: "_SUBJ X QAPBAR S QAPHDR="Editing Individual Questions" X QAPBAR W !,BLDON,"Type ^ to exit, ? or ?? for HELP",BLDOFF
.W:$D(LSTNUM) ?51,"Last question number: ",LSTNUM W !!,">> Question number: " R QAPQN:DTIME S:+QAPQN>0 LSTNUM=QAPQN I '$T S STOP=1 Q
.I QAPQN="?" D HELPLKE^QAPUTIL1 I QAPQN="" G DIS
.I QAPQN=""!(QAPQN[U) S OUT=1 Q
.S QAPQN=$TR(QAPQN,"cr","CR")
.I QAPQN?1"R" W " Resequence question numbers " H 1 D R1^QAPRSEQ G DIS
.I QAPQN?1"C" D EN^QAPQCOPY,RSQ G DIS
.I QAPQN'?1.3N,QAPQN'?1.3N1"."1.2N,QAPQN'?1"R",+QAPQN'=QAPQN W !!,"Question number entry must be numeric,'R' to resequence",!,"the question numbers, or 'C' to copy a question.",*7 H 2 G DIS
.I +QAPQN<1!(+QAPQN>999) W !!,*7,"This number must be between 1 and 999.",! H 2 G DIS
.S (DIC,DIE)="^QA(748.25,"_DA(1)_",1," X CLEOP
.S DA=$O(^QA(748.25,"E",DA(1),QAPQN,0)) I DA]"" F I=0:0 S I=$O(^QA(748.25,SURVEY,1,DA,2,I)) D:I=""!(+I=0) Q:I=""!(+I=0) S X=$P(^QA(748.25,SURVEY,1,DA,2,I,0),U,1) W X,!
.K DIR S DIR("A")="Change or Delete"
.I DA]"" S DIR(0)="SB^C:Change;D:Delete",DIR("B")="Change" D ^DIR S:$D(DTOUT) EXIT=1 S:$D(DUOUT) OUT=1 Q:$D(DTOUT) G:$D(DUOUT) DIS S CHOICE=Y I CHOICE=""!(CHOICE[U) S OUT=1 Q
.I DA="" K DIR,STOP,OUT S DIR("A")="Are you adding question "_QAPQN_" ",DIR(0)="Y",DIR("B")="No" W *7 D ^DIR S:$D(DTOUT) EXIT=1 S:$D(DUOUT) OUT=1 Q:$D(DTOUT)!($D(DUOUT)) S:Y=1 CHOICE="A" I Y'=1 G DIS
.I CHOICE="A" S:'$D(^QA(748.25,DA(1),1,0)) ^QA(748.25,DA(1),1,0)="^748.26I^0^0"
.I CHOICE="A" S X=+$P(^QA(748.25,DA(1),1,0),U,3)+1,DLAYGO=748.25,DIC(0)="AEQLM",DIC("DR")=".015////"_QAPQN_";.055;.05;.02" K DO,DD D FILE^DICN
.I CHOICE="A" Q:+Y<0 S DA=+Y I $P(^QA(748.25,DA(1),1,DA,1),U)="m" S DR=".025;I X'=""l"" S Y=""@1"";.027;3;1;2;S Y=""@99"";@1;.03;@99" D ^DIE,RSQ
.I CHOICE="C" S DR=".015;.055;.05;.02" X CLEOP D ^DIE,RSQ S:$D(DTOUT) STOP=1 G:$D(Y) DIS
.I CHOICE="C",$P(^QA(748.25,DA(1),1,DA,1),U)'="m" D KANS^QAPUTIL2 S DR=".025///@;.027///@;3///@;1///@;2///@" D ^DIE,RSQ
.I CHOICE="C",$P(^QA(748.25,DA(1),1,DA,1),U)="m" S DR=".025;I X'=""l"" S Y=""@1"";D KANS^QAPUTIL2;.027;3;1;2;S Y=""@99"";@1;.027///@;3///@;1///@;2///@;.03;@99" D ^DIE,RSQ
.I CHOICE="D" DO G DIS
..W !,*7,"Are you sure you want to remove this question" S %=2 D YN^DICN I $D(DTOUT) S EXIT=1 Q
..I %'=1 W !,">> Nothing deleted <<" H 1 Q
..I %=1 S DIK="^QA(748.25,"_DA(1)_",1," D ^DIK W !!,">> Question removed << " H 2 Q
.G DIS
;
EDITALL I $O(^QA(748.3,"B",SURVEY,0))]"" W *7,!!,"This survey has data associated with it and the question content",!,"may not be changed.",! H 2 G EN^QAPEDIT
S DA(1)=SURVEY
I ACTION="E" K OUT S QAPHDR="Survey Name: "_SUBJ W @IOF,! X QAPBAR S QAPHDR="Edit All Questions Sequentially" X QAPBAR K ^TMP($J)
I ACTION="E",$O(^QA(748.25,"E",SURVEY,0))="" W !!?10,"This survey has no questions.",! H 2 G EN^QAPEDIT
I ACTION="E" F QAPQN=0:0 S QAPQN=$O(^QA(748.25,"E",DA(1),QAPQN)) Q:QAPQN="" F DA=0:0 S DA=$O(^QA(748.25,"E",DA(1),QAPQN,DA)) Q:DA="" DO I $D(OUT)!($D(EXIT)) S (QAPQN,DA,DA(1))=999999
.S QAPHDR="Survey Name: "_SUBJ W @IOF,! X QAPBAR S QAPHDR="Edit All Questions Sequentially" X QAPBAR
.W !,">> Question number: ",QAPQN,! S (DIC,DIE)="^QA(748.25,"_DA(1)_",1,",DR=".055;.05;.015;.02" D ^DIE,RSQ I $D(DTOUT) S EXIT=1 Q
.I $D(Y) S OUT=1 Q
.I $P(^QA(748.25,DA(1),1,DA,1),U)'="m" D KANS^QAPUTIL2 S DR=".025///@;.027///@;3///@;1///@;2///@" D ^DIE,RSQ
.I $P(^QA(748.25,DA(1),1,DA,1),U)="m" S DR=".025;I X'=""l"" S Y=""@1"";D KANS^QAPUTIL2;.027;3;1;2;S Y=""@99"";@1;.027///@;3///@;1///@;2///@;.03;@99" D ^DIE,RSQ I $D(DTOUT) S EXIT=1 Q
.I $D(Y) S OUT=1 Q
I $D(EXIT) G EXIT
G EN^QAPEDIT
;
EXIT G EXIT^QAPUTIL
;
RSQ K DANS F I=0:0 S I=$O(^QA(748.25,"E",SURVEY,I)) Q:I="" F J=0:0 S J=$O(^QA(748.25,"E",SURVEY,I,J)) Q:J="" S DANS(I,J)=I,DANS(I)=I
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPEDIT1 4448 printed Dec 13, 2024@02:38:20 Page 2
QAPEDIT1 ;557/THM-CREATE/EDIT/MAINTAIN SURVEY INFORMATION, PART 2 [ 05/18/95 7:28 AM ]
+1 ;;2.0;Survey Generator;;Jun 20, 1995
+2 ;
INDIV IF $ORDER(^QA(748.3,"B",SURVEY,0))]""
WRITE *7,!!,"This survey has data associated with it and the question content",!,"may not be changed.",!!,"Press RETURN "
READ ANS:DTIME
if '$TEST
SET STOP=1
if $DATA(STOP)
GOTO EXIT
GOTO EN^QAPEDIT
+1 IF ACTION="I"
KILL STOP,OUT
SET DA(1)=SURVEY
Begin DoDot:1
+2 ;
DIS KILL DA
SET DA(1)=SURVEY
+1 KILL DANS
SET LSTNUM=""
FOR I=0:0
SET I=$ORDER(^QA(748.25,"E",SURVEY,I))
if I=""
QUIT
FOR J=0:0
SET J=$ORDER(^QA(748.25,"E",SURVEY,I,J))
if J=""
QUIT
SET DANS(I,J)=I
SET DANS(I)=I
SET LSTNUM=I
+2 WRITE @IOF,!
SET QAPHDR="Survey Name: "_SUBJ
XECUTE QAPBAR
SET QAPHDR="Editing Individual Questions"
XECUTE QAPBAR
WRITE !,BLDON,"Type ^ to exit, ? or ?? for HELP",BLDOFF
+3 if $DATA(LSTNUM)
WRITE ?51,"Last question number: ",LSTNUM
WRITE !!,">> Question number: "
READ QAPQN:DTIME
if +QAPQN>0
SET LSTNUM=QAPQN
IF '$TEST
SET STOP=1
QUIT
+4 IF QAPQN="?"
DO HELPLKE^QAPUTIL1
IF QAPQN=""
GOTO DIS
+5 IF QAPQN=""!(QAPQN[U)
SET OUT=1
QUIT
+6 SET QAPQN=$TRANSLATE(QAPQN,"cr","CR")
+7 IF QAPQN?1"R"
WRITE " Resequence question numbers "
HANG 1
DO R1^QAPRSEQ
GOTO DIS
+8 IF QAPQN?1"C"
DO EN^QAPQCOPY
DO RSQ
GOTO DIS
+9 IF QAPQN'?1.3N
IF QAPQN'?1.3N1"."1.2N
IF QAPQN'?1"R"
IF +QAPQN'=QAPQN
WRITE !!,"Question number entry must be numeric,'R' to resequence",!,"the question numbers, or 'C' to copy a question.",*7
HANG 2
GOTO DIS
+10 IF +QAPQN<1!(+QAPQN>999)
WRITE !!,*7,"This number must be between 1 and 999.",!
HANG 2
GOTO DIS
+11 SET (DIC,DIE)="^QA(748.25,"_DA(1)_",1,"
XECUTE CLEOP
+12 SET DA=$ORDER(^QA(748.25,"E",DA(1),QAPQN,0))
IF DA]""
FOR I=0:0
SET I=$ORDER(^QA(748.25,SURVEY,1,DA,2,I))
if I=""!(+I=0)
Begin DoDot:2
End DoDot:2
if I=""!(+I=0)
QUIT
SET X=$PIECE(^QA(748.25,SURVEY,1,DA,2,I,0),U,1)
WRITE X,!
+13 KILL DIR
SET DIR("A")="Change or Delete"
+14 IF DA]""
SET DIR(0)="SB^C:Change;D:Delete"
SET DIR("B")="Change"
DO ^DIR
if $DATA(DTOUT)
SET EXIT=1
if $DATA(DUOUT)
SET OUT=1
if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
GOTO DIS
SET CHOICE=Y
IF CHOICE=""!(CHOICE[U)
SET OUT=1
QUIT
+15 IF DA=""
KILL DIR,STOP,OUT
SET DIR("A")="Are you adding question "_QAPQN_" "
SET DIR(0)="Y"
SET DIR("B")="No"
WRITE *7
DO ^DIR
if $DATA(DTOUT)
SET EXIT=1
if $DATA(DUOUT)
SET OUT=1
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
if Y=1
SET CHOICE="A"
IF Y'=1
GOTO DIS
+16 IF CHOICE="A"
if '$DATA(^QA(748.25,DA(1),1,0))
SET ^QA(748.25,DA(1),1,0)="^748.26I^0^0"
+17 IF CHOICE="A"
SET X=+$PIECE(^QA(748.25,DA(1),1,0),U,3)+1
SET DLAYGO=748.25
SET DIC(0)="AEQLM"
SET DIC("DR")=".015////"_QAPQN_";.055;.05;.02"
KILL DO,DD
DO FILE^DICN
+18 IF CHOICE="A"
if +Y<0
QUIT
SET DA=+Y
IF $PIECE(^QA(748.25,DA(1),1,DA,1),U)="m"
SET DR=".025;I X'=""l"" S Y=""@1"";.027;3;1;2;S Y=""@99"";@1;.03;@99"
DO ^DIE
DO RSQ
+19 IF CHOICE="C"
SET DR=".015;.055;.05;.02"
XECUTE CLEOP
DO ^DIE
DO RSQ
if $DATA(DTOUT)
SET STOP=1
if $DATA(Y)
GOTO DIS
+20 IF CHOICE="C"
IF $PIECE(^QA(748.25,DA(1),1,DA,1),U)'="m"
DO KANS^QAPUTIL2
SET DR=".025///@;.027///@;3///@;1///@;2///@"
DO ^DIE
DO RSQ
+21 IF CHOICE="C"
IF $PIECE(^QA(748.25,DA(1),1,DA,1),U)="m"
SET DR=".025;I X'=""l"" S Y=""@1"";D KANS^QAPUTIL2;.027;3;1;2;S Y=""@99"";@1;.027///@;3///@;1///@;2///@;.03;@99"
DO ^DIE
DO RSQ
+22 IF CHOICE="D"
Begin DoDot:2
+23 WRITE !,*7,"Are you sure you want to remove this question"
SET %=2
DO YN^DICN
IF $DATA(DTOUT)
SET EXIT=1
QUIT
+24 IF %'=1
WRITE !,">> Nothing deleted <<"
HANG 1
QUIT
+25 IF %=1
SET DIK="^QA(748.25,"_DA(1)_",1,"
DO ^DIK
WRITE !!,">> Question removed << "
HANG 2
QUIT
End DoDot:2
GOTO DIS
+26 GOTO DIS
End DoDot:1
if $DATA(STOP)
GOTO EXIT
+27 ;
EDITALL IF $ORDER(^QA(748.3,"B",SURVEY,0))]""
WRITE *7,!!,"This survey has data associated with it and the question content",!,"may not be changed.",!
HANG 2
GOTO EN^QAPEDIT
+1 SET DA(1)=SURVEY
+2 IF ACTION="E"
KILL OUT
SET QAPHDR="Survey Name: "_SUBJ
WRITE @IOF,!
XECUTE QAPBAR
SET QAPHDR="Edit All Questions Sequentially"
XECUTE QAPBAR
KILL ^TMP($JOB)
+3 IF ACTION="E"
IF $ORDER(^QA(748.25,"E",SURVEY,0))=""
WRITE !!?10,"This survey has no questions.",!
HANG 2
GOTO EN^QAPEDIT
+4 IF ACTION="E"
FOR QAPQN=0:0
SET QAPQN=$ORDER(^QA(748.25,"E",DA(1),QAPQN))
if QAPQN=""
QUIT
FOR DA=0:0
SET DA=$ORDER(^QA(748.25,"E",DA(1),QAPQN,DA))
if DA=""
QUIT
Begin DoDot:1
+5 SET QAPHDR="Survey Name: "_SUBJ
WRITE @IOF,!
XECUTE QAPBAR
SET QAPHDR="Edit All Questions Sequentially"
XECUTE QAPBAR
+6 WRITE !,">> Question number: ",QAPQN,!
SET (DIC,DIE)="^QA(748.25,"_DA(1)_",1,"
SET DR=".055;.05;.015;.02"
DO ^DIE
DO RSQ
IF $DATA(DTOUT)
SET EXIT=1
QUIT
+7 IF $DATA(Y)
SET OUT=1
QUIT
+8 IF $PIECE(^QA(748.25,DA(1),1,DA,1),U)'="m"
DO KANS^QAPUTIL2
SET DR=".025///@;.027///@;3///@;1///@;2///@"
DO ^DIE
DO RSQ
+9 IF $PIECE(^QA(748.25,DA(1),1,DA,1),U)="m"
SET DR=".025;I X'=""l"" S Y=""@1"";D KANS^QAPUTIL2;.027;3;1;2;S Y=""@99"";@1;.027///@;3///@;1///@;2///@;.03;@99"
DO ^DIE
DO RSQ
IF $DATA(DTOUT)
SET EXIT=1
QUIT
+10 IF $DATA(Y)
SET OUT=1
QUIT
End DoDot:1
IF $DATA(OUT)!($DATA(EXIT))
SET (QAPQN,DA,DA(1))=999999
+11 IF $DATA(EXIT)
GOTO EXIT
+12 GOTO EN^QAPEDIT
+13 ;
EXIT GOTO EXIT^QAPUTIL
+1 ;
RSQ KILL DANS
FOR I=0:0
SET I=$ORDER(^QA(748.25,"E",SURVEY,I))
if I=""
QUIT
FOR J=0:0
SET J=$ORDER(^QA(748.25,"E",SURVEY,I,J))
if J=""
QUIT
SET DANS(I,J)=I
SET DANS(I)=I
+1 QUIT
