58 lines
2.5 KiB
Mathematica
58 lines
2.5 KiB
Mathematica
RMPFDE1 ;DDC/KAW-ENTER/EDIT REQUEST FOR ELIGIBILITY DETERMINATION [ 06/16/95 3:06 PM ]
|
|
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
|
|
;; input: RMPFX
|
|
;;output: None
|
|
S DFN=$P(^RMPF(791810,RMPFX,0),U,4) W @IOF,! D DISP^RMPFDD,PAT^RMPFUTL
|
|
S X=$G(^RMPF(791810,RMPFX,2)),EL=$P(X,U,6),EU=$P(X,U,7),SE=$P(X,U,8)
|
|
I EL,$D(^RMPF(791810.4,EL,0)) S RMPFELG=$P(^(0),U,1)
|
|
I EU,$D(^VA(200,EU,0)) S EU=$P(^(0),U,1)
|
|
W ! F I=1:1:80 W "-"
|
|
W !?13,"Proposed Eligibility: ",RMPFELG
|
|
W !?23,"Entered By: ",EU
|
|
A0 W !!,"<A>ccept, <E>dit, <R>eject or <RETURN> for no action: "
|
|
D READ 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 edit the eligibility"
|
|
.W !?6,"an <R> to reject the order back to ASPS or"
|
|
.W !?7,"a <RETURN> to exit without action."
|
|
G END:Y="" S RMPFSEL=$E(Y,1) I "AaEeRr"'[RMPFSEL S RMPFQUT="" G A1
|
|
I "Aa"[RMPFSEL S DR="2.02////"_EL_";2.03////"_DUZ_";2.04////1;2.05////"_DT D SET G END
|
|
I "Rr"[RMPFSEL S DR=2.09 D SET G END
|
|
I "Ee"[RMPFSEL S DR="2.02;2.03////"_DUZ_";2.04////1;2.05////"_DT_";2.09" D SET G END
|
|
END K SE,DFN,RMPFNAM,RMPFDOB,RMPFDOD,RMPFSSN,RMPFELG,RMPFE,RMPFSEL,RMPFTE,EL,EU,I Q
|
|
SET ;; input: RMPFX,DR,SE,RMPFSEL
|
|
;;output: None
|
|
S S1=$P($G(^RMPF(791810,RMPFX,2)),U,2)
|
|
S DIE="^RMPF(791810,",DA=RMPFX D ^DIE
|
|
S SX=$G(^RMPF(791810,RMPFX,2)),S2=$P(SX,U,2),S3=$P(SX,U,9)
|
|
S S4="" I S2,$D(^RMPF(791810.4,S2,0)) S S4=$P(^(0),U,1)
|
|
I S2 S MS=$S("Aa"[RMPFSEL!(S1=S2):"Eligibility accepted as: "_S4,1:"Eligibility changed to: "_S4)
|
|
I 'S2 S MS=$S(S3'="":"Record rejected with NO ELIGIBILITY",1:"NO ACTION TAKEN")
|
|
W !!,MS
|
|
I $P(SX,U,2)="",$P(SX,U,9)="" G SETE
|
|
K ^RMPF(791810,"AF",SE,RMPFX) D MAIL
|
|
SETE K D,D0,DA,DI,DIC,DIE,DQ,DR,SX,X,S1,S2,S3,S4,MS Q
|
|
MAIL ;;Send message to ASPS mail group
|
|
;; input: MS,S3,RMPFNAM,RMPFSSN
|
|
;;output: None
|
|
S MG=$O(^XMB(3.8,"B","RMPF ROES UPDATES (ASPS)",0))
|
|
I 'MG W $C(7),!!,"*** MAIL GROUP RMPF ROES UPDATES (ASPS) NOT ESTABLISHED - NO MESSAGE SENT ***" G MAILE
|
|
S XMY("G."_$P($G(^XMB(3.8,MG,0)),U,1))=""
|
|
S XMSUB="ROES PATIENT ELIGIBILITY UPDATE"
|
|
S XMTEXT(1)="ROES Patient Eligibility has been updated for the following patient:"
|
|
S XMTEXT(2)=" "
|
|
S XMTEXT(3)=RMPFNAM_" "_RMPFSSN
|
|
S XMTEXT(4)=" "
|
|
S XMTEXT(5)=MS
|
|
S XMTEXT(6)=" "
|
|
S XMTEXT(7)="Comment: "_S3
|
|
S XMTEXT="XMTEXT("
|
|
D ^XMD W !!,"*** Message sent to ASPS Mail Group ***" H 2
|
|
MAILE K XCNP,XMDUZ,XMZ,S3,MS,MG,XMZ,XMDUZ,XCNP Q
|
|
READ K RMPFOUT,RMPFQUT
|
|
R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
|
|
I Y?1"^".E S (RMPFOUT,Y)="" Q
|
|
S:Y?1"?".E (RMPFQUT,Y)=""
|
|
Q
|