QAPDEM ;557/THM-ADD SURVEY DEMOGRAPHICS [ 06/19/95 1:44 PM ]
;;2.0;Survey Generator;;Jun 20, 1995
;
;called by QAPEDIT
Q ;enter properly
;
EN K DIC,DIE,DR,Y,STOP
W @IOF,! S QAPHDR="Subject: "_SUBJ X QAPBAR
S QAPHDR="Add/Edit Demographic Questions" X QAPBAR
;
DATA I $O(^QA(748.3,"B",SURVEY,0))]"" W *7,!!,"This survey has data associated with it and the demographic content",!,"may not be changed.",!!,"Press RETURN " R ANS:DTIME S:'$T STOP=1 G EXIT
W !
S X=SUBJ,(DIE,DIC)="^QA(748,",DIC(0)="QLM" D ^DIC S DA=+Y G:Y<0!($D(DTOUT)) EXIT
S DR=".01;1;I X=""s"" S Y=""@1"";I X=""p"" S Y=""@2"";S Y=""@99"";@1;3;S Y=""@99"";@2;2;@99;4",DR(3,748.33)=".01:1"
;add to subfile
W ! S DA(1)=+Y,DIC=DIC_DA(1)_",1,",DIC(0)="QAELM",DIC("P")=$P(^DD(748,3,0),U,2) D ^DIC I Y=-1 K DIC,DA G EXIT
S DIE=DIC S DA=+Y K DIC W !! D ^DIE G:$D(Y) EN I $D(DTOUT) S STOP=1 G EXIT
X CLEOP K FIND F DEMQUES=0:0 S DEMQUES=$O(^QA(748,SURVEY,1,DEMQUES)) Q:DEMQUES=""!(+DEMQUES=0)!($D(STOP)) S DEMDTA=^QA(748,SURVEY,1,DEMQUES,0) K STOP DO Q:$D(STOP)
.I $P(DEMDTA,U,2)="p",$P(DEMDTA,U,3)="" W !,*7,"You have entered a pointer type in question ",DEMQUES," and",!,"have not specified any file.",! S FIND=1
.I $P(DEMDTA,U,2)="s",$O(^QA(748,SURVEY,1,DEMQUES,0))="" W !,*7,"You have entered a 'set of codes' type in question ",DEMQUES,!,"and not entered any codes.",! S FIND=1
I $D(FIND) W !,"Press RETURN " R ANS:DTIME I '$T S STOP=1 Q
I '$D(STOP) G EN
;
EXIT Q ;kill variables in calling program
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPDEM 1509 printed Dec 13, 2024@02:38:13 Page 2
QAPDEM ;557/THM-ADD SURVEY DEMOGRAPHICS [ 06/19/95 1:44 PM ]
+1 ;;2.0;Survey Generator;;Jun 20, 1995
+2 ;
+3 ;called by QAPEDIT
+4 ;enter properly
QUIT
+5 ;
EN KILL DIC,DIE,DR,Y,STOP
+1 WRITE @IOF,!
SET QAPHDR="Subject: "_SUBJ
XECUTE QAPBAR
+2 SET QAPHDR="Add/Edit Demographic Questions"
XECUTE QAPBAR
+3 ;
DATA IF $ORDER(^QA(748.3,"B",SURVEY,0))]""
WRITE *7,!!,"This survey has data associated with it and the demographic content",!,"may not be changed.",!!,"Press RETURN "
READ ANS:DTIME
if '$TEST
SET STOP=1
GOTO EXIT
+1 WRITE !
+2 SET X=SUBJ
SET (DIE,DIC)="^QA(748,"
SET DIC(0)="QLM"
DO ^DIC
SET DA=+Y
if Y<0!($DATA(DTOUT))
GOTO EXIT
+3 SET DR=".01;1;I X=""s"" S Y=""@1"";I X=""p"" S Y=""@2"";S Y=""@99"";@1;3;S Y=""@99"";@2;2;@99;4"
SET DR(3,748.33)=".01:1"
+4 ;add to subfile
+5 WRITE !
SET DA(1)=+Y
SET DIC=DIC_DA(1)_",1,"
SET DIC(0)="QAELM"
SET DIC("P")=$PIECE(^DD(748,3,0),U,2)
DO ^DIC
IF Y=-1
KILL DIC,DA
GOTO EXIT
+6 SET DIE=DIC
SET DA=+Y
KILL DIC
WRITE !!
DO ^DIE
if $DATA(Y)
GOTO EN
IF $DATA(DTOUT)
SET STOP=1
GOTO EXIT
+7 XECUTE CLEOP
KILL FIND
FOR DEMQUES=0:0
SET DEMQUES=$ORDER(^QA(748,SURVEY,1,DEMQUES))
if DEMQUES=""!(+DEMQUES=0)!($DATA(STOP))
QUIT
SET DEMDTA=^QA(748,SURVEY,1,DEMQUES,0)
KILL STOP
Begin DoDot:1
+8 IF $PIECE(DEMDTA,U,2)="p"
IF $PIECE(DEMDTA,U,3)=""
WRITE !,*7,"You have entered a pointer type in question ",DEMQUES," and",!,"have not specified any file.",!
SET FIND=1
+9 IF $PIECE(DEMDTA,U,2)="s"
IF $ORDER(^QA(748,SURVEY,1,DEMQUES,0))=""
WRITE !,*7,"You have entered a 'set of codes' type in question ",DEMQUES,!,"and not entered any codes.",!
SET FIND=1
End DoDot:1
if $DATA(STOP)
QUIT
+10 IF $DATA(FIND)
WRITE !,"Press RETURN "
READ ANS:DTIME
IF '$TEST
SET STOP=1
QUIT
+11 IF '$DATA(STOP)
GOTO EN
+12 ;
EXIT ;kill variables in calling program
QUIT
