RMPFDE ;DDC/KAW-DISPLAY REQUESTS FOR ELIGIBILITY DETERMINATION ;07/06/01 9:25 AM
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**17,18**;07/06/01
K RMPFX,RMPRVIEW
S RMPFVFG=1
D HEAD1
D LIST
G:$D(RMPFOUT) END
G:$D(RMPRVIEW) RMPFDE
D LISTOT
I RMPFVFG D CONT
G:$D(RMPRVIEW) RMPFDE
;G RMPFDE:$D(RMPFX)
END K DDH,DFN,DISYS,EL,RD,RX,TT,VA,VADM,VAERR,Y
K RMPFOUT,RMPQOUT,I,%XX,%YY,Y Q
LIST ;;List active requests for eligibility determination
;; input: None
;;output: RMPFDS1
S (RD,TT)=0 K RMPFS1,RMPFX
L1 S RD=$O(^RMPF(791810,"AF",RD)) Q:'RD
S RX=0
L2 S RX=$O(^RMPF(791810,"AF",RD,RX)) G L1:'RX
G L2:'$D(^RMPF(791810,RX,0))
S DFN=$P(^(0),U,4)
D DEM^VADPT S Y=RD
D DD^%DT
S EL=$P($G(^RMPF(791810,RX,2)),U,6)
I EL,$D(^RMPF(791810.4,EL,0)) S EL=$P(^(0),U,1)
S TT=TT+1,RMPFS1(TT)=RX
I RMPFVFG,$Y>19 D Q:$D(RMPFOUT) Q:$D(RMPRVIEW)
.D CONT
.Q:$D(RMPFOUT)
.D HEAD1
I IOST?1"P-".E,$Y>(IOSL-5) D HEAD1
W !,$J(TT,2),?4,Y,?24,$E(VADM(1),1,16),?43,$P(VADM(2),U,2),?56,$E(EL,1,24)
G L2
LISTOT W !!,"Total Orders: ",TT
I IOST?1"P-".E W @IOF
Q
HEAD1 W @IOF,!?17,"ROES ORDERS PENDING ELIGIBILITY DETERMINATION"
W !,"Station: ",RMPFSTAP,?68,RMPFDAT
W ! F I=1:1:80 W "-"
W !?1,"#",?7,"Request Date",?26,"Patient Name"
W ?47,"SSN",?58,"Proposed Eligibility"
W !,"--",?4,"------------------",?24,"-----------------"
W ?43,"-----------",?56,"------------------------"
Q
CONT K RMPRVIEW
F I=1:1 Q:$Y>19 W !
CONT1 W !!,"Type the number of the order to process, <P>rint or <RETURN> to continue: "
D READ
Q:$D(RMPFOUT)
I $D(RMPFQUT) D G CONT1
.W !!,"Enter the number to the left of the order to select it for processing"
.W !?9,"a <P> to print the list or",!?11,"<RETURN> to continue."
Q:Y=""
I "Pp"[Y D QUE Q
I $D(RMPFS1(Y)) S RMPFX=RMPFS1(Y) D ^RMPFDE1 S RMPRVIEW=""
Q
QUE W ! S %ZIS="NPQ" D ^%ZIS G END:POP
I IO=IO(0),'$D(IO("S")) S RMPRVIEW="",RMPFVFG=1 G QUEE
I $D(IO("S")) S %ZIS="",IOP=ION D ^%ZIS D G QUEE
.S RMPFVFG=0
.D HEAD1,LIST,LISTOT
.D ^%ZISC
.S RMPRVIEW=""
.S RMPFVFG=1
S RMPFVFG=0
S ZTRTN="PRINT^RMPFDE",ZTSAVE("RMPF*")=""
S ZTIO=ION D ^%ZTLOAD
D HOME^%ZIS S RMPRVIEW="",RMPFVFG=1
W:$D(ZTSK) !!,"*** Request Queued ***" H 2
QUEE K %T,%ZIS,POP,ZTRTN,ZTSAVE,ZTIO,ZTSK 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
PRINT D HEAD1,LIST,LISTOT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDE 2453 printed Apr 09, 2024@21:39:07 Page 2
RMPFDE ;DDC/KAW-DISPLAY REQUESTS FOR ELIGIBILITY DETERMINATION ;07/06/01 9:25 AM
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**17,18**;07/06/01
+2 KILL RMPFX,RMPRVIEW
+3 SET RMPFVFG=1
+4 DO HEAD1
+5 DO LIST
+6 if $DATA(RMPFOUT)
GOTO END
+7 if $DATA(RMPRVIEW)
GOTO RMPFDE
+8 DO LISTOT
+9 IF RMPFVFG
DO CONT
+10 if $DATA(RMPRVIEW)
GOTO RMPFDE
+11 ;G RMPFDE:$D(RMPFX)
END KILL DDH,DFN,DISYS,EL,RD,RX,TT,VA,VADM,VAERR,Y
+1 KILL RMPFOUT,RMPQOUT,I,%XX,%YY,Y
QUIT
LIST ;;List active requests for eligibility determination
+1 ;; input: None
+2 ;;output: RMPFDS1
+3 SET (RD,TT)=0
KILL RMPFS1,RMPFX
L1 SET RD=$ORDER(^RMPF(791810,"AF",RD))
if 'RD
QUIT
+1 SET RX=0
L2 SET RX=$ORDER(^RMPF(791810,"AF",RD,RX))
if 'RX
GOTO L1
+1 if '$DATA(^RMPF(791810,RX,0))
GOTO L2
+2 SET DFN=$PIECE(^(0),U,4)
+3 DO DEM^VADPT
SET Y=RD
+4 DO DD^%DT
+5 SET EL=$PIECE($GET(^RMPF(791810,RX,2)),U,6)
+6 IF EL
IF $DATA(^RMPF(791810.4,EL,0))
SET EL=$PIECE(^(0),U,1)
+7 SET TT=TT+1
SET RMPFS1(TT)=RX
+8 IF RMPFVFG
IF $Y>19
Begin DoDot:1
+9 DO CONT
+10 if $DATA(RMPFOUT)
QUIT
+11 DO HEAD1
End DoDot:1
if $DATA(RMPFOUT)
QUIT
if $DATA(RMPRVIEW)
QUIT
+12 IF IOST?1"P-".E
IF $Y>(IOSL-5)
DO HEAD1
+13 WRITE !,$JUSTIFY(TT,2),?4,Y,?24,$EXTRACT(VADM(1),1,16),?43,$PIECE(VADM(2),U,2),?56,$EXTRACT(EL,1,24)
+14 GOTO L2
LISTOT WRITE !!,"Total Orders: ",TT
+1 IF IOST?1"P-".E
WRITE @IOF
+2 QUIT
HEAD1 WRITE @IOF,!?17,"ROES ORDERS PENDING ELIGIBILITY DETERMINATION"
+1 WRITE !,"Station: ",RMPFSTAP,?68,RMPFDAT
+2 WRITE !
FOR I=1:1:80
WRITE "-"
+3 WRITE !?1,"#",?7,"Request Date",?26,"Patient Name"
+4 WRITE ?47,"SSN",?58,"Proposed Eligibility"
+5 WRITE !,"--",?4,"------------------",?24,"-----------------"
+6 WRITE ?43,"-----------",?56,"------------------------"
+7 QUIT
CONT KILL RMPRVIEW
+1 FOR I=1:1
if $Y>19
QUIT
WRITE !
CONT1 WRITE !!,"Type the number of the order to process, <P>rint or <RETURN> to continue: "
+1 DO READ
+2 if $DATA(RMPFOUT)
QUIT
+3 IF $DATA(RMPFQUT)
Begin DoDot:1
+4 WRITE !!,"Enter the number to the left of the order to select it for processing"
+5 WRITE !?9,"a <P> to print the list or",!?11,"<RETURN> to continue."
End DoDot:1
GOTO CONT1
+6 if Y=""
QUIT
+7 IF "Pp"[Y
DO QUE
QUIT
+8 IF $DATA(RMPFS1(Y))
SET RMPFX=RMPFS1(Y)
DO ^RMPFDE1
SET RMPRVIEW=""
+9 QUIT
QUE WRITE !
SET %ZIS="NPQ"
DO ^%ZIS
if POP
GOTO END
+1 IF IO=IO(0)
IF '$DATA(IO("S"))
SET RMPRVIEW=""
SET RMPFVFG=1
GOTO QUEE
+2 IF $DATA(IO("S"))
SET %ZIS=""
SET IOP=ION
DO ^%ZIS
Begin DoDot:1
+3 SET RMPFVFG=0
+4 DO HEAD1
DO LIST
DO LISTOT
+5 DO ^%ZISC
+6 SET RMPRVIEW=""
+7 SET RMPFVFG=1
End DoDot:1
GOTO QUEE
+8 SET RMPFVFG=0
+9 SET ZTRTN="PRINT^RMPFDE"
SET ZTSAVE("RMPF*")=""
+10 SET ZTIO=ION
DO ^%ZTLOAD
+11 DO HOME^%ZIS
SET RMPRVIEW=""
SET RMPFVFG=1
+12 if $DATA(ZTSK)
WRITE !!,"*** Request Queued ***"
HANG 2
QUEE KILL %T,%ZIS,POP,ZTRTN,ZTSAVE,ZTIO,ZTSK
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
PRINT DO HEAD1
DO LIST
DO LISTOT
QUIT
