RMPRED5 ;HIN/RVD-EDIT ISSUE FROM STOCK UTILITY;2/1/1999
;;3.0;PROSTHETICS;**33,41,53**;Feb 09, 1996
;Per VHA Directive 10-93-142, this routine should not be modified.
;
NHCPC(RX) ;HCPCS, location or psas/item different
D NEWVAR
D RMVAR
I $G(RO),$G(RHO) D
.S RMHCPC=RHO,RL=RO
.S:$G(RMHCPC)&$G(RL) RMHCDA=$$RMHC
.S RMQTY=RQO*-1,RMIT=RIO
.I RH'=RHO,$G(RMSTOCK) S $P(^RMPR(661.2,RMSTOCK,0),U,2)="",$P(^(0),U,13)=RMDESC
D:$G(RMHCDA) UPD
S (RMHCDA,RD6612)=""
I $G(RN),$G(RH) D
.S RMHCPC=RH,RL=RN
.S:$G(RMHCPC)&$G(RL) RMHCDA=$$RMHC
.S RMQTY=RQ,RMIT=RI S:(RH'=RHO) RSO=RSOUR,RDF=RF
D:$G(RMHCDA) UPD
S:$G(RL) $P(^RMPR(660,RMPRIEN,1),U,5)=RD6612
I $G(RH)'=$G(RHO) S $P(^RMPR(660,RMPRIEN,1),U,2)=RDES
D SETC
Q
;
QTYN(RX) ;change quantity
D NEWVAR
D RMVAR
S RMHCPC=RH,RL=RN
S:$G(RMHCPC)&$G(RL) RMHCDA=$$RMHC
S RMQTY=RQ-RQO,RMIT=RI
S RDF=RF,RSO=RSOUR
D:$G(RMHCDA) UPD
S:$G(RL) $P(^RMPR(660,RMPRIEN,1),U,2)=RDES
D SETC
Q
;
NEWVAR N X,Y,RMQTY,RMIT,RMHCPC,RMHCDA,RMLOC
N RD6612,RMBA,RBAL,RAVA,RAV,RSOUR,RSO
Q
;
RMVAR ;piece array variable
S (RDF,RSO)=""
S RN=$P(RX,"^",1)
S RH=$P(RX,"^",2)
S RHO=$P(RX,"^",3)
S RO=$P(RX,"^",4)
S RI=$P(RX,"^",5)
S RIO=$P(RX,"^",6)
S RQ=$P(RX,"^",7)
S RQO=$P(RX,"^",8)
S RSOUR=$P(RX,"^",9)
S RF=$P(RX,"^",10)
S RMDESC="Edited/Returned STOCK ISSUE"
Q
;
RMHC() ; get HCPCS IEN in #661.3
N Y
S Y=$O(^RMPR(661.3,RL,1,"B",RMHCPC,0))
Q Y
;
UPD ;update Pros Inventory balance.
Q:'$G(RMHCDA)!'$G(RL)!'$D(RMIT)
S:$D(^RMPR(661.3,RL,1,RMHCDA,0)) RMITDA=$O(^RMPR(661.3,RL,1,RMHCDA,1,"B",RMIT,0))
Q:'$G(RMITDA)
S (RBAL,RCOS)=0 D
.S RMBA=$P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,2),RBAL=RMBA-RMQTY
.S RMCO=$P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,3)
.S (RAVA,RAV)=$P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,10)
.S $P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,2)=RBAL
.S $P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,3)=RBAL*RAV
S RMDAHC=RMHCPC
D BAL^RMPR5NU1
S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
D FILE^DICN K DLAYGO S RMCOM="Edited/Returned STOCK ISSUE" ;("_RMQTY_")"
S ^RMPR(661.2,+Y,0)=DT_"^"_RDF_"^"_RSO_"^"_RMDAHC_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RL_"^"_RAVA
S (RD6612,DA)=+Y,DIK=DIC D IX1^DIK
Q
;
SETC ;
K ^RMPR(660,"AD",$P(R12(0),U,6),RMPRIEN) K:$P(R12(0),U,12)'="" ^RMPR(660,"CT",$P(R12(0),U,12),RMPRIEN)
Q
;
CHK ;check for source and type of transaction changes.
S RMCPTOLD=$P(R1(1),U,6),RMSONEW=$P(R1(0),U,14),RMTYNEW=$P(R1(0),U,4)
Q:'$G(RMHCPC)
S RMCPT1=$G(^RMPR(661.1,RMHCPC,4))
I (RMSONEW="C"),(RMCPTOLD["UE"),(RMCPT1["NU") D SOUC
I (RMSONEW="C"),(RMCPTOLD'["RR"),(RMCPTOLD'["NU"),(RMCPT1["NU") S $P(R1(1),U,6)=RMCPTOLD_",NU"
I (RMSONEW="C"),(RMCPTOLD["RR") S RMRR="NU" D DELRPRR
I (RMSONEW="V"),(RMCPTOLD["RR") S RMRR="RR" D DELRPRR
I (RMSONEW="V"),(RMCPTOLD["NU"),(RMCPT1["UE") D SOUV
I (RMSONEW="V"),(RMCPTOLD'["NU"),(RMCPTOLD'["UE"),(RMCPT1["UE") S $P(R1(1),U,6)=RMCPTOLD_",UE"
I ((RMTYNEW="R")!(RMTYNEW="X")),(RMCPTOLD'["RP"),(RMCPT1["RP") D ADDRP
I ((RMTYNEW="I")!(RMTYNEW="S")),(RMCPTOLD["RP") S RMRR="RP" D DELRPRR
Q
SOUC ;logic for updating SOURCE change for commercial.
F RMCI=1:1 S RMC=$P(RMCPTOLD,",",RMCI) I RMC="UE" S $P(RMCPTOLD,",",RMCI)="NU" S $P(R1(1),U,6)=RMCPTOLD Q
Q
;
SOUV ;logic for updating SOURCE change for VA.
F RMCI=1:1 S RMC=$P(RMCPTOLD,",",RMCI) I RMC="NU" S $P(RMCPTOLD,",",RMCI)="UE" S $P(R1(1),U,6)=RMCPTOLD Q
Q
;
DELRPRR ;logic for deleting 'RP' or 'RR' modifier with transaction change.
F RMCI=1:1:8 S RMC=$P(RMCPTOLD,",",RMCI) I RMC=RMRR S $P(RMCPTOLD,",",RMCI)="" D
.S RMF=$F(RMCPTOLD,",,"),RMFPIECE=$E(RMCPTOLD,1,RMF-2)
.S RMLPIECE=$E(RMCPTOLD,RMF,32),RMCPTOLD=RMFPIECE_RMLPIECE,RMCLEN=$L(RMCPTOLD)
.I $E(RMCPTOLD,1)="," S RMCPTOLD=$E(RMCPTOLD,2,RMCLEN)
.I $E(RMCPTOLD,RMCLEN)="," S RMCPTOLD=$E(RMCPTOLD,1,RMCLEN-1)
.S $P(R1(1),U,6)=RMCPTOLD
K RMRR Q
;
ADDRP ;logic for adding 'RP' modifier with transaction change.
S RMCPTOLD=RMCPTOLD_",RP" S $P(R1(1),U,6)=RMCPTOLD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRED5 4110 printed Sep 23, 2025@20:10:29 Page 2
RMPRED5 ;HIN/RVD-EDIT ISSUE FROM STOCK UTILITY;2/1/1999
+1 ;;3.0;PROSTHETICS;**33,41,53**;Feb 09, 1996
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
NHCPC(RX) ;HCPCS, location or psas/item different
+1 DO NEWVAR
+2 DO RMVAR
+3 IF $GET(RO)
IF $GET(RHO)
Begin DoDot:1
+4 SET RMHCPC=RHO
SET RL=RO
+5 if $GET(RMHCPC)&$GET(RL)
SET RMHCDA=$$RMHC
+6 SET RMQTY=RQO*-1
SET RMIT=RIO
+7 IF RH'=RHO
IF $GET(RMSTOCK)
SET $PIECE(^RMPR(661.2,RMSTOCK,0),U,2)=""
SET $PIECE(^(0),U,13)=RMDESC
End DoDot:1
+8 if $GET(RMHCDA)
DO UPD
+9 SET (RMHCDA,RD6612)=""
+10 IF $GET(RN)
IF $GET(RH)
Begin DoDot:1
+11 SET RMHCPC=RH
SET RL=RN
+12 if $GET(RMHCPC)&$GET(RL)
SET RMHCDA=$$RMHC
+13 SET RMQTY=RQ
SET RMIT=RI
if (RH'=RHO)
SET RSO=RSOUR
SET RDF=RF
End DoDot:1
+14 if $GET(RMHCDA)
DO UPD
+15 if $GET(RL)
SET $PIECE(^RMPR(660,RMPRIEN,1),U,5)=RD6612
+16 IF $GET(RH)'=$GET(RHO)
SET $PIECE(^RMPR(660,RMPRIEN,1),U,2)=RDES
+17 DO SETC
+18 QUIT
+19 ;
QTYN(RX) ;change quantity
+1 DO NEWVAR
+2 DO RMVAR
+3 SET RMHCPC=RH
SET RL=RN
+4 if $GET(RMHCPC)&$GET(RL)
SET RMHCDA=$$RMHC
+5 SET RMQTY=RQ-RQO
SET RMIT=RI
+6 SET RDF=RF
SET RSO=RSOUR
+7 if $GET(RMHCDA)
DO UPD
+8 if $GET(RL)
SET $PIECE(^RMPR(660,RMPRIEN,1),U,2)=RDES
+9 DO SETC
+10 QUIT
+11 ;
NEWVAR NEW X,Y,RMQTY,RMIT,RMHCPC,RMHCDA,RMLOC
+1 NEW RD6612,RMBA,RBAL,RAVA,RAV,RSOUR,RSO
+2 QUIT
+3 ;
RMVAR ;piece array variable
+1 SET (RDF,RSO)=""
+2 SET RN=$PIECE(RX,"^",1)
+3 SET RH=$PIECE(RX,"^",2)
+4 SET RHO=$PIECE(RX,"^",3)
+5 SET RO=$PIECE(RX,"^",4)
+6 SET RI=$PIECE(RX,"^",5)
+7 SET RIO=$PIECE(RX,"^",6)
+8 SET RQ=$PIECE(RX,"^",7)
+9 SET RQO=$PIECE(RX,"^",8)
+10 SET RSOUR=$PIECE(RX,"^",9)
+11 SET RF=$PIECE(RX,"^",10)
+12 SET RMDESC="Edited/Returned STOCK ISSUE"
+13 QUIT
+14 ;
RMHC() ; get HCPCS IEN in #661.3
+1 NEW Y
+2 SET Y=$ORDER(^RMPR(661.3,RL,1,"B",RMHCPC,0))
+3 QUIT Y
+4 ;
UPD ;update Pros Inventory balance.
+1 if '$GET(RMHCDA)!'$GET(RL)!'$DATA(RMIT)
QUIT
+2 if $DATA(^RMPR(661.3,RL,1,RMHCDA,0))
SET RMITDA=$ORDER(^RMPR(661.3,RL,1,RMHCDA,1,"B",RMIT,0))
+3 if '$GET(RMITDA)
QUIT
+4 SET (RBAL,RCOS)=0
Begin DoDot:1
+5 SET RMBA=$PIECE(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,2)
SET RBAL=RMBA-RMQTY
+6 SET RMCO=$PIECE(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,3)
+7 SET (RAVA,RAV)=$PIECE(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,10)
+8 SET $PIECE(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,2)=RBAL
+9 SET $PIECE(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,3)=RBAL*RAV
End DoDot:1
+10 SET RMDAHC=RMHCPC
+11 DO BAL^RMPR5NU1
+12 SET X=DT
SET DIC(0)="AEQL"
SET DLAYGO=661.2
SET DIC="^RMPR(661.2,"
KILL DD,DO
+13 ;("_RMQTY_")"
DO FILE^DICN
KILL DLAYGO
SET RMCOM="Edited/Returned STOCK ISSUE"
+14 SET ^RMPR(661.2,+Y,0)=DT_"^"_RDF_"^"_RSO_"^"_RMDAHC_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^^"_RMTOBA_"^"_RMCOM_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RL_"^"_RAVA
+15 SET (RD6612,DA)=+Y
SET DIK=DIC
DO IX1^DIK
+16 QUIT
+17 ;
SETC ;
+1 KILL ^RMPR(660,"AD",$PIECE(R12(0),U,6),RMPRIEN)
if $PIECE(R12(0),U,12)'=""
KILL ^RMPR(660,"CT",$PIECE(R12(0),U,12),RMPRIEN)
+2 QUIT
+3 ;
CHK ;check for source and type of transaction changes.
+1 SET RMCPTOLD=$PIECE(R1(1),U,6)
SET RMSONEW=$PIECE(R1(0),U,14)
SET RMTYNEW=$PIECE(R1(0),U,4)
+2 if '$GET(RMHCPC)
QUIT
+3 SET RMCPT1=$GET(^RMPR(661.1,RMHCPC,4))
+4 IF (RMSONEW="C")
IF (RMCPTOLD["UE")
IF (RMCPT1["NU")
DO SOUC
+5 IF (RMSONEW="C")
IF (RMCPTOLD'["RR")
IF (RMCPTOLD'["NU")
IF (RMCPT1["NU")
SET $PIECE(R1(1),U,6)=RMCPTOLD_",NU"
+6 IF (RMSONEW="C")
IF (RMCPTOLD["RR")
SET RMRR="NU"
DO DELRPRR
+7 IF (RMSONEW="V")
IF (RMCPTOLD["RR")
SET RMRR="RR"
DO DELRPRR
+8 IF (RMSONEW="V")
IF (RMCPTOLD["NU")
IF (RMCPT1["UE")
DO SOUV
+9 IF (RMSONEW="V")
IF (RMCPTOLD'["NU")
IF (RMCPTOLD'["UE")
IF (RMCPT1["UE")
SET $PIECE(R1(1),U,6)=RMCPTOLD_",UE"
+10 IF ((RMTYNEW="R")!(RMTYNEW="X"))
IF (RMCPTOLD'["RP")
IF (RMCPT1["RP")
DO ADDRP
+11 IF ((RMTYNEW="I")!(RMTYNEW="S"))
IF (RMCPTOLD["RP")
SET RMRR="RP"
DO DELRPRR
+12 QUIT
SOUC ;logic for updating SOURCE change for commercial.
+1 FOR RMCI=1:1
SET RMC=$PIECE(RMCPTOLD,",",RMCI)
IF RMC="UE"
SET $PIECE(RMCPTOLD,",",RMCI)="NU"
SET $PIECE(R1(1),U,6)=RMCPTOLD
QUIT
+2 QUIT
+3 ;
SOUV ;logic for updating SOURCE change for VA.
+1 FOR RMCI=1:1
SET RMC=$PIECE(RMCPTOLD,",",RMCI)
IF RMC="NU"
SET $PIECE(RMCPTOLD,",",RMCI)="UE"
SET $PIECE(R1(1),U,6)=RMCPTOLD
QUIT
+2 QUIT
+3 ;
DELRPRR ;logic for deleting 'RP' or 'RR' modifier with transaction change.
+1 FOR RMCI=1:1:8
SET RMC=$PIECE(RMCPTOLD,",",RMCI)
IF RMC=RMRR
SET $PIECE(RMCPTOLD,",",RMCI)=""
Begin DoDot:1
+2 SET RMF=$FIND(RMCPTOLD,",,")
SET RMFPIECE=$EXTRACT(RMCPTOLD,1,RMF-2)
+3 SET RMLPIECE=$EXTRACT(RMCPTOLD,RMF,32)
SET RMCPTOLD=RMFPIECE_RMLPIECE
SET RMCLEN=$LENGTH(RMCPTOLD)
+4 IF $EXTRACT(RMCPTOLD,1)=","
SET RMCPTOLD=$EXTRACT(RMCPTOLD,2,RMCLEN)
+5 IF $EXTRACT(RMCPTOLD,RMCLEN)=","
SET RMCPTOLD=$EXTRACT(RMCPTOLD,1,RMCLEN-1)
+6 SET $PIECE(R1(1),U,6)=RMCPTOLD
End DoDot:1
+7 KILL RMRR
QUIT
+8 ;
ADDRP ;logic for adding 'RP' modifier with transaction change.
+1 SET RMCPTOLD=RMCPTOLD_",RP"
SET $PIECE(R1(1),U,6)=RMCPTOLD
+2 QUIT
