source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRDP.m@ 770

Last change on this file since 770 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.1 KB
RevLine 
[613]1RMPRDP ;PHX/HNC-RECORD PICKUP AND DELIVERY CHARGES ;8/29/1994
2 ;;3.0;PROSTHETICS;**24,34,41,62**;Feb 09, 1996
3 ;RVD patch #62 - PCE interface
4EN ;ENTRY POINT FOR PICKUP AND DELIVERY. CALLED FROM RMPROP.
5 K ^TMP($J)
6 D DIV4^RMPRSIT G:$D(X) EXIT
7 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
8A S RMPRF=99 W !,"This will Post Pickup and Delivery Charges to the 1358 and 10-2319 ",!
9 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
10ADD D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT S RMPRFLAG=1 S RMPRBAC1=1 D ^RMPRPAT I $D(RMPRKILL) W !,"Deleted..." G EXIT
11 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")
12 ;added for PSAS HCPCS prompt
13HC 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
14 S (X,RMHCPC)=+Y,RMTYPE="X",RDA=RMHCPC_"^"_RMTYPE_"^C^"_664
15CPT D CPT^RMPRCPTU(RDA)
16 S DIE=DIC,DA=RMPRA,DR="4;10////^S X=DUZ;11R~UNIT COST;14REMARKS" D ^DIE
17 I $D(DTOUT)!($D(Y)'=0) W !,$C(7),$C(7),"Please Try Later!" G KILL
18PD 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
19 S RMPRPD=Y
20PC K DIR,Y S DIR(0)="660,62" D ^DIR G:$D(DUOUT)!($D(DTOUT)) KILL S RMPREL=Y
21SC K DIR I RMPREL=4 S DIR(0)="660,63" D ^DIR G:$D(DTOUT)!($D(DUOUT)) KILL S RMPRSE=Y K DIR
22POST 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
23 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
24FILE W !,"Posting Now..."
25 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)
26 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)
27 W !?5,"1358 Transaction has been assigned Number: ",RMPRTRN
28 ;I $Y>18 K DIR S DIR(0)="FAO^0:0",DIR("A")="Press 'RETURN' to continue." D ^DIR K DIR
29 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
30 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
31 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
32 S ^RMPR(660,RMPR660,1)=RMPRTRN_"^^^"_RMHCPC_"^^"_RMCPT,^("AM")=U_U_RMPREL_U_$S($D(RMPRSE):RMPRSE,1:"")
33 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G DIK60
34 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1
35 S $P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
36 S $P(^RMPR(660,RMPR660,"AMS"),U,1)=RMPRG
37DIK60 S DIK="^RMPR(660,",DA=RMPR660 D IX1^DIK
38 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
39 ;
40 W !?5,"Updated 10-2319 Record"
41 ;
42 ;set temp global for suspense link, added in patch #62
43 S ^TMP($J,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$G(RMPRDFN)
44 D LINK^RMPRS
45 G EXIT
46DEL 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."
47 G POST
48HLP W !,"This will create a 1358 Daily Transaction and post to Veteran's 10-2319 Record that AMIS will be counted from.",! G A
49ERROR W !,$C(7),$C(7),?5,"*** PLEASE CONTACT YOUR FISCAL SERVICE ***",!,?5,Y
50KILL S DA=RMPRK,DIK="^RMPR(664," D ^DIK K DIR W !,$C(7),?20,"Deleted..."
51 S DIR(0)="E" D ^DIR
52EXIT 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
53 I $D(RMPROB) W @IOF D PRCS^RMPRPSC G:X'["^" A
54 K ^TMP($J)
55 K RMPROB,PRC,PRCS,RBL,RDA,RVA,RX,RMCPT,RMHCPC,RMPRBAC1,RMPRBACK,RMPRSSNE,PRCRI Q
Note: See TracBrowser for help on using the repository browser.