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 ---[H[J[2J[HQAPFILE 1127 printed Nov 22, 2024@17:48:17 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
