source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121C.m@ 1119

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1RMPR121C ;HINES-OI/HNC/SPS - IFCAP GUI TO 2319 ;3/1/2003
2 ;;3.0;PROSTHETICS;**90,75,60**;Feb 09, 1996;Build 18
3 ;
4R19 ;PASS RMPRA AS IEN OF 644, AND B2 AS ITEM MULTIPLE
5 ;S:$D(RMPRCONT) $P(^RMPR(664,RMPRA,1,B2,0),U,14)=RMPRCONT
6 S RMPRI=$P(^RMPR(664,RMPRA,1,B2,0),U,1),RMPRCT=$P(^(0),U,3)
7 S RMPRQT=$P(^RMPR(664,RMPRA,1,B2,0),U,4),RMPRDES=$P(^(0),U,2)
8 S RMPRPER=$P(^RMPR(664,RMPRA,2),U,6)/100
9 ;contract data
10 S RMPRCONT=""
11 S RMPRCONT=$P(^RMPR(664,RMPRA,1,B2,0),U,14)
12 ;TEMPORARY FIX FOR TRANSACTION TYPE AND PATIENT CATAGORY
13 S RMPRT=$P(^RMPR(664,RMPRA,1,B2,0),U,9),RMPRR=$P(^(0),U,8),RMPRDIS=$P(^(0),U,10),RMPRS=$P(^(0),U,12),UOI=$P(^(0),U,5),RMPRSLN=$P(^(0),U,15)
14 ;
15 I RMPRT="R" S $P(^RMPR(664,RMPRA,1,B2,0),U,9)="X",RMPRT="X"
16 I RMPRDIS=2 S $P(^RMPR(664,RMPRA,1,B2,0),U,10)=1,RMPRDIS=1
17 I RMPRDIS=3 S $P(^RMPR(664,RMPRA,1,B2,0),U,10)=4,RMPRDIS=4
18 S RMPRSC=$P(^RMPR(664,RMPRA,1,B2,0),U,11) ;Special catagory
19 S RMPRNOB=$P(^RMPR(664,RMPRA,1,B2,0),U,17) ;NUMBER OF BIDS
20 S RMPRHCPC=$P(^RMPR(664,RMPRA,1,B2,0),U,16) ;PSAS HCPCS
21 S RMPRMK=$P(^RMPR(664,RMPRA,1,B2,2),U,1),RMPRMD=$P(^(2),U,2),RMPRLTN=$P(^(2),U,3),RMPREW=$P(^(2),U,4) ;MAKE,MODEL,LOT,EXCLUDE/WAVER
22 S RMCPT=$P($G(^RMPR(664,RMPRA,1,B2,4)),U,2) ;CPT MODIFIER
23 K DD,DO S DIC="^RMPR(660,",DIC(0)="QL",X=DT,DLAYGO=660
24 D FILE^DICN K DLAYGO,DIC,D0 S (RMPR660,DA)=+Y
25 S $P(^RMPR(664,RMPRA,1,B2,0),U,13)=RMPR660
26 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
27 S RMPRAMT=(RMPRQT*RMPRCT)
28 S RMPRDCT=RMPRAMT*RMPRPER
29 S RMPRTOTL=RMPRAMT-RMPRDCT
30 ;ctd is unit cost with percent discount applied.
31 S RMPRCTD=RMPRAMT-RMPRDCT/RMPRQT
32 ;
33 S ^RMPR(660,RMPR660,0)=DT_U_RMPRDFN_U_DT_U_RMPRT_U_U_U_RMPRQT_U_UOI_U_RMPRV_U_RMPR("STA")_U_U_U_"14"_U_RMPRS_U_U_$J(RMPRTOTL,0,2)_"^^^^^^"
34 ;SERIAL#,MAKE,MODEL,LOT#,EXCLUDE/WAVER
35 S $P(^RMPR(660,RMPR660,0),U,11)=RMPRSLN,$P(^(0),U,24)=RMPRLTN
36 S $P(^RMPR(660,RMPR660,9),U)=RMPRMK,$P(^(9),U,2)=RMPRMD
37 S $P(^RMPR(660,RMPR660,2),U,3)=RMPREW
38 ;OIF/OEF
39 S DFN=RMPRDFN D SVC^VADPT
40 S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0)
41 D KVAR^VADPT
42 I RMPROEOI="<!>" S $P(^RMPR(660,RMPR660,5),U,1)=1
43 ;CONTRACT #
44 S $P(^RMPR(660,RMPR660,2),U,9)=$P(^RMPR(664,RMPRA,1,B2,0),U,14)
45 ; ITEM
46 S $P(^RMPR(660,RMPR660,0),U,6)=RMPRI
47 ;NUMBER OF BIDS
48 S $P(^RMPR(660,RMPR660,2),U,10)=RMPRNOB
49 ;HCPCS code
50 S:RMPRHCPC $P(^RMPR(660,RMPR660,0),U,22)=$P(^RMPR(661.1,RMPRHCPC,0),U,4)
51 ;
52 S ^RMPR(660,RMPR660,"AMS")=RMPRG,^RMPR(660,RMPR660,"AM")=U_U_RMPRDIS_U_RMPRSC
53 ; /SPS removed below from above line for 75 may re-use later
54 ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1,$P(^RMPR(660,RMPR660,"LB"),U,5)=RMPRWO
55 S:$D(RMPRR) $P(^RMPR(660,RMPR660,0),U,18)=RMPRR
56 S RMPRTRN=$P(^RMPR(664,RMPRA,4),U,5)
57 S $P(^RMPR(660,RMPR660,0),U,27)=DUZ,^(1)=RMPRTRN_U_RMPRDES_"^^"_RMPRHCPC_"^^"_RMCPT
58 ;If work order and no count fields need to be set
59 I +$P(^RMPR(664,RMPRA,0),U,17)>0 D NCNT
60 ;note to supplier
61 ;
62 S RMPRNS=""
63 S (D1,RD)=0
64 F S RD=$O(^RMPR(664,RMPRA,1,B2,1,RD)) Q:RD="" D
65 .S ^RMPR(660,RMPR660,"DES",RD,0)=^RMPR(664,RMPRA,1,B2,1,RD,0)
66 .I $L(RMPRNS)>160 Q
67 .S RMPRNS=RMPRNS_" "_^RMPR(664,RMPRA,1,B2,1,RD,0)
68 .S D1=RD
69 S ^RMPR(660,RMPR660,"DES",0)="^660.028^"_D1_U_D1
70 S:$D(RMPRDELN) ^RMPR(660,RMPR660,3)=RMPRDELN
71 ;modified by #62
72 S ^TMP($J,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$G(RMPRDFN)
73 ;set x-refs
74 S DIK="^RMPR(660,",DA=RMPR660 D IX1^DIK
75 K RMPRTRN
76 Q
77NCNT ; ADD NO ADMIN COUNT TO 660 FOR WORK ORDER
78 ;
79 S RMIE1=$P(^RMPR(664,RMPRA,0),U,17)
80 S RMRWO=$P(^RMPR(664.1,RMIE1,0),U,13)
81 S RMDAT(660,RMPR660_",",72.5)=RMRWO
82 S RMDAT(660,RMPR660_",",72)=RMIE1
83 S RMDAT(660,RMPR660_",",81)=1
84 S RMDAT(660,RMPR660_",",11)=14
85 S RMDAT(660,RMPR660_",",12)="C"
86 D FILE^DIE("","RMDAT","RMERROR")
87 I $D(RMERROR) S RESULT(0)=1_U_RMERROR G EXIT
88 Q
89EXIT ;
90 K RMIE1,RMRWO,RMPRA,RMPR660
91 Q
Note: See TracBrowser for help on using the repository browser.