source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFDE1.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 2.5 KB
Line 
1RMPFDE1 ;DDC/KAW-ENTER/EDIT REQUEST FOR ELIGIBILITY DETERMINATION [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
3 ;; input: RMPFX
4 ;;output: None
5 S DFN=$P(^RMPF(791810,RMPFX,0),U,4) W @IOF,! D DISP^RMPFDD,PAT^RMPFUTL
6 S X=$G(^RMPF(791810,RMPFX,2)),EL=$P(X,U,6),EU=$P(X,U,7),SE=$P(X,U,8)
7 I EL,$D(^RMPF(791810.4,EL,0)) S RMPFELG=$P(^(0),U,1)
8 I EU,$D(^VA(200,EU,0)) S EU=$P(^(0),U,1)
9 W ! F I=1:1:80 W "-"
10 W !?13,"Proposed Eligibility: ",RMPFELG
11 W !?23,"Entered By: ",EU
12A0 W !!,"<A>ccept, <E>dit, <R>eject or <RETURN> for no action: "
13 D READ G END:$D(RMPFOUT)
14A1 I $D(RMPFQUT) D G A0
15 .W !!,"Enter an <A> to accept the proposed eligibility"
16 .W !?6,"an <E> to edit the eligibility"
17 .W !?6,"an <R> to reject the order back to ASPS or"
18 .W !?7,"a <RETURN> to exit without action."
19 G END:Y="" S RMPFSEL=$E(Y,1) I "AaEeRr"'[RMPFSEL S RMPFQUT="" G A1
20 I "Aa"[RMPFSEL S DR="2.02////"_EL_";2.03////"_DUZ_";2.04////1;2.05////"_DT D SET G END
21 I "Rr"[RMPFSEL S DR=2.09 D SET G END
22 I "Ee"[RMPFSEL S DR="2.02;2.03////"_DUZ_";2.04////1;2.05////"_DT_";2.09" D SET G END
23END K SE,DFN,RMPFNAM,RMPFDOB,RMPFDOD,RMPFSSN,RMPFELG,RMPFE,RMPFSEL,RMPFTE,EL,EU,I Q
24SET ;; input: RMPFX,DR,SE,RMPFSEL
25 ;;output: None
26 S S1=$P($G(^RMPF(791810,RMPFX,2)),U,2)
27 S DIE="^RMPF(791810,",DA=RMPFX D ^DIE
28 S SX=$G(^RMPF(791810,RMPFX,2)),S2=$P(SX,U,2),S3=$P(SX,U,9)
29 S S4="" I S2,$D(^RMPF(791810.4,S2,0)) S S4=$P(^(0),U,1)
30 I S2 S MS=$S("Aa"[RMPFSEL!(S1=S2):"Eligibility accepted as: "_S4,1:"Eligibility changed to: "_S4)
31 I 'S2 S MS=$S(S3'="":"Record rejected with NO ELIGIBILITY",1:"NO ACTION TAKEN")
32 W !!,MS
33 I $P(SX,U,2)="",$P(SX,U,9)="" G SETE
34 K ^RMPF(791810,"AF",SE,RMPFX) D MAIL
35SETE K D,D0,DA,DI,DIC,DIE,DQ,DR,SX,X,S1,S2,S3,S4,MS Q
36MAIL ;;Send message to ASPS mail group
37 ;; input: MS,S3,RMPFNAM,RMPFSSN
38 ;;output: None
39 S MG=$O(^XMB(3.8,"B","RMPF ROES UPDATES (ASPS)",0))
40 I 'MG W $C(7),!!,"*** MAIL GROUP RMPF ROES UPDATES (ASPS) NOT ESTABLISHED - NO MESSAGE SENT ***" G MAILE
41 S XMY("G."_$P($G(^XMB(3.8,MG,0)),U,1))=""
42 S XMSUB="ROES PATIENT ELIGIBILITY UPDATE"
43 S XMTEXT(1)="ROES Patient Eligibility has been updated for the following patient:"
44 S XMTEXT(2)=" "
45 S XMTEXT(3)=RMPFNAM_" "_RMPFSSN
46 S XMTEXT(4)=" "
47 S XMTEXT(5)=MS
48 S XMTEXT(6)=" "
49 S XMTEXT(7)="Comment: "_S3
50 S XMTEXT="XMTEXT("
51 D ^XMD W !!,"*** Message sent to ASPS Mail Group ***" H 2
52MAILE K XCNP,XMDUZ,XMZ,S3,MS,MG,XMZ,XMDUZ,XCNP Q
53READ K RMPFOUT,RMPFQUT
54 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
55 I Y?1"^".E S (RMPFOUT,Y)="" Q
56 S:Y?1"?".E (RMPFQUT,Y)=""
57 Q
Note: See TracBrowser for help on using the repository browser.