source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR21A.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1RMPR21A ;PHX/HNB/JLT-CONT. CREATE 1358 TRANSACTION, POST TO 2319 ;8/29/1994
2 ;;3.0;PROSTHETICS;**12,41,50,90,129**;Feb 09, 1996;Build 2
3 ;HNC - #90, item to billing item 10/29/04
4 ;Per VHA Directive 10-93-142, this routine should not be modified.
5P24 ;2421 DATE REQUIRED
6 S DR="20//T+30" D ^DIE I $D(DTOUT)!($D(Y)'=0) G KILL^RMPR21
7COT ;2421'S AND NO FORM WITH CONTRACT AUTHORITY1
8 I '$D(^RMPR(664,RMPRA,3)) S ^(3)=""
9 S DR="4"
10COT1 D ^DIE I $D(DTOUT)!($D(Y)'=0) G KILL^RMPR21
11 S RMPRV=$P($G(^RMPR(664,RMPRA,0)),U,4) G:$G(RMPRV)'>0 TRAN G:'$D(^PRC(440,RMPRV,4)) TRAN K DIR S DIR(0)="PO^PRC(440,"_RMPRV_",4,:QEM" D ^DIR I (Y'>0)&(X'="")&(X'["^") S DIR("B")="" G COT1
12 I X["^" G KILL^RMPR21
13 I Y>0,$P(^PRC(440,RMPRV,4,+Y,0),U,2)<DT W $C(7),!,"Sorry, contract has expired. Enter another contract or `return` to continue." S DR="4//""""" G COT1
14 K DIR,DA S:Y>0 (RMPRCONT,RMPRCTK)=$P(Y,U,2)
15L2 ;ENTER/EDIT 2421, NO FORM
16 W !,"----------------------------------",!
17TRAN K DIR S DIR(0)="SMAO^I:INITIAL ISSUE;R:REPLACE;S:SPARE;X:REPAIR"
18 S DIR("A")="TYPE OF TRANSACTION: " D ^DIR
19 I $D(DUOUT)!$D(DTOUT) G CHK
20 I (Y="")&($D(^RMPR(664,RMPRA,1))) G CHK
21 I (Y="")&('$D(^RMPR(664,RMPRA,1))) W !,"Please enter type of Transaction!!" G TRAN
22 S RMTYPE=Y
23PCAT K DIR S DIR(0)="SMAO^1:SC/OP;2:SC/IP;3:NSC/IP;4:NSC/OP"
24 S DIR("A")="PATIENT CATEGORY: " D ^DIR
25 I $D(DUOUT)!$D(DTOUT) G CHK
26 I (Y="")&($D(^RMPR(664,RMPRA,1))) G CHK
27 I (Y="")&('$D(^RMPRA(664,RMPRA,1))) W !,"Please enter Patient Category!!" G PCAT
28 S RMCAT=Y
29 K DIR G:RMCAT<4 ITEM
30SPES S DIR(0)="SMAO^1:SPECIAL LEGISLATION;2:A&A;3:PHC;4:ELIGIBILITY REFORM"
31 S DIR("A")="SPECIAL CATEGORY: "
32 I RMCAT=4 D ^DIR I $D(DUOUT)!$D(DTOUT) G CHK
33 I RMCAT=4 S RMSPE=Y
34ITEM ;
35 K DIR S DIR(0)="FO",DIR("A")="Select BILLING ITEM"
36 S DIR("?")="^S RFL=1 D ZDSP^RMPR21A"
37 D ^DIR G:$D(DTOUT) KILL^RMPR21 G:$D(DUOUT) CHK
38 G:$D(DIRUT)&($D(^RMPR(664,RMPRA,1))) CHK
39 S DIC=661,DIC(0)="EQMZ" D ^DIC G:+Y'>0 ITEM
40 D EDT^RMPRUTIL G:$D(DTOUT) KILL^RMPR21 G L2
41 ;
42CHK K RFL,DIR S FL=1
43 I '$D(^RMPR(664,RMPRA,1)) W !!,?5,$C(7),"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL^RMPR21
44 I $D(^RMPR(664,RMPRA,1)) S FL=0 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 I $D(^(RI,0)) S FL=1 I $P(^(0),U,3)=""!($P(^(0),U,4)="")!($P(^(0),U,5)="")!($P(^(0),U,9)="")!($P(^(0),U,10)="") S FL=0 Q
45 I 'FL W !!,?5,$C(7),"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL^RMPR21
46 S $P(^RMPR(664,RMPRA,0),U,9)=DUZ
47 I $D(DUOUT)&('$D(^RMPR(664,RMPRA,1))) W !,$C(7),$C(7),"Please Try Later!" G KILL^RMPR21
48 I RMPRF'=8 S DA=RMPRA,DIE=664,DR="11;17" D ^DIE
49ASK I RMPRF=2 D D ^DIR K DIR G:$D(DTOUT) KILL^RMPR21 I $D(DIRUT)!(X="") W $C(7),"Delivery is required. Enter '?' for additional help." G ASK
50 .K DIR
51 .S DIR(0)="SAO^1:VETERAN;2:VAMC WAREHOUSE;3:PROSTHETICS;4:OTHER;"
52 .S DIR("A")="DELIVER TO: "
53 .;S DIR("B")=$P(^RMPR(664,RMPRA,3),U,1)
54 .;D ^DIR K DIR G:$D(DTOUT) KILL^RMPR21 I $D(DIRUT) W $C(7)," ??" G ASK
55 I RMPRF=2 S RMPRDELN=Y(0),$P(^RMPR(664,RMPRA,3),U)=RMPRDELN I Y=4 D G:$D(DTOUT) KILL^RMPR21
56 .S DIE="^RMPR(664,",DA=RMPRA,DR="21.1T" D ^DIE
57 .Q
58ASK5 S %=2 W !!,"Are you ready to POST to IFCAP and 10-2319 NOW" D YN^DICN G:%=1 FILE^RMPR21B G:$D(DTOUT) KILL^RMPR21
59 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 ASK5
60 I %=-1 S %=2 R !,"Do you want to Delete this Transaction" D YN^DICN G:$D(DTOUT)!(%=1) KILL^RMPR21
61 D ^RMPRLI I RMPRX]"" G ASK5
62L W !!!,"Enter Item to Edit: " R X:DTIME G:'$T KILL^RMPR21
63 G:"^"[X ASK5 I X["?" D ZDSP G L
64 S DA(1)=RMPRA,DIC="^RMPR(664,"_RMPRA_",1,",DIC(0)="EQMZ" D ^DIC I +Y'>0 K DA,Y G L
65 ;HCPCS code
66 S:$D(RMPRCTK) RMPRCONT=RMPRCTK
67 S DA=+Y,DA(1)=RMPRA
68 S DR="8;9;S RMTYPE=$P($G(^(0)),U,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;.01;16;1;14;3;2;4;7"
69 S DIE="^RMPR(664,"_RMPRA_",1," D ^DIE
70 ;do a final check for cpt modifier
71 D CHKCPT
72 K DA
73 S FL=1 I $D(^RMPR(664,RMPRA,1)) S FL=0 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 I $D(^(RI,0)) S FL=1 I $P(^(0),U,3)=""!($P(^(0),U,4)="")!($P(^(0),U,5)="")!($P(^(0),U,9)="")!($P(^(0),U,10)="") S FL=0 Q
74 I 'FL W !!,?5,$C(7),"REQUIRED ITEMS DO NOT EXIST ON THIS FORM",! G KILL^RMPR21
75 K DA S DIE="^RMPR(664,",DA=RMPRA,DR="11;17" S:RMPRF=2 DR=DR_";20" D ^DIE
76 I RMPRF=2 D G:$D(DTOUT) KILL^RMPR21 G:$D(DUOUT) ASK5
77 .S DIR(0)="SA^1:VETERAN;2:VAMC WAREHOUSE;3:PROSTHETICS;4:OTHER;"
78 .S DIR("A")="DELIVER TO: "
79 .;REMOVE DIR(?)
80 .S DIR("B")=$P(^RMPR(664,DA,3),U,1)
81 .D ^DIR K DIR
82 .Q:$D(DTOUT)!($D(DUOUT))
83 .S RMPRDELN=Y(0)
84 .I Y=4 S:'$D(^RMPR(664,RMPRA,3)) ^(3)="" S Y1=Y,DIE="^RMPR(664,",DA=RMPRA,DR="21.1T" D ^DIE
85 G:$D(DTOUT) KILL^RMPR21 K Y1 G L
86 ;
87ZDSP ;MULTIPLE ITEM DISPLAY FOR PURCHASING AND CLOSE-OUT
88 K RAC S RMPRI=0 F S RMPRI=$O(^RMPR(664,RMPRA,1,RMPRI)) Q:RMPRI'>0 S RMPRI1=$P(^(RMPRI,0),U,1),RMPRIT=$P(^RMPR(661,RMPRI1,0),U,1),RAC(RMPRIT)=$P(^PRC(441,RMPRIT,0),U,2)
89 W ! I $D(RAC) W !,?5,"Answer With Item # or Item Name",! F RI=0:0 S RI=$O(RAC(RI)) Q:RI'>0 W !,?5,RI,?10,RAC(RI)
90LDIC I $D(RFL) S X="?",DIC=661,DIC(0)="EQM",DIC("W")="W "" "",$P(^PRC(441,$P(^(0),U,1),0),U,2)" D ^DIC K RFL
91 Q
92PR1 ;ENTRY POINT FOR 10-2421S ASKING THE USER IF THEY WANT TO PRINT THE PATIENT NOTIFICATION LETTER
93 Q:RMPRF'=2
94 S RMPRPN=0,%=2
95 R !,"Would you like to print a Patient Notification letter"
96 D YN^DICN I %=1 S RMPRPN=1 Q
97 G:%=0 HELP1
98 Q:(%=2)!(%=-1)
99 Q
100HELP1 ;
101 W !,"Enter `Y` for YES to print the Patient Notification letter",!,"`N` for No if you do not wish to print the letter." G PR1
102 Q
103PR ;ENTRY POINT FOR BOTH 10-2421S AND 10-55S ASKING THE USER IF THEY WANT TO PRINT THE PRIVACY ACT STATEMENT
104 S %=1 R !,"Would you like to print the Privacy Act Statement" D YN^DICN I %=1 S RMPRPRIV=1 D PR1 Q
105 G:%=0 HELP D:%=2 PR1 Q
106 Q:%=-1
107HELP W !,"Enter `Y` for YES to print the Privacy Act Statement",!,"`N` for NO if you do not want to print the statement." G PR
108 Q
109 ;
110CHKCPT ;check for cpt modifier
111 S RMCPTOLD=$P($G(^RMPR(664,DA(1),1,DA,4)),U,2)
112 S RMTYNEW=$P(^RMPR(664,DA(1),1,DA,0),U,9)
113 S RMHCPC=$P(^RMPR(664,DA(1),1,DA,0),U,16) Q:'$G(RMHCPC)
114 I ((RMTYNEW="R")!(RMTYNEW="X")),(RMCPTOLD'["RP"),($G(^RMPR(661.1,RMHCPC,4))["RP") D ADDRP
115 I ((RMTYNEW="I")!(RMTYNEW="S")),(RMCPTOLD["RP"),($G(^RMPR(661.1,RMHCPC,4))["RP") D DELRP
116 K RMCPTOLD,RMTYNEW,RMHCPC,RMF,RMCI,RMC,RMLPIECE,RMCLEN
117 Q
118DELRP ;logic for deleting 'RP' modifier with transaction change.
119 F RMCI=1:1:8 S RMC=$P(RMCPTOLD,",",RMCI) I RMC="RP" S $P(RMCPTOLD,",",RMCI)="" D
120 .S RMF=$F(RMCPTOLD,",,"),RMFPIECE=$E(RMCPTOLD,1,RMF-2)
121 .S RMLPIECE=$E(RMCPTOLD,RMF,32),RMCPTOLD=RMFPIECE_RMLPIECE
122 .S RMCLEN=$L(RMCPTOLD)
123 .I $E(RMCPTOLD,1)="," S RMCPTOLD=$E(RMCPTOLD,2,RMCLEN)
124 .I $E(RMCPTOLD,RMCLEN)="," S RMCPTOLD=$E(RMCPTOLD,1,RMCLEN-1)
125 .S $P(^RMPR(664,DA(1),1,DA,4),U,2)=RMCPTOLD
126 Q
127 ;
128ADDRP ;logic for adding 'RP' modifier with transaction change.
129 S RMCPTOLD=RMCPTOLD_",RP"
130 S $P(^RMPR(664,DA(1),1,DA,4),U,2)=RMCPTOLD
131 Q
132 ;END
Note: See TracBrowser for help on using the repository browser.