- 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 Feb 18, 2025@23:58:11 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