RMPFDD3 ;DDC/KAW-ENTER/EDIT ELIGIBILITY [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
;; input: DFN
;;output:
D PAT^RMPFUTL
W @IOF,!?29,"ENTER/EDIT ELIGIBILITY"
W !!,"Patient: ",RMPFNAM,?40,"SSN: ",RMPFSSN,?63,RMPFDOB,!
F I=1:1:79 W "-"
W !!,"Eligibility for ROES transactions cannot be determined from the DHCP database",!,"for this veteran."
E0 W !!,"Do you wish to enter an eligibility? YES// "
D READ G END:$D(RMPFOUT)
E01 I $D(RMPFQUT) W !!,"Enter a <Y> if you wish to select an eligibility",!?6,"a <N> if you wish to exit" G E0
S:Y="" Y="Y" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G E01
G END:"Nn"[Y
E1 W ! S DIC=791810.4,DIC(0)="AEQM" D ^DIC G END:Y=-1
S RMPFELG=+Y,RMPFELGD=$P(Y,U,2)
END Q
READ K RMPFOUT,RMPFQUT
R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
I Y?1U.E S (RMPFOUT,Y)="" Q
S:Y?1"?".E (RMPFQUT,Y)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDD3 888 printed Sep 23, 2025@20:12:05 Page 2
RMPFDD3 ;DDC/KAW-ENTER/EDIT ELIGIBILITY [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
+2 ;; input: DFN
+3 ;;output:
+4 DO PAT^RMPFUTL
+5 WRITE @IOF,!?29,"ENTER/EDIT ELIGIBILITY"
+6 WRITE !!,"Patient: ",RMPFNAM,?40,"SSN: ",RMPFSSN,?63,RMPFDOB,!
+7 FOR I=1:1:79
WRITE "-"
+8 WRITE !!,"Eligibility for ROES transactions cannot be determined from the DHCP database",!,"for this veteran."
E0 WRITE !!,"Do you wish to enter an eligibility? YES// "
+1 DO READ
if $DATA(RMPFOUT)
GOTO END
E01 IF $DATA(RMPFQUT)
WRITE !!,"Enter a <Y> if you wish to select an eligibility",!?6,"a <N> if you wish to exit"
GOTO E0
+1 if Y=""
SET Y="Y"
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO E01
+2 if "Nn"[Y
GOTO END
E1 WRITE !
SET DIC=791810.4
SET DIC(0)="AEQM"
DO ^DIC
if Y=-1
GOTO END
+1 SET RMPFELG=+Y
SET RMPFELGD=$PIECE(Y,U,2)
END QUIT
READ KILL RMPFOUT,RMPFQUT
+1 READ Y:DTIME
IF '$TEST
WRITE $CHAR(7)
READ Y:5
if Y="."
GOTO READ
if '$TEST
SET Y=U
+2 IF Y?1U.E
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
