RMPRDP ;PHX/HNC-RECORD PICKUP AND DELIVERY CHARGES ;8/29/1994
;;3.0;PROSTHETICS;**24,34,41,62**;Feb 09, 1996
;RVD patch #62 - PCE interface
EN ;ENTRY POINT FOR PICKUP AND DELIVERY. CALLED FROM RMPROP.
K ^TMP($J)
D DIV4^RMPRSIT G:$D(X) EXIT
S PRCS("A")="Select OBLIGATION NUMBER: " D EN1^PRCS58 G:Y=-1 EXIT S RMPROB=$P(Y,U,2) K PRCS("A") D BAL^RMPRPSC
A S RMPRF=99 W !,"This will Post Pickup and Delivery Charges to the 1358 and 10-2319 ",!
S %=1 R "Do you wish to Continue" D YN^DICN S RMPRACT=$S(%=-1:"EXIT",%=1:"ADD",%=2:"EXIT",%=0:"HLP",1:"EXIT") K:(%=2)!(%=-1) RMPROB G @RMPRACT
ADD D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT S RMPRFLAG=1 S RMPRBAC1=1 D ^RMPRPAT I $D(RMPRKILL) W !,"Deleted..." G EXIT
S X=DT,DIC="^RMPR(664,",DIC(0)="AEQML",DLAYGO=664,DIC("DR")="1////^S X=RMPRDFN" K DINUM,DD,DO D FILE^DICN K DLAYGO Q:Y<0 S (RMPRK,RMPRA)=+Y S $P(^RMPR(664,+Y,0),U,14)=RMPR("STA")
;added for PSAS HCPCS prompt
HC K DIR,Y,DA S DIR(0)="660,4.5",DIR("A")="Enter PSAS HCPCS" D ^DIR G:$D(DUOUT)!($D(DTOUT)) KILL I X="" W $C(7)," ??" G HC
S (X,RMHCPC)=+Y,RMTYPE="X",RDA=RMHCPC_"^"_RMTYPE_"^C^"_664
CPT D CPT^RMPRCPTU(RDA)
S DIE=DIC,DA=RMPRA,DR="4;10////^S X=DUZ;11R~UNIT COST;14REMARKS" D ^DIE
I $D(DTOUT)!($D(Y)'=0) W !,$C(7),$C(7),"Please Try Later!" G KILL
PD K DIR,Y,DA S DIR(0)="660,6.5",DIR("A")="Select PICKUP OR DELIVERY" D ^DIR G:$D(DUOUT)!($D(DTOUT)) KILL I X="" W $C(7)," ??" G PD
S RMPRPD=Y
PC K DIR,Y S DIR(0)="660,62" D ^DIR G:$D(DUOUT)!($D(DTOUT)) KILL S RMPREL=Y
SC K DIR I RMPREL=4 S DIR(0)="660,63" D ^DIR G:$D(DTOUT)!($D(DUOUT)) KILL S RMPRSE=Y K DIR
POST S %=2 R !,"Are you ready to POST to IFCAP and 10-2319 now" D YN^DICN G:$D(DTOUT) KILL G:%=1 FILE G:%=-1 DEL
W !!,"This will post an Est. $",$J($P(^RMPR(664,RMPRA,0),U,10),0,2)," on the 1358 Transaction and,",!,"$",$J($P(^(0),U,10),0,2)," on the 10-2319 Record.",!,"Type '^' to delete and exit.",! G POST
FILE W !,"Posting Now..."
S X=RMPROB_U_DT_U_$P(^RMPR(664,RMPRA,0),U,10)_U_U_$E($P(RMPRNAM,",",1),1,6)_","_$E(RMPRSSN,6,9)_U_$P(^(0),U,13)
S PRCS("TYPE")="FB" K DO,DD,D0 D EN2^PRCS58 G:+Y'=1 ERROR S RMPRTN=$P(Y,U,2),RMPRTRN=$P(^PRC(424,RMPRTN,0),U,1)
W !?5,"1358 Transaction has been assigned Number: ",RMPRTRN
;I $Y>18 K DIR S DIR(0)="FAO^0:0",DIR("A")="Press 'RETURN' to continue." D ^DIR K DIR
S RMPRV=$P(^RMPR(664,RMPRA,0),U,4),$P(^RMPR(664,RMPRA,0),U,7)=RMPRTRN,$P(^RMPR(664,RMPRA,0),U,6)=PRCSCPAN S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
S X=DT,DIC="^RMPR(660,",DIC(0)="LQ",X=DT,DLAYGO=660 K DINUM,DO,DD D FILE^DICN S RMPR660=+Y K DLAYGO
S ^RMPR(660,RMPR660,0)=DT_U_RMPRDFN_U_DT_U_"X"_"^^^^^"_RMPRV_U_RMPR("STA")_"^^^9^C^^"_$P(^RMPR(664,RMPRA,0),U,10)_U_$P(^RMPR(664,RMPRA,0),U,10)_U_$P(^(0),U,13)_"^^^^^^^^"_RMPRPD_U_DUZ
S ^RMPR(660,RMPR660,1)=RMPRTRN_"^^^"_RMHCPC_"^^"_RMCPT,^("AM")=U_U_RMPREL_U_$S($D(RMPRSE):RMPRSE,1:"")
L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G DIK60
S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1
S $P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
S $P(^RMPR(660,RMPR660,"AMS"),U,1)=RMPRG
DIK60 S DIK="^RMPR(660,",DA=RMPR660 D IX1^DIK
S $P(^RMPR(664,RMPRA,0),U,3)=RMPROB,$P(^(0),U,12)=RMPR660,$P(^RMPR(664,RMPRA,2),U,4)="OTHER" S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
;
W !?5,"Updated 10-2319 Record"
;
;set temp global for suspense link, added in patch #62
S ^TMP($J,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$G(RMPRDFN)
D LINK^RMPRS
G EXIT
DEL S %=2 R !,"Do you want to Delete this Transaction" D YN^DICN G:%=1!(%<0) KILL I %=0 W !,"Enter `YES` to delete the transaction, `NO` to continue."
G POST
HLP W !,"This will create a 1358 Daily Transaction and post to Veteran's 10-2319 Record that AMIS will be counted from.",! G A
ERROR W !,$C(7),$C(7),?5,"*** PLEASE CONTACT YOUR FISCAL SERVICE ***",!,?5,Y
KILL S DA=RMPRK,DIK="^RMPR(664," D ^DIK K DIR W !,$C(7),?20,"Deleted..."
S DIR(0)="E" D ^DIR
EXIT K RMPRKILL,RMPRF,DIR,PRCSIP,RMPRDOB,RMPRFLAG,PRCSCPAN,PRCS("TYPE"),RMPRSE,RMPRV,DA,%,DIE,DIRUT,DTOUT,RMPRACT,RMPREL,RMPRK,RMPRTN,RMPRTRN,RMPRA,RMPRDFN,RMPRNAM,RMPRSSN,RMPRPD,RMPRSC,RMPRPC,RMPR660,DIK,DIC,DR,Y
I $D(RMPROB) W @IOF D PRCS^RMPRPSC G:X'["^" A
K ^TMP($J)
K RMPROB,PRC,PRCS,RBL,RDA,RVA,RX,RMCPT,RMHCPC,RMPRBAC1,RMPRBACK,RMPRSSNE,PRCRI Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRDP 4265 printed Apr 09, 2024@21:40:52 Page 2
RMPRDP ;PHX/HNC-RECORD PICKUP AND DELIVERY CHARGES ;8/29/1994
+1 ;;3.0;PROSTHETICS;**24,34,41,62**;Feb 09, 1996
+2 ;RVD patch #62 - PCE interface
EN ;ENTRY POINT FOR PICKUP AND DELIVERY. CALLED FROM RMPROP.
+1 KILL ^TMP($JOB)
+2 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+3 SET PRCS("A")="Select OBLIGATION NUMBER: "
DO EN1^PRCS58
if Y=-1
GOTO EXIT
SET RMPROB=$PIECE(Y,U,2)
KILL PRCS("A")
DO BAL^RMPRPSC
A SET RMPRF=99
WRITE !,"This will Post Pickup and Delivery Charges to the 1358 and 10-2319 ",!
+1 SET %=1
READ "Do you wish to Continue"
DO YN^DICN
SET RMPRACT=$SELECT(%=-1:"EXIT",%=1:"ADD",%=2:"EXIT",%=0:"HLP",1:"EXIT")
if (%=2)!(%=-1)
KILL RMPROB
GOTO @RMPRACT
ADD DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
GOTO EXIT
SET RMPRFLAG=1
SET RMPRBAC1=1
DO ^RMPRPAT
IF $DATA(RMPRKILL)
WRITE !,"Deleted..."
GOTO EXIT
+1 SET X=DT
SET DIC="^RMPR(664,"
SET DIC(0)="AEQML"
SET DLAYGO=664
SET DIC("DR")="1////^S X=RMPRDFN"
KILL DINUM,DD,DO
DO FILE^DICN
KILL DLAYGO
if Y<0
QUIT
SET (RMPRK,RMPRA)=+Y
SET $PIECE(^RMPR(664,+Y,0),U,14)=RMPR("STA")
+2 ;added for PSAS HCPCS prompt
HC KILL DIR,Y,DA
SET DIR(0)="660,4.5"
SET DIR("A")="Enter PSAS HCPCS"
DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO KILL
IF X=""
WRITE $CHAR(7)," ??"
GOTO HC
+1 SET (X,RMHCPC)=+Y
SET RMTYPE="X"
SET RDA=RMHCPC_"^"_RMTYPE_"^C^"_664
CPT DO CPT^RMPRCPTU(RDA)
+1 SET DIE=DIC
SET DA=RMPRA
SET DR="4;10////^S X=DUZ;11R~UNIT COST;14REMARKS"
DO ^DIE
+2 IF $DATA(DTOUT)!($DATA(Y)'=0)
WRITE !,$CHAR(7),$CHAR(7),"Please Try Later!"
GOTO KILL
PD KILL DIR,Y,DA
SET DIR(0)="660,6.5"
SET DIR("A")="Select PICKUP OR DELIVERY"
DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO KILL
IF X=""
WRITE $CHAR(7)," ??"
GOTO PD
+1 SET RMPRPD=Y
PC KILL DIR,Y
SET DIR(0)="660,62"
DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO KILL
SET RMPREL=Y
SC KILL DIR
IF RMPREL=4
SET DIR(0)="660,63"
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO KILL
SET RMPRSE=Y
KILL DIR
POST SET %=2
READ !,"Are you ready to POST to IFCAP and 10-2319 now"
DO YN^DICN
if $DATA(DTOUT)
GOTO KILL
if %=1
GOTO FILE
if %=-1
GOTO DEL
+1 WRITE !!,"This will post an Est. $",$JUSTIFY($PIECE(^RMPR(664,RMPRA,0),U,10),0,2)," on the 1358 Transaction and,",!,"$",$JUSTIFY($PIECE(^(0),U,10),0,2)," on the 10-2319 Record.",!,"Type '^' to delete and exit.",!
GOTO POST
FILE WRITE !,"Posting Now..."
+1 SET X=RMPROB_U_DT_U_$PIECE(^RMPR(664,RMPRA,0),U,10)_U_U_$EXTRACT($PIECE(RMPRNAM,",",1),1,6)_","_$EXTRACT(RMPRSSN,6,9)_U_$PIECE(^(0),U,13)
+2 SET PRCS("TYPE")="FB"
KILL DO,DD,D0
DO EN2^PRCS58
if +Y'=1
GOTO ERROR
SET RMPRTN=$PIECE(Y,U,2)
SET RMPRTRN=$PIECE(^PRC(424,RMPRTN,0),U,1)
+3 WRITE !?5,"1358 Transaction has been assigned Number: ",RMPRTRN
+4 ;I $Y>18 K DIR S DIR(0)="FAO^0:0",DIR("A")="Press 'RETURN' to continue." D ^DIR K DIR
+5 SET RMPRV=$PIECE(^RMPR(664,RMPRA,0),U,4)
SET $PIECE(^RMPR(664,RMPRA,0),U,7)=RMPRTRN
SET $PIECE(^RMPR(664,RMPRA,0),U,6)=PRCSCPAN
SET DA=RMPRA
SET DIK="^RMPR(664,"
DO IX1^DIK
+6 SET X=DT
SET DIC="^RMPR(660,"
SET DIC(0)="LQ"
SET X=DT
SET DLAYGO=660
KILL DINUM,DO,DD
DO FILE^DICN
SET RMPR660=+Y
KILL DLAYGO
+7 SET ^RMPR(660,RMPR660,0)=DT_U_RMPRDFN_U_DT_U_"X"_"^^^^^"_RMPRV_U_RMPR("STA")_"^^^9^C^^"_$PIECE(^RMPR(664,RMPRA,0),U,10)_U_$PIECE(^RMPR(664,RMPRA,0),U,10)_U_$PIECE(^(0),U,13)_"^^^^^^^^"_RMPRPD_U_DUZ
+8 SET ^RMPR(660,RMPR660,1)=RMPRTRN_"^^^"_RMHCPC_"^^"_RMCPT
SET ^("AM")=U_U_RMPREL_U_$SELECT($DATA(RMPRSE):RMPRSE,1:"")
+9 LOCK +^RMPR(669.9,RMPRSITE,0):999
IF $TEST=0
SET RMPRG=DT_99
GOTO DIK60
+10 SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)
SET RMPRG=RMPRG-1
+11 SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG
LOCK -^RMPR(669.9,RMPRSITE,0)
+12 SET $PIECE(^RMPR(660,RMPR660,"AMS"),U,1)=RMPRG
DIK60 SET DIK="^RMPR(660,"
SET DA=RMPR660
DO IX1^DIK
+1 SET $PIECE(^RMPR(664,RMPRA,0),U,3)=RMPROB
SET $PIECE(^(0),U,12)=RMPR660
SET $PIECE(^RMPR(664,RMPRA,2),U,4)="OTHER"
SET DA=RMPRA
SET DIK="^RMPR(664,"
DO IX1^DIK
+2 ;
+3 WRITE !?5,"Updated 10-2319 Record"
+4 ;
+5 ;set temp global for suspense link, added in patch #62
+6 SET ^TMP($JOB,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$GET(RMPRDFN)
+7 DO LINK^RMPRS
+8 GOTO EXIT
DEL SET %=2
READ !,"Do you want to Delete this Transaction"
DO YN^DICN
if %=1!(%<0)
GOTO KILL
IF %=0
WRITE !,"Enter `YES` to delete the transaction, `NO` to continue."
+1 GOTO POST
HLP WRITE !,"This will create a 1358 Daily Transaction and post to Veteran's 10-2319 Record that AMIS will be counted from.",!
GOTO A
ERROR WRITE !,$CHAR(7),$CHAR(7),?5,"*** PLEASE CONTACT YOUR FISCAL SERVICE ***",!,?5,Y
KILL SET DA=RMPRK
SET DIK="^RMPR(664,"
DO ^DIK
KILL DIR
WRITE !,$CHAR(7),?20,"Deleted..."
+1 SET DIR(0)="E"
DO ^DIR
EXIT KILL RMPRKILL,RMPRF,DIR,PRCSIP,RMPRDOB,RMPRFLAG,PRCSCPAN,PRCS("TYPE"),RMPRSE,RMPRV,DA,%,DIE,DIRUT,DTOUT,RMPRACT,RMPREL,RMPRK,RMPRTN,RMPRTRN,RMPRA,RMPRDFN,RMPRNAM,RMPRSSN,RMPRPD,RMPRSC,RMPRPC,RMPR660,DIK,DIC,DR,Y
+1 IF $DATA(RMPROB)
WRITE @IOF
DO PRCS^RMPRPSC
if X'["^"
GOTO A
+2 KILL ^TMP($JOB)
+3 KILL RMPROB,PRC,PRCS,RBL,RDA,RVA,RX,RMCPT,RMHCPC,RMPRBAC1,RMPRBACK,RMPRSSNE,PRCRI
QUIT
