source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFETL.m@ 1789

Last change on this file since 1789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.3 KB
Line 
1RMPFETL ;DDC/KAW-ENTER/EDIT VETERAN ELIGIBILITY [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
3ADD ;; 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
8ADD0 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
10ADD1 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
13ADD2 S AC="enter" D HEAD
14 W !!,"Eligibility for ROES orders cannot be determined from the DHCP database."
15 D SUB G END
16EDIT ;; 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
21EDIT1 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)
25EDIT2 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
30END 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
32SUB W !!,"Do you wish to ",AC," the eligibility? NO// "
33 D READ Q:$D(RMPFOUT)
34SUB1 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
37E1 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
41HEAD 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
46READ 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
51WARN W !!?11,"*** DO NOT EDIT UNLESS YOU ARE SURE YOU WANT TO SEND ***",!?11,"*** ANOTHER ELIGIBILITY TO THE DDC ***" Q
Note: See TracBrowser for help on using the repository browser.