RMPFETL1 ;DDC/KAW-CONTINUATION OF RMPFETL [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
;; input: RMPFX,DFN
;;output: RMPFTE
G END:$P(RMPFSYS,U,13)
S SX=$G(^RMPF(791810,RMPFX,2)),SD=$P(SX,U,8) G START:'SD
I $D(^RMPF(791810,"AF",SD,RMPFX)) W $C(7),!!,"*** Eligibility Determination Awaiting Processing in PSAS ***" G END
START D ASK G END:$D(RMPFOUT),END:"Yy"'[Y
D GETEL G END:$D(RMPFOUT)
END S RMPFTE="" K RMPFOUT,RMPFQUT,SD,SX 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
ASK ;;Request eligibility determination
;; input: None
;;output: Y
W !!,"Request an Eligibility Determination from PSAS? YES// "
D READ Q:$D(RMPFOUT)
ASK1 I $D(RMPFQUT) W !!,"Enter a <Y> to submit a request for eligibility determination from PSAS",!?5,"an <N> or <RETURN> to exit." G ASK
S:Y="" Y="Y" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G ASK1
Q
GETEL ;;Set up proposed eligibility fields
;; input: RMPFX
;;output: RMPFTE
Q:'$D(DFN) Q:'DFN D PAT^RMPFUTL
S DIC=791810.4,DIC(0)="AEQM",DIC("A")="Select Proposed Eligibility: " W ! D ^DIC G GETELE:Y=-1 S RMPFTE=+Y,RMPFELG=$P(Y,U,2)
S X="NOW",%DT="T" D ^%DT S TD=Y
S DIE="^RMPF(791810,",DA=RMPFX,DR="2.06////"_RMPFTE_";2.07////"_DUZ_";2.08////"_TD D ^DIE
MAIL ;;Send message to PSAS mail group
;; input: RMPFELG,RMPFNAM
;;output:
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 - NO MESSAGE SENT ***" G GETELE
S XMY("G."_$P($G(^XMB(3.8,MG,0)),U,1))=""
S XMSUB="ROES PATIENT ELIGIBILITY DETERMINATION REQUEST"
S XMTEXT(1)="The Remote Order/Entry System requires that a patient be eligible"
S XMTEXT(2)="to receive a hearing aid, batteries or hearing aid services."
S XMTEXT(3)="An eligibility determination has been requested by ASPS for:"
S XMTEXT(4)=" "
S XMTEXT(5)=RMPFNAM_" SSN: "_RMPFSSN
S XMTEXT(6)=" "
S XMTEXT(7)="Proposed Eligibility: "_RMPFELG
S XMTEXT="XMTEXT("
D ^XMD W !!,"*** Message sent to PSAS Mail Group ***" H 2
GETELE K DIC,DIE,DA,DR,D0,DI,DISYS,DQ,TD,%DT,X,Y,RMPFNAM,RMPFSSN,RMPFDOB
K RMPFDOD,RMPFELG,XMZ,XMDUZ,XCNP,MG,D Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFETL1 2253 printed Sep 23, 2025@20:12:54 Page 2
RMPFETL1 ;DDC/KAW-CONTINUATION OF RMPFETL [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
+2 ;; input: RMPFX,DFN
+3 ;;output: RMPFTE
+4 if $PIECE(RMPFSYS,U,13)
GOTO END
+5 SET SX=$GET(^RMPF(791810,RMPFX,2))
SET SD=$PIECE(SX,U,8)
if 'SD
GOTO START
+6 IF $DATA(^RMPF(791810,"AF",SD,RMPFX))
WRITE $CHAR(7),!!,"*** Eligibility Determination Awaiting Processing in PSAS ***"
GOTO END
START DO ASK
if $DATA(RMPFOUT)
GOTO END
if "Yy"'[Y
GOTO END
+1 DO GETEL
if $DATA(RMPFOUT)
GOTO END
END SET RMPFTE=""
KILL RMPFOUT,RMPFQUT,SD,SX
QUIT
READ KILL RMPFOUT,RMPFQUT
+1 READ Y:DTIME
IF '$TEST
WRITE $CHAR(7)
READ Y:5
if Y="."
GOTO READ
if '$TEST
SET Y=U
+2 IF Y?1"^".E
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
ASK ;;Request eligibility determination
+1 ;; input: None
+2 ;;output: Y
+3 WRITE !!,"Request an Eligibility Determination from PSAS? YES// "
+4 DO READ
if $DATA(RMPFOUT)
QUIT
ASK1 IF $DATA(RMPFQUT)
WRITE !!,"Enter a <Y> to submit a request for eligibility determination from PSAS",!?5,"an <N> or <RETURN> to exit."
GOTO ASK
+1 if Y=""
SET Y="Y"
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO ASK1
+2 QUIT
GETEL ;;Set up proposed eligibility fields
+1 ;; input: RMPFX
+2 ;;output: RMPFTE
+3 if '$DATA(DFN)
QUIT
if 'DFN
QUIT
DO PAT^RMPFUTL
+4 SET DIC=791810.4
SET DIC(0)="AEQM"
SET DIC("A")="Select Proposed Eligibility: "
WRITE !
DO ^DIC
if Y=-1
GOTO GETELE
SET RMPFTE=+Y
SET RMPFELG=$PIECE(Y,U,2)
+5 SET X="NOW"
SET %DT="T"
DO ^%DT
SET TD=Y
+6 SET DIE="^RMPF(791810,"
SET DA=RMPFX
SET DR="2.06////"_RMPFTE_";2.07////"_DUZ_";2.08////"_TD
DO ^DIE
MAIL ;;Send message to PSAS mail group
+1 ;; input: RMPFELG,RMPFNAM
+2 ;;output:
+3 SET MG=$ORDER(^XMB(3.8,"B","RMPF ROES UPDATES (PSAS)",0))
+4 IF 'MG
WRITE $CHAR(7),!!,"*** MAIL GROUP RMPF ROES UPDATES (PSAS) NOT ESTABLISHED - NO MESSAGE SENT ***"
GOTO GETELE
+5 SET XMY("G."_$PIECE($GET(^XMB(3.8,MG,0)),U,1))=""
+6 SET XMSUB="ROES PATIENT ELIGIBILITY DETERMINATION REQUEST"
+7 SET XMTEXT(1)="The Remote Order/Entry System requires that a patient be eligible"
+8 SET XMTEXT(2)="to receive a hearing aid, batteries or hearing aid services."
+9 SET XMTEXT(3)="An eligibility determination has been requested by ASPS for:"
+10 SET XMTEXT(4)=" "
+11 SET XMTEXT(5)=RMPFNAM_" SSN: "_RMPFSSN
+12 SET XMTEXT(6)=" "
+13 SET XMTEXT(7)="Proposed Eligibility: "_RMPFELG
+14 SET XMTEXT="XMTEXT("
+15 DO ^XMD
WRITE !!,"*** Message sent to PSAS Mail Group ***"
HANG 2
GETELE KILL DIC,DIE,DA,DR,D0,DI,DISYS,DQ,TD,%DT,X,Y,RMPFNAM,RMPFSSN,RMPFDOB
+1 KILL RMPFDOD,RMPFELG,XMZ,XMDUZ,XCNP,MG,D
QUIT
