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