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