source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRM.m@ 1683

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

initial load of FOIAVistA 6/30/08 version
File size: 3.6 KB
Line 
1RMPRM ;PHX/DWL-INFORMATION MESSAGES / PURCHASING FUNCTIONS ; 5/22/00 4:16pm
2 ;;3.0;PROSTHETICS;**3,49**;Feb 09, 1996
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;THE FIRST THREE LINES DISPLAY MESSAGES FOR THE USER FROM PURCHASING
5M1 W !,$C(7),$C(7),"This Transaction has been Closed!" Q
6M2 ;ENTRY POINT TO DISPLAY Canceled TRANSACTION MESSAGE
7 W !,$C(7),$C(7),"This Transaction has already been Canceled!" Q
8M3 W !,$C(7),$C(7),"An X in the Item column is an error and must be reported to your Application Coordinator!" Q
9 ;RETURNS PSC AMT IN RMPRAMT FROM SITE PARAMATER FILE
10EN2520 ;ENTRY POINT FOR 2520 FORM TO SELECT PSC ITEM CATEGORY
11 W !,"Enter 'W' for WHEELCHAIR, 'O' for BRACE, 'B' for BLIND AIDS, 'A' for ART. LIMBS"
12 R !,"Select PSC ITEM CATEGORY: ",RMPRPSC:DTIME G:('$T)!(RMPRPSC["^") EXIT G:(RMPRPSC="") HPSC G:(RMPRPSC?."W")!(RMPRPSC?."B")!(RMPRPSC?."A")!(RMPRPSC?."O") PSCAMT G HPSC
13PSCAMT ;CHECKS FOR DOLLAR LIMITATIONS IN SITE PARAMETER FILE-
14 ;FOR PSC PURCHASE BY CATEGORY
15 S RMPRAMT=$S(RMPRPSC["B":$P(^RMPR(669.9,RMPRSITE,2),U,10),RMPRPSC["O":$P(^RMPR(669.9,RMPRSITE,2),U,9),RMPRPSC["W":$P(^RMPR(669.9,RMPRSITE,2),U,8),RMPRPSC["A":$P(^RMPR(669.9,RMPRSITE,2),U,7),1:0) I $D(RMPRF),RMPRF="E" Q
16 W !,"You will not be able to exceed an item repair cost of more than $",$J(RMPRAMT,0,2),"."
17 Q
18HPSC W !,$C(7),$C(7),"??",!,"CHOOSE FROM:",!?5,"W",?15,"WHEELCHAIR",!?5,"O",?15,"BRACE",!?5,"B",?15,"BLIND AID",!?5,"A",?15,"ARTIFICIAL LIMB" G EN2520
19EXIT K RMPRPSC,RMPRF Q
20POST2 ;1358
21 S (R1,RMPR("AMT"),AMT)=0
22 I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 D
23 .S RMX=^RMPR(664,RMPRA,1,RI,0) S $P(^(0),U,7)=$S($P(RMX,U,7):$P(RMX,U,7)-$J($P(RMX,U,7)*DCT,0,2),1:$P(RMX,U,3)-$J($P(RMX,U,3)*DCT,0,2))
24 S RMPRCC=""
25 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 D
26 .S R2=^RMPR(664,RMPRA,1,R1,0)
27 .;remarks in RMPRCC from all items at this point
28 .S RMPRCC=$S($P(^RMPR(664,RMPRA,1,R1,0),U,8)'="":RMPRCC_" "_$P(^RMPR(664,RMPRA,1,R1,0),U,8),1:"")
29 .I $P(R2,U,7)'="" S AMT=$P(R2,U,7)
30 .E S AMT=$P(R2,U,3)
31 .;S AMT=$S($P(R2,U,7):$P(R2,U,7),1:$P(R2,U,3))
32 .S RMPR("AMT")=RMPR("AMT")+$J((AMT*$P(R2,U,4)),0,2)
33 .I '$D(RMPRCONT),$P(^(0),U,14)'="" S RMPRCONT=$P(^(0),U,14)
34 S RMPRTO=RMPR("AMT") D CHECK^RMPRCT
35 I '$D(RMPRTO) G EXIT^RMPRE21
36 D NOW^%DTC S RMPR("DDT")=%
37 S $P(^RMPR(664,RMPRA,0),U,8)=RMPR("DDT")
38 S B2=^RMPR(664,RMPRA,0)
39 K DIC S DIC=424,DIC(0)="MZ",X=$P(B2,U,7) D ^DIC
40 S RMPR("DRN")=+Y
41 S B2=^RMPR(664,RMPRA,0)
42 S RMPRSH=$S($P(B2,U,11)'="":+$P(B2,U,11),$P(B2,U,10):+$P(B2,U,10),1:"")
43 S DIE="^RMPR(664,",DA=RMPRA,DR="8.1" D ^DIE
44 ;close-out remarks added to item remarks, stored as one comment
45 S RMPRCC=RMPRCC_" "_$P($G(^RMPR(664,RMPRA,2)),U,3)
46 ;strip all leading spaces in remarks before calling IFCAP
47 N STOP,CC
48 S STOP="",CC=""
49 F CC=0:1:$L(RMPRCC) D Q:STOP
50 .I $E(RMPRCC,1,1)'=" " S STOP=1
51 .I $E(RMPRCC,1,1)=" " S RMPRCC=$E(RMPRCC,2,$L(RMPRCC))
52 I RMPRF=10 K DIE S DIE="^RMPR(660,",DA=RMPR660,DR=9 I $D(RMPRSR) S RO=0 I $O(RMPRSR(RO)) S RO=$O(RMPRSR(RO)) D
53 .S DR="9//^S X=RMPRSR(RO)"
54 .D ^DIE S RMPRSER=$P(^RMPR(660,RMPR660,0),U,11)
55 D NOW^%DTC
56 S PRCSX=RMPR("DRN")_U_%_U_$J(RMPR("AMT")+RMPRSH,0,2)_U_RMPRCC_U_1
57 D ^PRCS58CC
58 K RMPRCC
59 I +Y'>0 S $P(^RMPR(664,RMPRA,0),U,8)="",$P(^(0),U,11)="" W !,$C(7),$C(7),"Transaction NOT Closed-out, IFCAP Failed to Post for the Following Reason.",!,$P(Y,U,2)
60 I S R1=0 G EXIT^RMPRE21
61 S RMPRWO=$P(^RMPR(664,RMPRA,0),U,15)
62 I RMPRWO,$D(^RMPR(664.2,+RMPRWO,0)) S DA(1)=RMPRWO F DA=0:0 S DA=$O(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)) Q:DA'>0 S DIK="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO D ^DIK
63 G POST1^RMPRE21
Note: See TracBrowser for help on using the repository browser.