source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121C.m

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