RMPFETL ;DDC/KAW-ENTER/EDIT VETERAN ELIGIBILITY [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
ADD ;; input: DFN,RMPFTE,RMPFX
;;output: RMPFTE
S P=$P(RMPFSYS,U,8) G ADD0:P
I RMPFTE="" W !!,"*** ROES ELIGIBILITY CANNOT BE DETERMINED FROM THE DATABASE FOR THIS PATIENT ***" D ^RMPFETL1
G END
ADD0 G ADD1:P=2
I '$D(^XUSEC("RMPF SUPERVISOR",DUZ)),'$D(^XUSEC("RMPF SYSTEM MANAGER",DUZ)) W:RMPFTE="" !!,"*** ONLY A ROES SUPERVISOR CAN ENTER/EDIT ELIGIBILITIES ***" G END
ADD1 G ADD2:RMPFTE="" S AC="edit" D HEAD
W !!,"Eligibility determined from the DHCP database: ",$P(RMPFTE,U,1)
D WARN,SUB G END
ADD2 S AC="enter" D HEAD
W !!,"Eligibility for ROES orders cannot be determined from the DHCP database."
D SUB G END
EDIT ;; input: RMPFX,DFN,RMPFTE
;;output: RMPFTE
S S2=$G(^RMPF(791810,RMPFX,2)),XX=$P(S2,U,2),YY=$P(S2,U,4)
S P=$P(RMPFSYS,U,8) G END:'P,EDIT1:YY!(P=2)
G EDIT1:$D(^XUSEC("RMPF SUPERVISOR",DUZ))!$D(^XUSEC("RMPF SYSTEM MANAGER",DUZ)),END
EDIT1 S (SV,RMPFTE)=$P(^RMPF(791810.4,XX,0),U,1),AC="edit"
D HEAD W !!,"Eligibility associated with this order: ",$P(RMPFTE,U,1)
I 'YY S X="DHCP DATABASE" G EDIT2
S X=$P(S2,U,3),X=$P($G(^VA(200,X,0)),U,1)
EDIT2 W !?13,"Eligibility determined by: ",X
I X="DHCP DATABASE" D WARN
D SUB G END:$D(RMPFOUT),END:RMPFTE=SV
S DR="2.02///"_$P(RMPFTE,U,1)_";2.03////"_DUZ_";2.04////1;2.05////"_DT
S DIE="^RMPF(791810,",DA=RMPFX D ^DIE
END K RMPFNAM,RMPFSSN,RMPFDOB,RMPFDOD,DIC,DA,DR,DIE,D0,DI,DQ,I,S2,SV,AC
K DISYS,%,X,Y,XX,YY,AC,P Q
SUB W !!,"Do you wish to ",AC," the eligibility? NO// "
D READ Q:$D(RMPFOUT)
SUB1 I $D(RMPFQUT) W !!,"Enter a <Y> if you wish to select an eligibility",!?5,"an <N> or <RETURN> if you wish to continue." G SUB
S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G SUB1
Q:"Nn"[Y
E1 W ! S DIC=791810.4,DIC(0)="AEQM"
S:$P(RMPFTE,U,1)'="" DIC("B")=$P(RMPFTE,U,1) D ^DIC Q:Y=-1
S RMPFTE=$P(Y,U,2)_U_1
Q
HEAD D PAT^RMPFUTL
W @IOF,!?29,"ENTER/EDIT ELIGIBILITY"
W !!,"Patient: ",RMPFNAM,?40,"SSN: ",RMPFSSN,?63,"DOB: ",RMPFDOB,!
F I=1:1:79 W "-"
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?1"^".E S (RMPFOUT,Y)="" Q
S:Y?1"?".E (RMPFQUT,Y)=""
Q
WARN W !!?11,"*** DO NOT EDIT UNLESS YOU ARE SURE YOU WANT TO SEND ***",!?11,"*** ANOTHER ELIGIBILITY TO THE DDC ***" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFETL 2386 printed Apr 09, 2024@21:39:04 Page 2
RMPFETL ;DDC/KAW-ENTER/EDIT VETERAN ELIGIBILITY [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
ADD ;; input: DFN,RMPFTE,RMPFX
+1 ;;output: RMPFTE
+2 SET P=$PIECE(RMPFSYS,U,8)
if P
GOTO ADD0
+3 IF RMPFTE=""
WRITE !!,"*** ROES ELIGIBILITY CANNOT BE DETERMINED FROM THE DATABASE FOR THIS PATIENT ***"
DO ^RMPFETL1
+4 GOTO END
ADD0 if P=2
GOTO ADD1
+1 IF '$DATA(^XUSEC("RMPF SUPERVISOR",DUZ))
IF '$DATA(^XUSEC("RMPF SYSTEM MANAGER",DUZ))
if RMPFTE=""
WRITE !!,"*** ONLY A ROES SUPERVISOR CAN ENTER/EDIT ELIGIBILITIES ***"
GOTO END
ADD1 if RMPFTE=""
GOTO ADD2
SET AC="edit"
DO HEAD
+1 WRITE !!,"Eligibility determined from the DHCP database: ",$PIECE(RMPFTE,U,1)
+2 DO WARN
DO SUB
GOTO END
ADD2 SET AC="enter"
DO HEAD
+1 WRITE !!,"Eligibility for ROES orders cannot be determined from the DHCP database."
+2 DO SUB
GOTO END
EDIT ;; input: RMPFX,DFN,RMPFTE
+1 ;;output: RMPFTE
+2 SET S2=$GET(^RMPF(791810,RMPFX,2))
SET XX=$PIECE(S2,U,2)
SET YY=$PIECE(S2,U,4)
+3 SET P=$PIECE(RMPFSYS,U,8)
if 'P
GOTO END
if YY!(P=2)
GOTO EDIT1
+4 if $DATA(^XUSEC("RMPF SUPERVISOR",DUZ))!$DATA(^XUSEC("RMPF SYSTEM MANAGER",DUZ))
GOTO EDIT1
GOTO END
EDIT1 SET (SV,RMPFTE)=$PIECE(^RMPF(791810.4,XX,0),U,1)
SET AC="edit"
+1 DO HEAD
WRITE !!,"Eligibility associated with this order: ",$PIECE(RMPFTE,U,1)
+2 IF 'YY
SET X="DHCP DATABASE"
GOTO EDIT2
+3 SET X=$PIECE(S2,U,3)
SET X=$PIECE($GET(^VA(200,X,0)),U,1)
EDIT2 WRITE !?13,"Eligibility determined by: ",X
+1 IF X="DHCP DATABASE"
DO WARN
+2 DO SUB
if $DATA(RMPFOUT)
GOTO END
if RMPFTE=SV
GOTO END
+3 SET DR="2.02///"_$PIECE(RMPFTE,U,1)_";2.03////"_DUZ_";2.04////1;2.05////"_DT
+4 SET DIE="^RMPF(791810,"
SET DA=RMPFX
DO ^DIE
END KILL RMPFNAM,RMPFSSN,RMPFDOB,RMPFDOD,DIC,DA,DR,DIE,D0,DI,DQ,I,S2,SV,AC
+1 KILL DISYS,%,X,Y,XX,YY,AC,P
QUIT
SUB WRITE !!,"Do you wish to ",AC," the eligibility? NO// "
+1 DO READ
if $DATA(RMPFOUT)
QUIT
SUB1 IF $DATA(RMPFQUT)
WRITE !!,"Enter a <Y> if you wish to select an eligibility",!?5,"an <N> or <RETURN> if you wish to continue."
GOTO SUB
+1 if Y=""
SET Y="N"
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO SUB1
+2 if "Nn"[Y
QUIT
E1 WRITE !
SET DIC=791810.4
SET DIC(0)="AEQM"
+1 if $PIECE(RMPFTE,U,1)'=""
SET DIC("B")=$PIECE(RMPFTE,U,1)
DO ^DIC
if Y=-1
QUIT
+2 SET RMPFTE=$PIECE(Y,U,2)_U_1
+3 QUIT
HEAD DO PAT^RMPFUTL
+1 WRITE @IOF,!?29,"ENTER/EDIT ELIGIBILITY"
+2 WRITE !!,"Patient: ",RMPFNAM,?40,"SSN: ",RMPFSSN,?63,"DOB: ",RMPFDOB,!
+3 FOR I=1:1:79
WRITE "-"
+4 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?1"^".E
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
WARN WRITE !!?11,"*** DO NOT EDIT UNLESS YOU ARE SURE YOU WANT TO SEND ***",!?11,"*** ANOTHER ELIGIBILITY TO THE DDC ***"
QUIT
