source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121C.m@ 1111

RMPR121C ;HINES-OI/HNC/SPS - IFCAP GUI TO 2319 ;3/1/2003

 ;;3.0;PROSTHETICS;**90,75,60**;Feb 09, 1996;Build 18

 ;

R19 ;PASS RMPRA AS IEN OF 644, AND B2 AS ITEM MULTIPLE

 ;S:$D(RMPRCONT) $P(^RMPR(664,RMPRA,1,B2,0),U,14)=RMPRCONT

 S RMPRI=$P(^RMPR(664,RMPRA,1,B2,0),U,1),RMPRCT=$P(^(0),U,3)

 S RMPRQT=$P(^RMPR(664,RMPRA,1,B2,0),U,4),RMPRDES=$P(^(0),U,2)

 S RMPRPER=$P(^RMPR(664,RMPRA,2),U,6)/100

 ;contract data

 S RMPRCONT=""

 S RMPRCONT=$P(^RMPR(664,RMPRA,1,B2,0),U,14)

 ;TEMPORARY FIX FOR TRANSACTION TYPE AND PATIENT CATAGORY

 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)

 ;

 I RMPRT="R" S $P(^RMPR(664,RMPRA,1,B2,0),U,9)="X",RMPRT="X"

 I RMPRDIS=2 S $P(^RMPR(664,RMPRA,1,B2,0),U,10)=1,RMPRDIS=1

 I RMPRDIS=3 S $P(^RMPR(664,RMPRA,1,B2,0),U,10)=4,RMPRDIS=4

 S RMPRSC=$P(^RMPR(664,RMPRA,1,B2,0),U,11) ;Special catagory

 S RMPRNOB=$P(^RMPR(664,RMPRA,1,B2,0),U,17) ;NUMBER OF BIDS

 S RMPRHCPC=$P(^RMPR(664,RMPRA,1,B2,0),U,16) ;PSAS HCPCS

 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

 S RMCPT=$P($G(^RMPR(664,RMPRA,1,B2,4)),U,2) ;CPT MODIFIER

 K DD,DO S DIC="^RMPR(660,",DIC(0)="QL",X=DT,DLAYGO=660

 D FILE^DICN K DLAYGO,DIC,D0 S (RMPR660,DA)=+Y

 S $P(^RMPR(664,RMPRA,1,B2,0),U,13)=RMPR660

 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK

 S RMPRAMT=(RMPRQT*RMPRCT)

 S RMPRDCT=RMPRAMT*RMPRPER

 S RMPRTOTL=RMPRAMT-RMPRDCT

 ;ctd is unit cost with percent discount applied.

 S RMPRCTD=RMPRAMT-RMPRDCT/RMPRQT

 ;

 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)_"^^^^^^"

 ;SERIAL#,MAKE,MODEL,LOT#,EXCLUDE/WAVER

 S $P(^RMPR(660,RMPR660,0),U,11)=RMPRSLN,$P(^(0),U,24)=RMPRLTN

 S $P(^RMPR(660,RMPR660,9),U)=RMPRMK,$P(^(9),U,2)=RMPRMD

 S $P(^RMPR(660,RMPR660,2),U,3)=RMPREW

 ;OIF/OEF

 S DFN=RMPRDFN D SVC^VADPT

 S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0)

 D KVAR^VADPT

 I RMPROEOI="<!>" S $P(^RMPR(660,RMPR660,5),U,1)=1

 ;CONTRACT #

 S $P(^RMPR(660,RMPR660,2),U,9)=$P(^RMPR(664,RMPRA,1,B2,0),U,14)

 ; ITEM

 S $P(^RMPR(660,RMPR660,0),U,6)=RMPRI

 ;NUMBER OF BIDS

 S $P(^RMPR(660,RMPR660,2),U,10)=RMPRNOB

 ;HCPCS code

 S:RMPRHCPC $P(^RMPR(660,RMPR660,0),U,22)=$P(^RMPR(661.1,RMPRHCPC,0),U,4)

 ;

 S ^RMPR(660,RMPR660,"AMS")=RMPRG,^RMPR(660,RMPR660,"AM")=U_U_RMPRDIS_U_RMPRSC

 ; /SPS removed below from above line for 75 may re-use later

 ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1,$P(^RMPR(660,RMPR660,"LB"),U,5)=RMPRWO

 S:$D(RMPRR) $P(^RMPR(660,RMPR660,0),U,18)=RMPRR

 S RMPRTRN=$P(^RMPR(664,RMPRA,4),U,5)

 S $P(^RMPR(660,RMPR660,0),U,27)=DUZ,^(1)=RMPRTRN_U_RMPRDES_"^^"_RMPRHCPC_"^^"_RMCPT

 ;If work order and no count fields need to be set

 I +$P(^RMPR(664,RMPRA,0),U,17)>0 D NCNT

 ;note to supplier

 ;

 S RMPRNS=""

 S (D1,RD)=0

 F  S RD=$O(^RMPR(664,RMPRA,1,B2,1,RD)) Q:RD=""  D

 .S ^RMPR(660,RMPR660,"DES",RD,0)=^RMPR(664,RMPRA,1,B2,1,RD,0)

 .I $L(RMPRNS)>160 Q

 .S RMPRNS=RMPRNS_" "_^RMPR(664,RMPRA,1,B2,1,RD,0)

 .S D1=RD

 S ^RMPR(660,RMPR660,"DES",0)="^660.028^"_D1_U_D1

 S:$D(RMPRDELN) ^RMPR(660,RMPR660,3)=RMPRDELN

 ;modified by #62

 S ^TMP($J,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$G(RMPRDFN)

 ;set x-refs

 S DIK="^RMPR(660,",DA=RMPR660 D IX1^DIK

 K RMPRTRN

 Q

NCNT ; ADD NO ADMIN COUNT TO 660 FOR WORK ORDER

 ;

 S RMIE1=$P(^RMPR(664,RMPRA,0),U,17)

 S RMRWO=$P(^RMPR(664.1,RMIE1,0),U,13)

 S RMDAT(660,RMPR660_",",72.5)=RMRWO

 S RMDAT(660,RMPR660_",",72)=RMIE1

 S RMDAT(660,RMPR660_",",81)=1

 S RMDAT(660,RMPR660_",",11)=14

 S RMDAT(660,RMPR660_",",12)="C"

 D FILE^DIE("","RMDAT","RMERROR")

 I $D(RMERROR) S RESULT(0)=1_U_RMERROR G EXIT

 Q

EXIT ;

 K RMIE1,RMRWO,RMPRA,RMPR660

 Q