source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4M.m@ 1005

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

initial load of WorldVistAEHR

File size: 5.5 KB
Line 
1RMPR4M ;PHX/HNB,RVD - PURCHASE CARD MODULE FUNCTIONS ;3/1/1996
2 ;;3.0;PROSTHETICS;**3,26,28,30,41,62,90,133**;Feb 09, 1996;Build 2
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; RVD patch #62 - pce and suspense link to 2319
6POST2 ;*** Posting Data to 2319 *******************************************
7 ;set global to local table/variables
8 S R190=$G(^RMPR(664,RMPRA,0))
9 S R192=$G(^RMPR(664,RMPRA,2))
10 S R193=$G(^RMPR(664,RMPRA,3))
11 S R194=$G(^RMPR(664,RMPRA,4))
12 W !,"...now posting to file 660..."
13ADD ;for adding new entry in 2319
14 S RMPHC="" I $D(^TMP("RM",$J,"N")) D
15 .F I=0:0 S I=$O(^TMP("RM",$J,"N",I)) Q:I'>0 S RMI=$G(^RMPR(664,RMPRA,1,I,0)) I RMI D
16 ..S RMCPT=$P($G(^RMPR(664,RMPRA,1,I,4)),U,2)
17 ..S DIC="^RMPR(660,",DIC(0)="L",X=DT
18 ..K DD,DO D FILE^DICN
19 ..S $P(^RMPR(664,RMPRA,1,I,0),U,13)=+Y
20 ..D TOT
21 ..S:$P(RMI,U,16) RMPHC=$P(^RMPR(661.1,$P(RMI,U,16),0),U,4)
22 ..S R19A=+Y
23 ..S R19I=$G(^RMPR(664,RMPRA,1,I,0))
24 ..S R19(660,R19A_",",8)=RMPR("STA")
25 ..S R19(660,R19A_",",.02)=$P(R190,U,2)
26 ..S R19(660,R19A_",",7)=$P(R190,U,4)
27 ..S R19(660,R19A_",",4.3)=$P(R194,U,2)
28 ..S R19(660,R19A_",",23)=$P(R194,U,5)
29 ..S R19(660,R19A_",",1)=$P(R190,U,1)
30 ..S R19(660,R19A_",",25)=$P(R193,U,1)
31 ..S R19(660,R19A_",",27)=DUZ
32 ..S R19(660,R19A_",",2)=$P(R19I,U,9)
33 ..S R19(660,R19A_",",4)=$P(R19I,U,1)
34 ..S R19(660,R19A_",",5)=$P(R19I,U,4)
35 ..S R19(660,R19A_",",4.5)=$P(R19I,U,16)
36 ..S R19(660,R19A_",",4.7)=RMCPT
37 ..S R19(660,R19A_",",4.1)=RMPHC
38 ..S R19(660,R19A_",",12)=$P(R19I,U,12)
39 ..S R19(660,R19A_",",78)=$P(R19I,U,5)
40 ..S R19(660,R19A_",",16)=$P(R19I,U,8)
41 ..S R19(660,R19A_",",24)=$P(R19I,U,2)
42 ..S R19(660,R19A_",",62)=$P(R19I,U,10)
43 ..S R19(660,R19A_",",63)=$P(R19I,U,11)
44 ..S R19(660,R19A_",",24)=$P(R19I,U,2)
45 ..S R19(660,R19A_",",14)=RMTOT
46 ..S R19(660,R19A_",",9)=$P(R19I,U,15)
47 ..S R19(660,R19A_",",11)=14
48 ..S R19(660,R19A_",",68)=RGRP1
49 ..S R19(660,R19A_",",8.14)=0
50 ..D FILE^DIE("K","R19","ERROR")
51 ..I $D(^RMPR(664,RMPRA,1,I,4)) S $P(^RMPR(660,R19A,4),U,1)=$P(^RMPR(664,RMPRA,1,I,4),U,1)
52 ..MERGE ^RMPR(660,R19A,"DES")=^RMPR(664,RMPRA,1,I,1)
53 ..S RMPRDFN=$P(R190,U,2)
54 ..S RM60LINK(R19A)=""
55 ..D CHK
56 ;
57EDIT ;for editing entry in 2319
58 S RMPHC="" I $D(^TMP("RM",$J,"E")) D
59 .F I=0:0 S I=$O(^TMP("RM",$J,"E",I)) Q:I'>0 S RMI=$G(^RMPR(664,RMPRA,1,I,0)),DA=$P(RMI,U,13) I DA D
60 ..S RMCPT=$P($G(^RMPR(664,RMPRA,1,I,4)),U,2)
61 ..D TOT
62 ..S:$P(RMI,U,16) RMPHC=$P(^RMPR(661.1,$P(RMI,U,16),0),U,4)
63 ..S $P(^RMPR(660,DA,0),U,11)=$P(RMI,U,15)
64 ..S $P(^RMPR(660,DA,0),U,4)=$P(RMI,U,9)
65 ..S $P(^RMPR(660,DA,0),U,7)=$P(RMI,U,4)
66 ..S $P(^RMPR(660,DA,0),U,8)=$P(RMI,U,5)
67 ..S $P(^RMPR(660,DA,0),U,13)=14
68 ..S $P(^RMPR(660,DA,0),U,16)=RMTOT
69 ..S $P(^RMPR(660,DA,"AM"),U,3)=$P(RMI,U,10)
70 ..S $P(^RMPR(660,DA,"AM"),U,4)=$P(RMI,U,11)
71 ..S $P(^RMPR(660,DA,0),U,22)=RMPHC
72 ..S $P(^RMPR(660,DA,1),U,4)=$P(RMI,U,16)
73 ..S $P(^RMPR(660,DA,1),U,6)=RMCPT
74 ..S $P(^RMPR(660,DA,0),U,18)=$P(RMI,U,8)
75 ..;update brief descripton field 24 in 660
76 ..S $P(^RMPR(660,DA,1),U,2)=$P(RMI,U,2)
77 ..I $D(^RMPR(664,RMPRA,1,I,4)) S $P(^RMPR(660,DA,4),U,1)=$P(^RMPR(664,RMPRA,1,I,4),U,1)
78 ..;added by patch #62
79 ..I $D(^RMPR(660,DA,10)) S RM10STAT=$P(^RMPR(660,DA,10),U,14)
80 ..I '$D(^RMPR(660,DA,10))!'$G(RM10STAT) D
81 ...K RM10STAT
82 ...S RM60LINK(DA)=""
83 ..MERGE ^RMPR(660,DA,"DES")=^RMPR(664,RMPRA,1,I,1)
84 ..S DIK="^RMPR(660," D IX1^DIK
85SHIP ;for shipping entry in 2319
86 I $G(RMSHIF) S DA=$P(R190,U,12) S:$G(DA) $P(^RMPR(660,DA,0),U,17)=$P(R190,U,11),$P(^RMPR(660,DA,0),U,16)=$P(R190,U,11) I '$G(DA) D
87 .S DIC="^RMPR(660,",DIC(0)="L",X=DT
88 .K DD,DO D FILE^DICN
89 .S $P(^RMPR(664,RMPRA,0),U,12)=+Y
90 .S R19IEN=$O(^RMPR(664,RMPRA,1,0)) Q:R19IEN=""
91 .S R19I=$G(^RMPR(664,RMPRA,1,R19IEN,0))
92 .S R19A=+Y
93 .S R19(660,R19A_",",8)=RMPR("STA")
94 .S R19(660,R19A_",",.02)=$P(R190,U,2)
95 .S R19(660,R19A_",",7)=$P(R190,U,4)
96 .S R19(660,R19A_",",4.3)=$P(R194,U,2)
97 .S R19(660,R19A_",",23)=$P(R194,U,5)
98 .S R19(660,R19A_",",1)=$P(R190,U,1)
99 .S R19(660,R19A_",",2)="X"
100 .S R19(660,R19A_",",25)=$P(R193,U,1)
101 .S R19(660,R19A_",",27)=DUZ
102 .S R19(660,R19A_",",6)=$P(R190,U,11)
103 .S R19(660,R19A_",",14)=$P(R190,U,11)
104 .S R19(660,R19A_",",11)=14
105 .S R19(660,R19A_",",12)="C"
106 .S R19(660,R19A_",",62)=$P(R19I,U,10)
107 .S R19(660,R19A_",",63)=$P(R19I,U,11)
108 .S R19(660,R19A_",",68)=RGRP1
109 .D FILE^DIE("K","R19","ERROR")
110 .I $D(^RMPR(660,R19A,10)) S RM10STAT=$P(^RMPR(660,R19A,10),U,14)
111 .I '$D(^RMPR(660,R19A,10))!'$G(RM10STAT) D
112 ..K RM10STAT
113 ..S RM60LINK(R19A)=""
114 ;
115CAN ;for CANCELING entry in 2319
116 ;call pce delete if patient encounter was recorded.
117 N RMI
118 I $D(^TMP("RM",$J,"C")) S DIK="^RMPR(660," F RMI=0:0 S RMI=$O(^TMP("RM",$J,"C",RMI)) Q:RMI'>0 D
119 .I $D(^RMPR(660,RMI,10)),$P(^RMPR(660,RMI,10),U,12) D
120 ..S RMCHK=0
121 ..S RMCHK=$$DEL^RMPRPCED(RMI)
122 .S DA=RMI D ^DIK
123 ;
124UPD ; Update Percent discount, Bank Authorization and remove shipping entry.
125 I $G(RMPERF)!$G(RMBANF) D
126 .F I=0:0 S I=$O(^RMPR(664,RMPRA,1,I)) Q:I'>0 S RMI=$G(^(I,0)),DA=$P(RMI,U,13) I DA D
127 ..I $G(RMPERF) D TOT S $P(^RMPR(660,DA,0),U,16)=RMTOT
128 ..S:$G(RMBANF) $P(^RMPR(660,DA,4),U,2)=$P(R194,U,2)
129 I $G(RMSHIF),($P(^RMPR(664,RMPRA,0),U,11)=0) S DA=$P(^(0),U,12),DIK="^RMPR(660," D ^DIK S $P(^RMPR(664,RMPRA,0),U,12)=""
130 ;
131KILL K RMTOT,RMI,R19I,R19A,DR,DA,RMPERF,RMBANF,RMSHIF,RMPHC,RMCPT
132 Q
133TOT S RMACT=$P(RMI,U,7),RMUNC=$P(RMI,U,3),RMQTY=$P(RMI,U,4)
134 I DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT-$J(RMACT*DCT,0,2)*RMQTY,1:RMUNC-$J(RMUNC*DCT,0,2)*RMQTY)
135 I 'DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT*RMQTY,1:RMUNC*RMQTY)
136 Q
137CHK I '$D(^RMPR(660,R19A,0)) W !!,$C(7),"**** POSTING TO 2319 FOR ITEM.."_I_" FAILED",!,"PLEASE RUN CLOSE-OUT OPTION AGAIN..." G KTMP^RMPR4E21
138 Q
Note: See TracBrowser for help on using the repository browser.