QAPFILE.m

QAPFILE ;557/THM-POPULATE THE DEMOGRAPHIC REFERENCE FILE [ 06/19/95  11:59 AM ]

 ;;2.0;Survey Generator;;Jun 20, 1995

 ;

 D SCREEN^QAPUTIL

EN I $D(DUZ)#2=0 W !!,*7,"Your DUZ is missing !   " H 2 G EXIT

 I '$D(DUZ(0)) W !!,*7,"Your DUZ(0) is missing !   " H 2 G EXIT

 ;

BEGIN W @IOF,! S QAPHDR="Populate the Demographic Reference File" X QAPBAR W !!

 I DUZ(0)'="@" W !!,*7,"Programmer access required for this program !   " H 2 G EXIT

 W !,"Enter DEMOGRAPHIC REFERENCE FILE NAME: "  R X:DTIME I X[U!(X="") G EXIT

 S DLAYGO=748.2,DIC="^QA(748.2,",DIC(0)="EQLMZ"

 I X["?" S IOTM=1,IOBM=24 W @TOPBOT,@IOF,! D ^DIC G:$D(DTOUT) EXIT W !!,"Press RETURN  " R ANS:DTIME G:'$T EXIT S IOTM=8,IOBM=24 W @TOPBOT G BEGIN

 D ^DIC G:X=""!(X[U) EXIT S DA=+Y I +Y<0 H 1 G EN

 I $P(Y,U,3)'=1 S DR=".01",DIE=DIC W !! D ^DIE G EN

 ;

EXIT G EXIT^QAPUTIL

 ;

SCREEN ;screen any user file selections on demographics

 ;they are not allowed to use files they have no normal access to

 S QAPY=Y,QAPY=+$P($G(^QA(748.2,+QAPY,0)),U,1)

 S PROTECT=$G(^DIC(+QAPY,0,"RD"))

 I DUZ(0)="@"!(DUZ(0)[PROTECT) ;set $T

 K PROTECT,DIC("S"),QAPY Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---QAPFILE   1127     printed  Apr 09, 2024@21:41:03                                                                                                                                                                                                     Page 2

QAPFILE   ;557/THM-POPULATE THE DEMOGRAPHIC REFERENCE FILE [ 06/19/95  11:59 AM ]

 +1       ;;2.0;Survey Generator;;Jun 20, 1995

 +2       ;

 +3        DO SCREEN^QAPUTIL

EN         IF $DATA(DUZ)#2=0

               WRITE !!,*7,"Your DUZ is missing !   "

               HANG 2

               GOTO EXIT

 +1        IF '$DATA(DUZ(0))

               WRITE !!,*7,"Your DUZ(0) is missing !   "

               HANG 2

               GOTO EXIT

 +2       ;

BEGIN      WRITE @IOF,!

           SET QAPHDR="Populate the Demographic Reference File"

           XECUTE QAPBAR

           WRITE !!

 +1        IF DUZ(0)'="@"

               WRITE !!,*7,"Programmer access required for this program !   "

               HANG 2

               GOTO EXIT

 +2        WRITE !,"Enter DEMOGRAPHIC REFERENCE FILE NAME: "

           READ X:DTIME

           IF X[U!(X="")

               GOTO EXIT

 +3        SET DLAYGO=748.2

           SET DIC="^QA(748.2,"

           SET DIC(0)="EQLMZ"

 +4        IF X["?"

               SET IOTM=1

               SET IOBM=24

               WRITE @TOPBOT,@IOF,!

               DO ^DIC

               if $DATA(DTOUT)

                   GOTO EXIT

               WRITE !!,"Press RETURN  "

               READ ANS:DTIME

               if '$TEST

                   GOTO EXIT

               SET IOTM=8

               SET IOBM=24

               WRITE @TOPBOT

               GOTO BEGIN

 +5        DO ^DIC

           if X=""!(X[U)

               GOTO EXIT

           SET DA=+Y

           IF +Y<0

               HANG 1

               GOTO EN

 +6        IF $PIECE(Y,U,3)'=1

               SET DR=".01"

               SET DIE=DIC

               WRITE !!

               DO ^DIE

               GOTO EN

 +7       ;

EXIT       GOTO EXIT^QAPUTIL

 +1       ;

SCREEN    ;screen any user file selections on demographics

 +1       ;they are not allowed to use files they have no normal access to

 +2        SET QAPY=Y

           SET QAPY=+$PIECE($GET(^QA(748.2,+QAPY,0)),U,1)

 +3        SET PROTECT=$GET(^DIC(+QAPY,0,"RD"))

 +4       ;set $T

           IF DUZ(0)="@"!(DUZ(0)[PROTECT)

 +5        KILL PROTECT,DIC("S"),QAPY

           QUIT