source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR21.m@ 789

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

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1RMPR21 ;PHX/HNB/JLT-CREATE 1358 TRANSACTION, POST TO 2319 ;8/29/1994
2 ;;3.0;PROSTHETICS;**12,41,62**;Feb 09, 1996
3 ;RVD patch #62 - pce api
4 ;Per VHA Directive 10-93-142, this routine should not be modified.
5 K ^TMP($J,"RMPRPCE")
6 S PRCS("A")="Select OBLIGATION NUMBER: " D EN1^PRCS58 G:Y=-1 EXIT
7 S RMPROB=$P(Y,U,2) D BAL^RMPRPSC
8ST S RMPRR="",(RMPRCT,R1,RMPRQT,RMPRTO,RMPRDS,RMPRIS,B2)=0,B1=1
9 W !,"This will Create"_$S('$D(RMPRF):" a NO FORM ",RMPRF=1:" a PSC 10-55 ",RMPRF=2:" a 10-2421 ",RMPRF=8:" an EYEGLASS 10-2914 ",1:" ALL OTHER ")
10A S %=1 R "Do you wish to Continue" D YN^DICN G:%=1 EN1 G:%=0 H
11 K RMPROB G EXIT
12EN1 D GETPAT^RMPRUTIL
13 G:'$D(RMPRDFN) EXT
14 K DIC,DINUM,DIC("DR")
15 S X=DT,DIC("DR")="1////^S X=RMPRDFN"
16 S DIC="^RMPR(664,",DIC(0)="AELQM",DLAYGO=664
17 K DD,DO
18 D FILE^DICN K DLAYGO,DIC Q:Y<0
19 S (RMPRK,RMPRA)=+Y
20 S DFN=RMPRDFN D DEM^VADPT
21VIEW ;VIEW 10-2319
22 S RMPRBAC1=1 D ^RMPRPAT K RMPRBAC1 G:$D(RMPRKILL) KILL
23 I RMPRF=10 D EN2520^RMPRM G:'$D(RMPRF) KILL
24 I RMPRF=1!(RMPRF=10) S RMPRFLAG=1 D DIS^RMPRAP G:$D(RMPRDIE) KILL
25 S DIE="^RMPR(664,",DA=RMPRA
26 S RMPRDR=$S(RMPRF=9:"NOFORM",RMPRF=1:"[RMPR55]",RMPRF=8:"[RMPREYE]",RMPRF=2:"2421",RMPRF=10:"[RMPR 2520]",1:"NOFORM")
27 G:RMPRDR["2421" P24^RMPR21A
28 G:RMPRDR["NOFORM" COT^RMPR21A
29 G:RMPRDR["RMPREYE" EYE^RMPRPSC
30CON K DR
31 S DR=RMPRDR D ^DIE G:'$P(^RMPR(664,RMPRA,0),U,4) KILL
32CHK D CHK1
33 I 'FL W !!,$C(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL
34 S $P(^RMPR(664,RMPRA,0),U,9)=DUZ
35 ;I $D(DTOUT)!($D(Y(0))) W !,$C(7),$C(7),"Please Try Later!" G KILL
36ASK ;POST TRANSACTION QUESTION
37 S %=2 W !!,"Are you ready to POST to IFCAP and 10-2319 NOW"
38 D YN^DICN G:%=1 FILE^RMPR21B G:$D(DTOUT) KILL
39 I %=0 W !,"This will Create a Daily Transaction in the 1358 Module of IFCAP,",!,"and Create an Entry on the Prosthetic 10-2319 Record." G ASK
40DEL ;
41 I %=-1 S %=2 R !,"Do you want to Delete this Transaction" D YN^DICN I $D(DTOUT)!(%=1) S:$D(RMPRA) RMPRK=RMPRA G KILL
42 I %=0 W !!,"ENTER YES OR NO!!",$C(7) S %=-1 G DEL
43 D ^RMPRLI I RMPRX]"" G ASK
44L W !!!,"Enter Item to Edit: " R X:DTIME G:'$T KILL
45 G:X["^"!(X="") ASK I X["?" D ZDSP^RMPR21A G L
46 S DIC="^RMPR(664,"_RMPRA_",1,",DIC(0)="EQMZ" D ^DIC
47 I +Y'>0 K DA,Y G L
48 S DA=+Y,DA(1)=RMPRA,DIE=DIC
49 ;HCPCS code
50 S DR="8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";.01;16;1;14;3;2;4;7;S Y="""";@1;10;16;1;14;3;2;4;7"
51 ;S DR=".01;1;14;16;8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";3;2;4;7;S Y="""";@1;10;3;2;4;7"
52 ;HCPCS code
53 S:RMPRDR["RMPREYE" DR="8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";.01;16;1;3;2;4;7;S Y="""";@1;10;16;1;3;2;4;7" D ^DIE
54 ;S:RMPRDR["RMPREYE" DR=".01;16;8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";1;3;2;4;7;S Y="""";@1;10;1;3;2;4;7" D ^DIE
55 D CHK
56 I '$D(FL) W !!,$C(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL
57 S DIE="^RMPR(664,",DA=RMPRA,DR=11 D ^DIE G L
58H W !,"This will create a transaction, post to IFCAP, and update the 2319 report",! G A
59 ;
60CHK1 ;CHECK FOR EXISTENCE OF ITEMS ON PURCHASING FORMS
61 S FL=1
62 I $D(^RMPR(664,RMPRA,1)) S (FL,RI)=0 F S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 Q:'$D(^(RI,0)) D
63 .S FL=1
64 .S RB=^RMPR(664,RMPRA,1,RI,0)
65 .I $P(RB,U,3)=""!($P(RB,U,4)="")!($P(RB,U,5)="")!($P(RB,U,9)="")!($P(RB,U,10)="") S FL=0 Q
66 .S DA(1)=RMPRA,DA=RI D CHKCPT^RMPR21A
67 Q
68 ;
69ERROR ;ERROR MESSAGE FOR FAILED POSTING
70 W !,$C(7),?5,"***PLEASE CONTACT YOUR FISCAL SERVICE***",!,Y
71KILL ;DELETE PURCHASING ENTRY
72 Q:'$D(RMPRK)
73 S DA=RMPRK,DIK="^RMPR(664," D ^DIK W !,$C(7),?20,"Deleted..." K RMPRDOD,RMPROB
74 I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) D K DIK
75TMP .S DA=0
76 .F S DA=$O(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)) Q:$G(DA)'>0
77 .S DIK="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO
78 .D ^DIK
79EXIT ;EXIT AND KILL VARIABLES. SET UP OBLIGATION NUMBER QUESTION
80 D:'$D(DTOUT) LINK^RMPRS D KVAR^VADPT
81 I $G(RMPRF)=2419 S RMPRSF=RMPRF S RMPRSDA=RMPRDA,RMPRSA=RMPRA
82EXT K RMPRFLAG,RMPRG,RD,RMPRPSC,RMPRCONT,RMPRSH,RMPRDS,RMPRTO,RMPRCT,RMPRQT,R1,B2,D1,RMPRI,%,B1,DA,DIC,DIK,PRCS,PRCSCPAN,RMPRIN,RMPRPC,RMPRAMIS,RMPRARD,RMPRCNT,RMPRIT,RMPRIT1,RMPRU,SR,TYPE,RAC,FL,RMPRCTK,PRCSIP,PQTY,FL1,RMPRNOB,HY,RMPRGO
83 K ^TMP($J,"RMPRPCE")
84 K RMPRDIE,RMPRDR,RMPRDES,DIE,RMPRSR,DR,DTOUT,RMPRDOB,RMPRSC,RMPRTRN,RMPRX,RMPRK,RMPR660,RMPRA,RMPRDFN,RMPRDIS,RMPRIS,RMPRNAM,RMPRR,RMPRS,RMPRSSN
85 K RMPRSSNE,RMPRT,RMPRTN,RMPRV,Y,LINE,RMPRUP,RMPRSR,RMPRPI,RI,RA,RMPRI1,RMPRDELN,RDP,Y,RMPRSER,NAME,RMTYP,RMCAT,RMSPE
86 I $D(RMPRWO),RMPRWO D POST^RMPR29U Q
87 I $D(RMPRDA) Q
88 I $D(RMPROB) D PRCS^RMPRPSC G:(X'="^")!(X'["^") ST
89 K RMPROB,RMPRF,PRC,PRCS,RBL,RDA,RVA,RX,RMPRKILL Q
Note: See TracBrowser for help on using the repository browser.