101 lines
3.9 KiB
Mathematica
101 lines
3.9 KiB
Mathematica
RMPFDE3 ;DDC/PJU - RE ELIGIBILITY APPROVAL PROCESS ;7/8/04
|
|
;;3.0;REMOTE ORDER/ENTRY SYSTEM;**1**;11/1/02
|
|
;CALLED DURING OPTION RMPFDE2 TO PROCESS PENDING ELIGIBILITIES
|
|
DISPLINE ;
|
|
;RMPFX=req dt^pat name^pat SSN^sug el^dfn^req DUZ^MSG #
|
|
N EL,I,IEN,NM,RD,RMMSG,RMPFOUT,RMPFQUT,RMPFSEL,RO,RQ,SSN,X,Y
|
|
S RD=$P(RMPFX,U,1),NM=$P(RMPFX,U,2),SSN=$P(RMPFX,U,3)
|
|
S EL=$P(RMPFX,U,4),RQ=$P(RMPFX,U,6),RMMSG=$P(RMPFX,U,7)
|
|
S IEN=$P(RMPFX,U,8),RO=0
|
|
W !!!,?4,$$FMTE^XLFDT(RD),?24,NM
|
|
W ?43,$E(SSN,1,3),"-",$E(SSN,4,5),"-",$E(SSN,6,$L(SSN)),?56,EL
|
|
W ! F I=1:1:80 W "-"
|
|
W !?13,"Proposed Eligibility: ",EL
|
|
W !?23,"Entered By: ",$S(RQ:$P($G(^VA(200,RQ,0)),U,1),1:"UNKNOWN")
|
|
I RMMSG,$D(^XMB(3.9,RMMSG,2))>9 D
|
|
.W !?4,"Comments: " S I=6 F S I=$O(^XMB(3.9,RMMSG,2,I)) Q:'I D
|
|
..W !,^XMB(3.9,RMMSG,2,I,0)
|
|
A0 W !!,"<A>ccept, <E>dit, <R>eject or <RETURN> to listing: "
|
|
D:$G(RMPFVFLG)=1 READ^RMPFDE2 G END:$D(RMPFOUT)
|
|
A1 I $D(RMPFQUT) D G A0
|
|
.W !!,"Enter an <A> to accept the proposed eligibility"
|
|
.W !?6,"an <E> to change to an acceptable eligibility"
|
|
.W !?6,"an <R> to reject the request back to ASPS or"
|
|
.W !?7,"a <RETURN> to exit back to the list."
|
|
G END:Y=""
|
|
S RMPFSEL=$E(Y,1),RMPFSEL=$$UP^XLFSTR(RMPFSEL)
|
|
S EL=$TR(EL," ","")
|
|
I "AER"'[RMPFSEL S RMPFQUT="" G A1
|
|
S DIE="^RMPF(791814,",DA=IEN K DR
|
|
I "AR"[RMPFSEL D D:'RO MAIL D:RO MSG G END
|
|
.I EL="",RMPFSEL="A" S RO=1 Q
|
|
.S DR=".04///"_$$FMADD^XLFDT(DT,730) ; 730 days to expire (2 yrs)
|
|
.S DR=DR_";2.01////"_EL_";2.03////"_DUZ_";2.04////"_DT
|
|
.I RMPFSEL="A" S DR=DR_";2.02////1"
|
|
.E S DR=DR_";2.02////0" ;reject
|
|
.D ^DIE
|
|
I "Ee"[RMPFSEL D G:$D(RMPFOUT) END D:'RO MAIL D:RO MSG G END
|
|
.W !
|
|
.F X=1:1:18 W !,X,?4,$P($T(@X),";;",2),?15,$P($T(@X),";;",3) ;list eligibilities
|
|
A2 .S Y=""
|
|
.W !!,"Enter the line number of the preferred eligibility: "
|
|
.D:$G(RMPFVFLG)=1 READ^RMPFDE2
|
|
.G:$D(RMPFQUT) A2 Q:$D(RMPFOUT)
|
|
.I (Y<1)!(Y>18) S RO=1 Q
|
|
.S EL=$P($T(@Y),";;",2) I EL="" S RO=1 Q
|
|
.S DR=".04///"_$$FMADD^XLFDT(DT,730) ;730 days to expire (2 yrs)
|
|
.S DR=DR_";2.01////"_EL_";2.03////"_DUZ_";2.04////"_DT
|
|
.S DR=DR_";2.02////1" ;accept selected elig
|
|
.D ^DIE K DR
|
|
END K DIE,DR,DA Q
|
|
;
|
|
MSG W !!,"*** No eligibility was selected. ***" R X:5 Q
|
|
;
|
|
MAIL ;;Send message to ASPS mail group
|
|
;; input: EL,NM,SSN
|
|
;;output: XMZ
|
|
S XMZ=""
|
|
S MG=$O(^XMB(3.8,"B","RMPF ROES UPDATES (ASPS)",0))
|
|
I 'MG D G MAILE
|
|
.W $C(7),!!,"*** MAIL GROUP - RMPF ROES UPDATES (ASPS) - NOT ESTABLISHED - NO MESSAGE SENT ***"
|
|
S XMY("G."_$P($G(^XMB(3.8,MG,0)),U,1))=""
|
|
S MG=$O(^XMB(3.8,"B","RMPF ROES UPDATES (PSAS)",0))
|
|
I 'MG W $C(7),!!,"*** MAIL GROUP - RMPF ROES UPDATES (PSAS) - NOT ESTABLISHED ***"
|
|
E S XMY("G."_$P($G(^XMB(3.8,MG,0)),U,1))=""
|
|
S XMY(DUZ)=""
|
|
S XMSUB="ROES PATIENT ELIGIBILITY UPDATE"
|
|
S XMDUZ=DUZ
|
|
D XMZ^XMA2 I XMZ<1 D G MAILE
|
|
.W !!,"*** MAIL Msg not created! Eligibility not updated! ***"
|
|
S XMTEXT(1)="ROES Patient Eligibility has been updated for the following patient:"
|
|
S XMTEXT(2)=" "
|
|
S XMTEXT(3)=NM_" "_SSN
|
|
S XMTEXT(4)=" "
|
|
S XMTEXT(5)="Eligibility: "_EL
|
|
S XMTEXT(6)=" "
|
|
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")
|
|
S XMTEXT(7)="Comment: "_X
|
|
S XMTEXT="XMTEXT("
|
|
D ^XMD W !!,"*** Message sent to user and Mail Group ***" H 2
|
|
MAILE K MG,XMTEXT,XMDUZ,XMSUB,XMY
|
|
Q
|
|
ELGLIST ;;LIST THE POSSIBILE ELIGIBILITIES
|
|
1 ;;SC;;Service Connected for Hearing Loss
|
|
2 ;;COM;;10 to 100 PerCent Service Connected Disability
|
|
3 ;;EP3;;Enrollment Priority Group 3 (PH, etc.)
|
|
4 ;;POW;;Prisoner of War
|
|
5 ;;AAA;;Aid and Attendance
|
|
6 ;;HB;;Housebound
|
|
7 ;;0CA;;0 PerCent SC and Priority Groups 5 or 7a
|
|
8 ;;NCA;;NSC_Pension or (NSC and Prioity Groups 5)
|
|
9 ;;SCV;;Special Category Veterans in Priority Group 6
|
|
10 ;;CAN;;Canadian Vet
|
|
11 ;;BRI;;Great Britain Vet
|
|
12 ;;WWI;;World War I or Mexican Border War
|
|
13 ;;NSC;;NSC and Priority Group 7c
|
|
14 ;;BLR;;Blind Rehab
|
|
15 ;;VOC;;Vocational Rehab
|
|
16 ;;OGA;;Other Approved Federal Agencies
|
|
17 ;;PG8;;Priority Group 8 (pays co-pay)
|
|
18 ;;PG4;;Catastrophic Disability
|