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