source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFDE3.m@ 1780

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1RMPFDE3 ;DDC/PJU - RE ELIGIBILITY APPROVAL PROCESS ;7/8/04
2 ;;3.0;REMOTE ORDER/ENTRY SYSTEM;**1**;11/1/02
3 ;CALLED DURING OPTION RMPFDE2 TO PROCESS PENDING ELIGIBILITIES
4DISPLINE ;
5 ;RMPFX=req dt^pat name^pat SSN^sug el^dfn^req DUZ^MSG #
6 N EL,I,IEN,NM,RD,RMMSG,RMPFOUT,RMPFQUT,RMPFSEL,RO,RQ,SSN,X,Y
7 S RD=$P(RMPFX,U,1),NM=$P(RMPFX,U,2),SSN=$P(RMPFX,U,3)
8 S EL=$P(RMPFX,U,4),RQ=$P(RMPFX,U,6),RMMSG=$P(RMPFX,U,7)
9 S IEN=$P(RMPFX,U,8),RO=0
10 W !!!,?4,$$FMTE^XLFDT(RD),?24,NM
11 W ?43,$E(SSN,1,3),"-",$E(SSN,4,5),"-",$E(SSN,6,$L(SSN)),?56,EL
12 W ! F I=1:1:80 W "-"
13 W !?13,"Proposed Eligibility: ",EL
14 W !?23,"Entered By: ",$S(RQ:$P($G(^VA(200,RQ,0)),U,1),1:"UNKNOWN")
15 I RMMSG,$D(^XMB(3.9,RMMSG,2))>9 D
16 .W !?4,"Comments: " S I=6 F S I=$O(^XMB(3.9,RMMSG,2,I)) Q:'I D
17 ..W !,^XMB(3.9,RMMSG,2,I,0)
18A0 W !!,"<A>ccept, <E>dit, <R>eject or <RETURN> to listing: "
19 D:$G(RMPFVFLG)=1 READ^RMPFDE2 G END:$D(RMPFOUT)
20A1 I $D(RMPFQUT) D G A0
21 .W !!,"Enter an <A> to accept the proposed eligibility"
22 .W !?6,"an <E> to change to an acceptable eligibility"
23 .W !?6,"an <R> to reject the request back to ASPS or"
24 .W !?7,"a <RETURN> to exit back to the list."
25 G END:Y=""
26 S RMPFSEL=$E(Y,1),RMPFSEL=$$UP^XLFSTR(RMPFSEL)
27 S EL=$TR(EL," ","")
28 I "AER"'[RMPFSEL S RMPFQUT="" G A1
29 S DIE="^RMPF(791814,",DA=IEN K DR
30 I "AR"[RMPFSEL D D:'RO MAIL D:RO MSG G END
31 .I EL="",RMPFSEL="A" S RO=1 Q
32 .S DR=".04///"_$$FMADD^XLFDT(DT,730) ; 730 days to expire (2 yrs)
33 .S DR=DR_";2.01////"_EL_";2.03////"_DUZ_";2.04////"_DT
34 .I RMPFSEL="A" S DR=DR_";2.02////1"
35 .E S DR=DR_";2.02////0" ;reject
36 .D ^DIE
37 I "Ee"[RMPFSEL D G:$D(RMPFOUT) END D:'RO MAIL D:RO MSG G END
38 .W !
39 .F X=1:1:18 W !,X,?4,$P($T(@X),";;",2),?15,$P($T(@X),";;",3) ;list eligibilities
40A2 .S Y=""
41 .W !!,"Enter the line number of the preferred eligibility: "
42 .D:$G(RMPFVFLG)=1 READ^RMPFDE2
43 .G:$D(RMPFQUT) A2 Q:$D(RMPFOUT)
44 .I (Y<1)!(Y>18) S RO=1 Q
45 .S EL=$P($T(@Y),";;",2) I EL="" S RO=1 Q
46 .S DR=".04///"_$$FMADD^XLFDT(DT,730) ;730 days to expire (2 yrs)
47 .S DR=DR_";2.01////"_EL_";2.03////"_DUZ_";2.04////"_DT
48 .S DR=DR_";2.02////1" ;accept selected elig
49 .D ^DIE K DR
50END K DIE,DR,DA Q
51 ;
52MSG W !!,"*** No eligibility was selected. ***" R X:5 Q
53 ;
54MAIL ;;Send message to ASPS mail group
55 ;; input: EL,NM,SSN
56 ;;output: XMZ
57 S XMZ=""
58 S MG=$O(^XMB(3.8,"B","RMPF ROES UPDATES (ASPS)",0))
59 I 'MG D G MAILE
60 .W $C(7),!!,"*** MAIL GROUP - RMPF ROES UPDATES (ASPS) - NOT ESTABLISHED - NO MESSAGE SENT ***"
61 S XMY("G."_$P($G(^XMB(3.8,MG,0)),U,1))=""
62 S MG=$O(^XMB(3.8,"B","RMPF ROES UPDATES (PSAS)",0))
63 I 'MG W $C(7),!!,"*** MAIL GROUP - RMPF ROES UPDATES (PSAS) - NOT ESTABLISHED ***"
64 E S XMY("G."_$P($G(^XMB(3.8,MG,0)),U,1))=""
65 S XMY(DUZ)=""
66 S XMSUB="ROES PATIENT ELIGIBILITY UPDATE"
67 S XMDUZ=DUZ
68 D XMZ^XMA2 I XMZ<1 D G MAILE
69 .W !!,"*** MAIL Msg not created! Eligibility not updated! ***"
70 S XMTEXT(1)="ROES Patient Eligibility has been updated for the following patient:"
71 S XMTEXT(2)=" "
72 S XMTEXT(3)=NM_" "_SSN
73 S XMTEXT(4)=" "
74 S XMTEXT(5)="Eligibility: "_EL
75 S XMTEXT(6)=" "
76 S X="" S:$D(^RMPF(791814,IEN,2)) X=$P(^(2),U,2) S X=$S(X=1:"Has been Accepted",X=0:"Has been Rejected",1:"Is Waiting processing")
77 S XMTEXT(7)="Comment: "_X
78 S XMTEXT="XMTEXT("
79 D ^XMD W !!,"*** Message sent to user and Mail Group ***" H 2
80MAILE K MG,XMTEXT,XMDUZ,XMSUB,XMY
81 Q
82ELGLIST ;;LIST THE POSSIBILE ELIGIBILITIES
831 ;;SC;;Service Connected for Hearing Loss
842 ;;COM;;10 to 100 PerCent Service Connected Disability
853 ;;EP3;;Enrollment Priority Group 3 (PH, etc.)
864 ;;POW;;Prisoner of War
875 ;;AAA;;Aid and Attendance
886 ;;HB;;Housebound
897 ;;0CA;;0 PerCent SC and Priority Groups 5 or 7a
908 ;;NCA;;NSC_Pension or (NSC and Prioity Groups 5)
919 ;;SCV;;Special Category Veterans in Priority Group 6
9210 ;;CAN;;Canadian Vet
9311 ;;BRI;;Great Britain Vet
9412 ;;WWI;;World War I or Mexican Border War
9513 ;;NSC;;NSC and Priority Group 7c
9614 ;;BLR;;Blind Rehab
9715 ;;VOC;;Vocational Rehab
9816 ;;OGA;;Other Approved Federal Agencies
9917 ;;PG8;;Priority Group 8 (pays co-pay)
10018 ;;PG4;;Catastrophic Disability
Note: See TracBrowser for help on using the repository browser.