source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRED5.m@ 636

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