RMPR121C ;HINES-OI/HNC/SPS - IFCAP GUI TO 2319 ;3/1/2003
;;3.0;PROSTHETICS;**90,75,60,144,125**;Feb 09, 1996;Build 21
;
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=+Y K Y
S $P(^RMPR(664,RMPRA,1,B2,0),U,13)=RMPR660
S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK K DA,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 K LRQ,IENA,IENB
. S LRQ=$P(^RMPR(664,RMPRA,0),U,17),IENA=$P($G(^RMPR(660,RMPR660,0)),U,2),IENB=$P($G(^RMPR(664.1,LRQ,0)),U,2)
. I IENA'=IENB S $P(^RMPR(664,RMPRA,0),U,17)="",LRQ="" Q
. 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) $P(^RMPR(660,RMPR660,3),U,1)=RMPRDELN
S $P(^RMPR(660,RMPR660,3),U,2)=$P(^RMPR(664,RMPRA,3),U,2) ;Date Required added for 125
;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 DA,DIK,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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR121C 4153 printed Dec 13, 2024@02:31:43 Page 2
RMPR121C ;HINES-OI/HNC/SPS - IFCAP GUI TO 2319 ;3/1/2003
+1 ;;3.0;PROSTHETICS;**90,75,60,144,125**;Feb 09, 1996;Build 21
+2 ;
R19 ;PASS RMPRA AS IEN OF 644, AND B2 AS ITEM MULTIPLE
+1 ;S:$D(RMPRCONT) $P(^RMPR(664,RMPRA,1,B2,0),U,14)=RMPRCONT
+2 SET RMPRI=$PIECE(^RMPR(664,RMPRA,1,B2,0),U,1)
SET RMPRCT=$PIECE(^(0),U,3)
+3 SET RMPRQT=$PIECE(^RMPR(664,RMPRA,1,B2,0),U,4)
SET RMPRDES=$PIECE(^(0),U,2)
+4 SET RMPRPER=$PIECE(^RMPR(664,RMPRA,2),U,6)/100
+5 ;contract data
+6 SET RMPRCONT=""
+7 SET RMPRCONT=$PIECE(^RMPR(664,RMPRA,1,B2,0),U,14)
+8 ;TEMPORARY FIX FOR TRANSACTION TYPE AND PATIENT CATAGORY
+9 SET RMPRT=$PIECE(^RMPR(664,RMPRA,1,B2,0),U,9)
SET RMPRR=$PIECE(^(0),U,8)
SET RMPRDIS=$PIECE(^(0),U,10)
SET RMPRS=$PIECE(^(0),U,12)
SET UOI=$PIECE(^(0),U,5)
SET RMPRSLN=$PIECE(^(0),U,15)
+10 ;
+11 IF RMPRT="R"
SET $PIECE(^RMPR(664,RMPRA,1,B2,0),U,9)="X"
SET RMPRT="X"
+12 IF RMPRDIS=2
SET $PIECE(^RMPR(664,RMPRA,1,B2,0),U,10)=1
SET RMPRDIS=1
+13 IF RMPRDIS=3
SET $PIECE(^RMPR(664,RMPRA,1,B2,0),U,10)=4
SET RMPRDIS=4
+14 ;Special catagory
SET RMPRSC=$PIECE(^RMPR(664,RMPRA,1,B2,0),U,11)
+15 ;NUMBER OF BIDS
SET RMPRNOB=$PIECE(^RMPR(664,RMPRA,1,B2,0),U,17)
+16 ;PSAS HCPCS
SET RMPRHCPC=$PIECE(^RMPR(664,RMPRA,1,B2,0),U,16)
+17 ;MAKE,MODEL,LOT,EXCLUDE/WAVER
SET RMPRMK=$PIECE(^RMPR(664,RMPRA,1,B2,2),U,1)
SET RMPRMD=$PIECE(^(2),U,2)
SET RMPRLTN=$PIECE(^(2),U,3)
SET RMPREW=$PIECE(^(2),U,4)
+18 ;CPT MODIFIER
SET RMCPT=$PIECE($GET(^RMPR(664,RMPRA,1,B2,4)),U,2)
+19 KILL DD,DO
SET DIC="^RMPR(660,"
SET DIC(0)="QL"
SET X=DT
SET DLAYGO=660
+20 DO FILE^DICN
KILL DLAYGO,DIC,D0
SET RMPR660=+Y
KILL Y
+21 SET $PIECE(^RMPR(664,RMPRA,1,B2,0),U,13)=RMPR660
+22 SET DA=RMPRA
SET DIK="^RMPR(664,"
DO IX1^DIK
KILL DA,DIK
+23 SET RMPRAMT=(RMPRQT*RMPRCT)
+24 SET RMPRDCT=RMPRAMT*RMPRPER
+25 SET RMPRTOTL=RMPRAMT-RMPRDCT
+26 ;ctd is unit cost with percent discount applied.
+27 SET RMPRCTD=RMPRAMT-RMPRDCT/RMPRQT
+28 ;
+29 SET ^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_$JUSTIFY(RMPRTOTL,0,2)_"^^^^^^"
+30 ;SERIAL#,MAKE,MODEL,LOT#,EXCLUDE/WAVER
+31 SET $PIECE(^RMPR(660,RMPR660,0),U,11)=RMPRSLN
SET $PIECE(^(0),U,24)=RMPRLTN
+32 SET $PIECE(^RMPR(660,RMPR660,9),U)=RMPRMK
SET $PIECE(^(9),U,2)=RMPRMD
+33 SET $PIECE(^RMPR(660,RMPR660,2),U,3)=RMPREW
+34 ;OIF/OEF
+35 SET DFN=RMPRDFN
DO SVC^VADPT
+36 SET RMPROEOI=$SELECT(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0)
+37 DO KVAR^VADPT
+38 IF RMPROEOI="<!>"
SET $PIECE(^RMPR(660,RMPR660,5),U,1)=1
+39 ;CONTRACT #
+40 SET $PIECE(^RMPR(660,RMPR660,2),U,9)=$PIECE(^RMPR(664,RMPRA,1,B2,0),U,14)
+41 ; ITEM
+42 SET $PIECE(^RMPR(660,RMPR660,0),U,6)=RMPRI
+43 ;NUMBER OF BIDS
+44 SET $PIECE(^RMPR(660,RMPR660,2),U,10)=RMPRNOB
+45 ;HCPCS code
+46 if RMPRHCPC
SET $PIECE(^RMPR(660,RMPR660,0),U,22)=$PIECE(^RMPR(661.1,RMPRHCPC,0),U,4)
+47 ;
+48 SET ^RMPR(660,RMPR660,"AMS")=RMPRG
SET ^RMPR(660,RMPR660,"AM")=U_U_RMPRDIS_U_RMPRSC
+49 ; /SPS removed below from above line for 75 may re-use later
+50 ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1,$P(^RMPR(660,RMPR660,"LB"),U,5)=RMPRWO
+51 if $DATA(RMPRR)
SET $PIECE(^RMPR(660,RMPR660,0),U,18)=RMPRR
+52 SET RMPRTRN=$PIECE(^RMPR(664,RMPRA,4),U,5)
+53 SET $PIECE(^RMPR(660,RMPR660,0),U,27)=DUZ
SET ^(1)=RMPRTRN_U_RMPRDES_"^^"_RMPRHCPC_"^^"_RMCPT
+54 ;If work order and no count fields need to be set
+55 IF +$PIECE(^RMPR(664,RMPRA,0),U,17)>0
Begin DoDot:1
+56 SET LRQ=$PIECE(^RMPR(664,RMPRA,0),U,17)
SET IENA=$PIECE($GET(^RMPR(660,RMPR660,0)),U,2)
SET IENB=$PIECE($GET(^RMPR(664.1,LRQ,0)),U,2)
+57 IF IENA'=IENB
SET $PIECE(^RMPR(664,RMPRA,0),U,17)=""
SET LRQ=""
QUIT
+58 DO NCNT
End DoDot:1
KILL LRQ,IENA,IENB
+59 ;note to supplier
+60 ;
+61 SET RMPRNS=""
+62 SET (D1,RD)=0
+63 FOR
SET RD=$ORDER(^RMPR(664,RMPRA,1,B2,1,RD))
if RD=""
QUIT
Begin DoDot:1
+64 SET ^RMPR(660,RMPR660,"DES",RD,0)=^RMPR(664,RMPRA,1,B2,1,RD,0)
+65 IF $LENGTH(RMPRNS)>160
QUIT
+66 SET RMPRNS=RMPRNS_" "_^RMPR(664,RMPRA,1,B2,1,RD,0)
+67 SET D1=RD
End DoDot:1
+68 SET ^RMPR(660,RMPR660,"DES",0)="^660.028^"_D1_U_D1
+69 if $DATA(RMPRDELN)
SET $PIECE(^RMPR(660,RMPR660,3),U,1)=RMPRDELN
+70 ;Date Required added for 125
SET $PIECE(^RMPR(660,RMPR660,3),U,2)=$PIECE(^RMPR(664,RMPRA,3),U,2)
+71 ;modified by #62
+72 SET ^TMP($JOB,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$GET(RMPRDFN)
+73 ;set x-refs
+74 SET DIK="^RMPR(660,"
SET DA=RMPR660
DO IX1^DIK
+75 KILL DA,DIK,RMPRTRN
+76 QUIT
NCNT ; ADD NO ADMIN COUNT TO 660 FOR WORK ORDER
+1 ;
+2 SET RMIE1=$PIECE(^RMPR(664,RMPRA,0),U,17)
+3 SET RMRWO=$PIECE(^RMPR(664.1,RMIE1,0),U,13)
+4 SET RMDAT(660,RMPR660_",",72.5)=RMRWO
+5 SET RMDAT(660,RMPR660_",",72)=RMIE1
+6 SET RMDAT(660,RMPR660_",",81)=1
+7 SET RMDAT(660,RMPR660_",",11)=14
+8 SET RMDAT(660,RMPR660_",",12)="C"
+9 DO FILE^DIE("","RMDAT","RMERROR")
+10 IF $DATA(RMERROR)
SET RESULT(0)=1_U_RMERROR
GOTO EXIT
+11 QUIT
EXIT ;
+1 KILL RMIE1,RMRWO,RMPRA,RMPR660
+2 QUIT
