- QAPCHKST ;557/THM-CHECK IF SURVEY CAN BE RELEASED [ 05/04/95 9:53 AM ]
- ;;2.0;Survey Generator;;Jun 20, 1995
- ;called by input transform of STATUS in file 748 and QAPCOPY
- ;
- Q:$P(^QA(748,DA,0),U,4)="r"&('$D(QAPCOPY))
- S QLINE=7 X CLEOP1 W !,"Please wait while this survey is checked for missing critical data " H 1
- K NOPEN,CANCEL W !
- I $P(^QA(748,DA,0),U,3)="" W *7,!,"Last date for usage is missing" S NOPEN=1
- I $O(^QA(748,DA,1,0))="" W !,"Demographic data is missing" S NOPEN=1
- I $O(^QA(748,DA,1,0))="",$P(^QA(748,DA,0),U,8)="y" W " and demographics are mandatory" S CANCEL=1
- I $O(^QA(748,DA,1,0))="",$P(^QA(748,DA,0),U,8)'="y" W " (but demographics are not mandatory)" S NOPEN=1
- I $P(^QA(748,DA,0),U,6)="" W !,"Survey title is missing" S CANCEL=1
- I $O(^QA(748,DA,4,0))="" W !,"Survey instructions are missing" S CANCEL=1
- I '$D(^QA(748.25,DA,0))!($O(^QA(748.25,DA,1,0))="") W !,"There are no questions for this survey" S CANCEL=1
- I $O(^QA(748.25,DA,0))]"" F QNUM=0:0 S QNUM=$O(^QA(748.25,DA,1,QNUM)) Q:QNUM=""!(+QNUM=0) DO
- .S QAPXX=^QA(748.25,DA,1,QNUM,0),QAPQN=$P(QAPXX,U,2)
- .I $P(QAPXX,U,3)="","^w^y^t^"'[$G(^QA(748.25,DA,1,QNUM,1)) W !,"The answer type on question ",QAPQN," is not (a)lpha ,(n)umeric or (L)ikert" S CANCEL=1
- .I $P(QAPXX,U,2)="" W !,"There is no question number for IFN ",QNUM S CANCEL=1
- .I $D(^QA(748.25,DA,1,QNUM,1)),$P(^(1),U,1)="m",$P(QAPXX,U,3)'="l",$O(^QA(748.25,DA,1,QNUM,3,1))="" W !,"Question ",QAPQN," is multiple choice and has no answers" S CANCEL=1
- .I $O(^QA(748.25,DA,1,QNUM,2,0))="" W !,"Question ",QAPQN," has no question text" S CANCEL=1
- Q:$D(QAPCOPY) ;quit if copying a survey
- REL I $D(NOPEN),'$D(CANCEL) W *7,!!,"Perhaps this survey should not be released",!,"until this data is supplied.",!
- ;
- I $D(NOPEN),'$D(CANCEL) W !,"Do you want to release anyway" S %=2 D YN^DICN I %<0!(%=2) K X S STOP=1 Q
- I $D(%Y),%Y="?" X CLEOP1 W !,"Answer Y release the survey or N to leave it as is. " H 3 X CLEOP1 G REL
- I $D(%Y),%Y["??" X CLEOP1 W !,"If you answer Y, the survey will be released regardless of",!,"what non-critical information is missing. N will leave it as is.",!!,"Press RETURN " R ANS:DTIME S:'$T DTOUT=1 I '$D(DTOUT) X CLEOP1 G REL
- I $D(DTOUT) S STOP=1 Q
- I $D(CANCEL) W !!,*7,"This survey is missing important data and cannot be released",!,"until it is supplied.",!! K X H 3
- I $D(%),%=0 W !!,*7,"You must specifically answer Y or N. " H 2 X CLEOP1 G REL
- I '$D(CANCEL) W !!,"Survey released. ",! H 2
- K %,YY,NOPEN,ANS,CANCEL,QAPXX
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAPCHKST 2544 printed Jan 18, 2025@03:39:15 Page 2
- QAPCHKST ;557/THM-CHECK IF SURVEY CAN BE RELEASED [ 05/04/95 9:53 AM ]
- +1 ;;2.0;Survey Generator;;Jun 20, 1995
- +2 ;called by input transform of STATUS in file 748 and QAPCOPY
- +3 ;
- +4 if $PIECE(^QA(748,DA,0),U,4)="r"&('$DATA(QAPCOPY))
- QUIT
- +5 SET QLINE=7
- XECUTE CLEOP1
- WRITE !,"Please wait while this survey is checked for missing critical data "
- HANG 1
- +6 KILL NOPEN,CANCEL
- WRITE !
- +7 IF $PIECE(^QA(748,DA,0),U,3)=""
- WRITE *7,!,"Last date for usage is missing"
- SET NOPEN=1
- +8 IF $ORDER(^QA(748,DA,1,0))=""
- WRITE !,"Demographic data is missing"
- SET NOPEN=1
- +9 IF $ORDER(^QA(748,DA,1,0))=""
- IF $PIECE(^QA(748,DA,0),U,8)="y"
- WRITE " and demographics are mandatory"
- SET CANCEL=1
- +10 IF $ORDER(^QA(748,DA,1,0))=""
- IF $PIECE(^QA(748,DA,0),U,8)'="y"
- WRITE " (but demographics are not mandatory)"
- SET NOPEN=1
- +11 IF $PIECE(^QA(748,DA,0),U,6)=""
- WRITE !,"Survey title is missing"
- SET CANCEL=1
- +12 IF $ORDER(^QA(748,DA,4,0))=""
- WRITE !,"Survey instructions are missing"
- SET CANCEL=1
- +13 IF '$DATA(^QA(748.25,DA,0))!($ORDER(^QA(748.25,DA,1,0))="")
- WRITE !,"There are no questions for this survey"
- SET CANCEL=1
- +14 IF $ORDER(^QA(748.25,DA,0))]""
- FOR QNUM=0:0
- SET QNUM=$ORDER(^QA(748.25,DA,1,QNUM))
- if QNUM=""!(+QNUM=0)
- QUIT
- Begin DoDot:1
- +15 SET QAPXX=^QA(748.25,DA,1,QNUM,0)
- SET QAPQN=$PIECE(QAPXX,U,2)
- +16 IF $PIECE(QAPXX,U,3)=""
- IF "^w^y^t^"'[$GET(^QA(748.25,DA,1,QNUM,1))
- WRITE !,"The answer type on question ",QAPQN," is not (a)lpha ,(n)umeric or (L)ikert"
- SET CANCEL=1
- +17 IF $PIECE(QAPXX,U,2)=""
- WRITE !,"There is no question number for IFN ",QNUM
- SET CANCEL=1
- +18 IF $DATA(^QA(748.25,DA,1,QNUM,1))
- IF $PIECE(^(1),U,1)="m"
- IF $PIECE(QAPXX,U,3)'="l"
- IF $ORDER(^QA(748.25,DA,1,QNUM,3,1))=""
- WRITE !,"Question ",QAPQN," is multiple choice and has no answers"
- SET CANCEL=1
- +19 IF $ORDER(^QA(748.25,DA,1,QNUM,2,0))=""
- WRITE !,"Question ",QAPQN," has no question text"
- SET CANCEL=1
- End DoDot:1
- +20 ;quit if copying a survey
- if $DATA(QAPCOPY)
- QUIT
- REL IF $DATA(NOPEN)
- IF '$DATA(CANCEL)
- WRITE *7,!!,"Perhaps this survey should not be released",!,"until this data is supplied.",!
- +1 ;
- +2 IF $DATA(NOPEN)
- IF '$DATA(CANCEL)
- WRITE !,"Do you want to release anyway"
- SET %=2
- DO YN^DICN
- IF %<0!(%=2)
- KILL X
- SET STOP=1
- QUIT
- +3 IF $DATA(%Y)
- IF %Y="?"
- XECUTE CLEOP1
- WRITE !,"Answer Y release the survey or N to leave it as is. "
- HANG 3
- XECUTE CLEOP1
- GOTO REL
- +4 IF $DATA(%Y)
- IF %Y["??"
- XECUTE CLEOP1
- WRITE !,"If you answer Y, the survey will be released regardless of",!,"what non-critical information is missing. N will leave it as is.",!!,"Press RETURN "
- READ ANS:DTIME
- if '$TEST
- SET DTOUT=1
- IF '$DATA(DTOUT)
- XECUTE CLEOP1
- GOTO REL
- +5 IF $DATA(DTOUT)
- SET STOP=1
- QUIT
- +6 IF $DATA(CANCEL)
- WRITE !!,*7,"This survey is missing important data and cannot be released",!,"until it is supplied.",!!
- KILL X
- HANG 3
- +7 IF $DATA(%)
- IF %=0
- WRITE !!,*7,"You must specifically answer Y or N. "
- HANG 2
- XECUTE CLEOP1
- GOTO REL
- +8 IF '$DATA(CANCEL)
- WRITE !!,"Survey released. ",!
- HANG 2
- +9 KILL %,YY,NOPEN,ANS,CANCEL,QAPXX
- +10 QUIT