| 1 | RMPFETL ;DDC/KAW-ENTER/EDIT VETERAN ELIGIBILITY [ 06/16/95 3:06 PM ]
|
|---|
| 2 | ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
|
|---|
| 3 | ADD ;; input: DFN,RMPFTE,RMPFX
|
|---|
| 4 | ;;output: RMPFTE
|
|---|
| 5 | S P=$P(RMPFSYS,U,8) G ADD0:P
|
|---|
| 6 | I RMPFTE="" W !!,"*** ROES ELIGIBILITY CANNOT BE DETERMINED FROM THE DATABASE FOR THIS PATIENT ***" D ^RMPFETL1
|
|---|
| 7 | G END
|
|---|
| 8 | ADD0 G ADD1:P=2
|
|---|
| 9 | I '$D(^XUSEC("RMPF SUPERVISOR",DUZ)),'$D(^XUSEC("RMPF SYSTEM MANAGER",DUZ)) W:RMPFTE="" !!,"*** ONLY A ROES SUPERVISOR CAN ENTER/EDIT ELIGIBILITIES ***" G END
|
|---|
| 10 | ADD1 G ADD2:RMPFTE="" S AC="edit" D HEAD
|
|---|
| 11 | W !!,"Eligibility determined from the DHCP database: ",$P(RMPFTE,U,1)
|
|---|
| 12 | D WARN,SUB G END
|
|---|
| 13 | ADD2 S AC="enter" D HEAD
|
|---|
| 14 | W !!,"Eligibility for ROES orders cannot be determined from the DHCP database."
|
|---|
| 15 | D SUB G END
|
|---|
| 16 | EDIT ;; input: RMPFX,DFN,RMPFTE
|
|---|
| 17 | ;;output: RMPFTE
|
|---|
| 18 | S S2=$G(^RMPF(791810,RMPFX,2)),XX=$P(S2,U,2),YY=$P(S2,U,4)
|
|---|
| 19 | S P=$P(RMPFSYS,U,8) G END:'P,EDIT1:YY!(P=2)
|
|---|
| 20 | G EDIT1:$D(^XUSEC("RMPF SUPERVISOR",DUZ))!$D(^XUSEC("RMPF SYSTEM MANAGER",DUZ)),END
|
|---|
| 21 | EDIT1 S (SV,RMPFTE)=$P(^RMPF(791810.4,XX,0),U,1),AC="edit"
|
|---|
| 22 | D HEAD W !!,"Eligibility associated with this order: ",$P(RMPFTE,U,1)
|
|---|
| 23 | I 'YY S X="DHCP DATABASE" G EDIT2
|
|---|
| 24 | S X=$P(S2,U,3),X=$P($G(^VA(200,X,0)),U,1)
|
|---|
| 25 | EDIT2 W !?13,"Eligibility determined by: ",X
|
|---|
| 26 | I X="DHCP DATABASE" D WARN
|
|---|
| 27 | D SUB G END:$D(RMPFOUT),END:RMPFTE=SV
|
|---|
| 28 | S DR="2.02///"_$P(RMPFTE,U,1)_";2.03////"_DUZ_";2.04////1;2.05////"_DT
|
|---|
| 29 | S DIE="^RMPF(791810,",DA=RMPFX D ^DIE
|
|---|
| 30 | END K RMPFNAM,RMPFSSN,RMPFDOB,RMPFDOD,DIC,DA,DR,DIE,D0,DI,DQ,I,S2,SV,AC
|
|---|
| 31 | K DISYS,%,X,Y,XX,YY,AC,P Q
|
|---|
| 32 | SUB W !!,"Do you wish to ",AC," the eligibility? NO// "
|
|---|
| 33 | D READ Q:$D(RMPFOUT)
|
|---|
| 34 | 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
|
|---|
| 35 | S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G SUB1
|
|---|
| 36 | Q:"Nn"[Y
|
|---|
| 37 | E1 W ! S DIC=791810.4,DIC(0)="AEQM"
|
|---|
| 38 | S:$P(RMPFTE,U,1)'="" DIC("B")=$P(RMPFTE,U,1) D ^DIC Q:Y=-1
|
|---|
| 39 | S RMPFTE=$P(Y,U,2)_U_1
|
|---|
| 40 | Q
|
|---|
| 41 | HEAD D PAT^RMPFUTL
|
|---|
| 42 | W @IOF,!?29,"ENTER/EDIT ELIGIBILITY"
|
|---|
| 43 | W !!,"Patient: ",RMPFNAM,?40,"SSN: ",RMPFSSN,?63,"DOB: ",RMPFDOB,!
|
|---|
| 44 | F I=1:1:79 W "-"
|
|---|
| 45 | Q
|
|---|
| 46 | READ K RMPFOUT,RMPFQUT
|
|---|
| 47 | R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
|
|---|
| 48 | I Y?1"^".E S (RMPFOUT,Y)="" Q
|
|---|
| 49 | S:Y?1"?".E (RMPFQUT,Y)=""
|
|---|
| 50 | Q
|
|---|
| 51 | WARN W !!?11,"*** DO NOT EDIT UNLESS YOU ARE SURE YOU WANT TO SEND ***",!?11,"*** ANOTHER ELIGIBILITY TO THE DDC ***" Q
|
|---|
