- 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 Feb 19, 2025@00:00:47 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