RMPRPIXJ ;HIN/RVD - INVENTORY UTILITY UPDATE BALANCE ;2/13/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
;Per VHA Directive 10-93-142, this routine should not be modified.
W !,"***Invalid Entry!!!!" Q
;
SVAL(RX) ;STARTING total Value.
;The Starting total Value is the Total Value of the previous entry
;date specified. If no previous entry, the Total Value will
;be set to ZERO.
;
;pass variable station, hcpcs, hcpcs item and date in RX local array.
; RX("STA") = station
; RX("HCP") = HCPCS
; RX("ITE") = HCPCS item
; RX("RDT") = date (starting date)
; REBAL = return variable (Starting Total Value based on the date)
N X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
S REBAL=0
S RS=RX("STA"),RH=RX("HCP"),RM=RX("ITE"),RD=RX("RDT")
Q:(RS="")!(RH="")!(RM="")!(RD="") REBAL
S RDATE=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RD),-1)
I '$G(RDATE) Q REBAL
S RI=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RDATE,0))
S RDATA=$G(^RMPR(661.9,RI,0))
S REBAL=$P(RDATA,U,9)
Q REBAL
;
;
CVAL(RX) ;CURRENT total Value
;The Current total Value is the total value based on the date specified.
;If the Date specified has no entry, the Current Total Value will be
;extracted from the previous date entry. If it has no previous entry,
;the Current Total Value will be set to ZERO.
;
;pass variable station, hcpcs, hcpcs item and date in RX local array.
; RX("STA") = station
; RX("HCP") = HCPCS
; RX("ITE") = HCPCS item
; RX("RDT") = date (current date)
; REBAL = return variable (Current Total value based on the date)
N X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
S REBAL=0
S RS=RX("STA"),RH=RX("HCP"),RM=RX("ITE"),RD=RX("RDT")
Q:(RS="")!(RH="")!(RM="")!(RD="") REBAL
S RI=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RD,0))
I '$G(RI) D I '$G(RI) Q REBAL
.S RDATE=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RD),-1)
.S:$G(RDATE) RI=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RDATE,0))
S RDATA=$G(^RMPR(661.9,RI,0))
S REBAL=$P(RDATA,U,9)
Q REBAL
;
;
SQTY(RX) ;STARTING total Quantity.
;The Starting total Quantity is the Total qty of the previous entry
;date specified. If no previous entry, the Total qty will
;be set to ZERO.
;
;pass variable station, hcpcs, hcpcs item and date in RX local array.
; RX("STA") = station
; RX("HCP") = HCPCS
; RX("ITE") = HCPCS item
; RX("RDT") = date (starting date)
; REBAL = return variable (Starting Total qty based on the date)
N X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
S REBAL=0
S RS=RX("STA"),RH=RX("HCP"),RM=RX("ITE"),RD=RX("RDT")
Q:(RS="")!(RH="")!(RM="")!(RD="") REBAL
S RDATE=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RD),-1)
I '$G(RDATE) Q REBAL
S RI=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RDATE,0))
S RDATA=$G(^RMPR(661.9,RI,0))
S REBAL=$P(RDATA,U,8)
Q REBAL
;
;
CQTY(RX) ;CURRENT total QTY
;The Current total qty is the total qty based on the date specified.
;If the Date specified has no entry, the Current Total qty will be
;extracted from the previous date entry. If it has no previous entry,
;the Current Total qty will be set to ZERO.
;
;pass variable station, hcpcs, hcpcs item and date in RX local array.
; RX("STA") = station
; RX("HCP") = HCPCS
; RX("ITE") = HCPCS item
; RX("RDT") = date (current date)
; REBAL = return variable (Current Total qty based on the date)
N X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
S RS=RX("STA"),RH=RX("HCP"),RM=RX("ITE"),RD=RX("RDT")
Q:(RS="")!(RH="")!(RM="")!(RD="") REBAL
S RI=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RD,0))
I '$G(RI) D I '$G(RI) Q REBAL
.S RDATE=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RD),-1)
.S:$G(RDATE) RI=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RDATE,0))
S RDATA=$G(^RMPR(661.9,RI,0))
S REBAL=$P(RDATA,U,8)
Q REBAL
;
TVAQT ;get total qty and cost from 661.7
N R7I,R7J,R7DAT,R7QBAL,R7CBAL
S (RMPRQBAL,RMPRCBAL)=0
F R7I=0:0 S R7I=$O(^RMPR(661.7,"XSHIDS",RS,RH,RM,R7I)) Q:R7I'>0 F R7J=0:0 S R7J=$O(^RMPR(661.7,"XSHIDS",RS,RH,RM,R7I,1,R7J)) Q:R7J'>0 D
.S R7DAT=$G(^RMPR(661.7,R7J,0))
.S R7QBAL=$P(R7DAT,U,7)
.S R7CBAL=$P(R7DAT,U,8)
.I $G(R7QBAL) S RMPRQBAL=RMPRQBAL+R7QBAL
.I $G(R7CBAL) S RMPRCBAL=RMPRCBAL+R7CBAL
Q
;
UPCR(RX) ;UPDATE or CREATE entry in 661.9
;If an entry already exist, this subroutine will update the entry.
;If no entry exist, this subroutine will create an entry.
;The calling routine should check if $G(RMERROR), then error occured.
;
;pass variable station, hcpcs, hcpcs item, date, total quantity
;and total cost in RX local array.
; RX("STA") = station
; RX("HCP") = HCPCS
; RX("ITE") = HCPCS item
; RX("RDT") = date
; RX("TQTY")= net quantity to add to balance
; RX("TCST")= net cost to add to balance
N X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
N RMPRCBAL,RMPRQBAL
S RMERROR=0
S RS=RX("STA"),RH=RX("HCP"),RM=RX("ITE"),RD=RX("RDT")
S RQ=RX("TQTY"),RC=$J(RX("TCST"),0,2)
I (RS="")!(RH="")!(RD="") S RMERROR=1 Q RMERROR
S (RMPRQBAL,RMPRCBAL)="" ;init quantity and cost balances
L +^RMPR(661.9,"ASHID",RS,RH,RM)
UPCRA K RI,RMDAT,RMERR,RDATA
;get the current total quntity and cost from 661.7.
D TVAQT
S RI=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RD,0))
;if there is an entry, update totals: (balance & cost).
I $G(RI) D
.S RDATA=$G(^RMPR(661.9,RI,0))
.;S RMPRQBAL=$P(RDATA,U,8)
.;S RMPRCBAL=$P(RDATA,U,9)
.S RMDAT(661.9,RI_",",.01)=RD
.S RMDAT(661.9,RI_",",1)=RH
.S RMDAT(661.9,RI_",",2)=RM
.S RMDAT(661.9,RI_",",4)=RS
.S RMDAT(661.9,RI_",",7)=RMPRQBAL
.S RMDAT(661.9,RI_",",8)=RMPRCBAL
.D FILE^DIE("K","RMDAT","RMERR")
.I $D(RMERR) S RMERROR=1
;if no entry, create an entry for the date being passed.
E D
.S RX("RDT")=RD
.S RMDAT(661.9,"+1,",.01)=RD
.S RMDAT(661.9,"+1,",1)=RH
.S RMDAT(661.9,"+1,",2)=RM
.S RMDAT(661.9,"+1,",4)=RS
.S RMDAT(661.9,"+1,",7)=RMPRQBAL
.S RMDAT(661.9,"+1,",8)=RMPRCBAL
.D UPDATE^DIE("","RMDAT","RI","RMERR")
.I $D(RMERR) S RMERROR=1
I RMERROR G UPCRU
;
; Get next date and continue update so that all subsequent
; balances are correct
UPCRN S RD=$O(^RMPR(661.9,"ASHID",RS,RH,RM,RD))
I RD'="" G UPCRA
UPCRU L -^RMPR(661.9,"ASHID",RS,RH,RM)
UPCRX Q RMERROR
;
ALLREC(RMA) ;reconcile all HCPCS in 661.9
Q:RMA'="TEST"
N RM11,RM11DAT,RX
S U="^",RMERR=0
S RX("TQTY")=0
S RX("TCST")=0
S RX("RDT")=DT
F RM11=0:0 S RM11=$O(^RMPR(661.11,RM11)) Q:RM11'>0 D
.S RM11DAT=^RMPR(661.11,RM11,0)
.S RX("HCP")=$P(RM11DAT,U,1)
.S RX("ITE")=$P(RM11DAT,U,2)
.S RX("STA")=$P(RM11DAT,U,4)
.W !,RX("HCP")," ",RX("ITE")," ",RX("STA")
.S RMERR=$$UPCR^RMPRPIXJ(.RX)
Q RMERR
;
NVAR ;new all variables
N X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
N RMPRCBAL,RMPRQBAL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIXJ 6767 printed Sep 23, 2025@20:12:56 Page 2
RMPRPIXJ ;HIN/RVD - INVENTORY UTILITY UPDATE BALANCE ;2/13/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 WRITE !,"***Invalid Entry!!!!"
QUIT
+4 ;
SVAL(RX) ;STARTING total Value.
+1 ;The Starting total Value is the Total Value of the previous entry
+2 ;date specified. If no previous entry, the Total Value will
+3 ;be set to ZERO.
+4 ;
+5 ;pass variable station, hcpcs, hcpcs item and date in RX local array.
+6 ; RX("STA") = station
+7 ; RX("HCP") = HCPCS
+8 ; RX("ITE") = HCPCS item
+9 ; RX("RDT") = date (starting date)
+10 ; REBAL = return variable (Starting Total Value based on the date)
+11 NEW X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
+12 SET REBAL=0
+13 SET RS=RX("STA")
SET RH=RX("HCP")
SET RM=RX("ITE")
SET RD=RX("RDT")
+14 if (RS="")!(RH="")!(RM="")!(RD="")
QUIT REBAL
+15 SET RDATE=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RD),-1)
+16 IF '$GET(RDATE)
QUIT REBAL
+17 SET RI=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RDATE,0))
+18 SET RDATA=$GET(^RMPR(661.9,RI,0))
+19 SET REBAL=$PIECE(RDATA,U,9)
+20 QUIT REBAL
+21 ;
+22 ;
CVAL(RX) ;CURRENT total Value
+1 ;The Current total Value is the total value based on the date specified.
+2 ;If the Date specified has no entry, the Current Total Value will be
+3 ;extracted from the previous date entry. If it has no previous entry,
+4 ;the Current Total Value will be set to ZERO.
+5 ;
+6 ;pass variable station, hcpcs, hcpcs item and date in RX local array.
+7 ; RX("STA") = station
+8 ; RX("HCP") = HCPCS
+9 ; RX("ITE") = HCPCS item
+10 ; RX("RDT") = date (current date)
+11 ; REBAL = return variable (Current Total value based on the date)
+12 NEW X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
+13 SET REBAL=0
+14 SET RS=RX("STA")
SET RH=RX("HCP")
SET RM=RX("ITE")
SET RD=RX("RDT")
+15 if (RS="")!(RH="")!(RM="")!(RD="")
QUIT REBAL
+16 SET RI=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RD,0))
+17 IF '$GET(RI)
Begin DoDot:1
+18 SET RDATE=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RD),-1)
+19 if $GET(RDATE)
SET RI=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RDATE,0))
End DoDot:1
IF '$GET(RI)
QUIT REBAL
+20 SET RDATA=$GET(^RMPR(661.9,RI,0))
+21 SET REBAL=$PIECE(RDATA,U,9)
+22 QUIT REBAL
+23 ;
+24 ;
SQTY(RX) ;STARTING total Quantity.
+1 ;The Starting total Quantity is the Total qty of the previous entry
+2 ;date specified. If no previous entry, the Total qty will
+3 ;be set to ZERO.
+4 ;
+5 ;pass variable station, hcpcs, hcpcs item and date in RX local array.
+6 ; RX("STA") = station
+7 ; RX("HCP") = HCPCS
+8 ; RX("ITE") = HCPCS item
+9 ; RX("RDT") = date (starting date)
+10 ; REBAL = return variable (Starting Total qty based on the date)
+11 NEW X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
+12 SET REBAL=0
+13 SET RS=RX("STA")
SET RH=RX("HCP")
SET RM=RX("ITE")
SET RD=RX("RDT")
+14 if (RS="")!(RH="")!(RM="")!(RD="")
QUIT REBAL
+15 SET RDATE=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RD),-1)
+16 IF '$GET(RDATE)
QUIT REBAL
+17 SET RI=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RDATE,0))
+18 SET RDATA=$GET(^RMPR(661.9,RI,0))
+19 SET REBAL=$PIECE(RDATA,U,8)
+20 QUIT REBAL
+21 ;
+22 ;
CQTY(RX) ;CURRENT total QTY
+1 ;The Current total qty is the total qty based on the date specified.
+2 ;If the Date specified has no entry, the Current Total qty will be
+3 ;extracted from the previous date entry. If it has no previous entry,
+4 ;the Current Total qty will be set to ZERO.
+5 ;
+6 ;pass variable station, hcpcs, hcpcs item and date in RX local array.
+7 ; RX("STA") = station
+8 ; RX("HCP") = HCPCS
+9 ; RX("ITE") = HCPCS item
+10 ; RX("RDT") = date (current date)
+11 ; REBAL = return variable (Current Total qty based on the date)
+12 NEW X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
+13 SET RS=RX("STA")
SET RH=RX("HCP")
SET RM=RX("ITE")
SET RD=RX("RDT")
+14 if (RS="")!(RH="")!(RM="")!(RD="")
QUIT REBAL
+15 SET RI=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RD,0))
+16 IF '$GET(RI)
Begin DoDot:1
+17 SET RDATE=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RD),-1)
+18 if $GET(RDATE)
SET RI=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RDATE,0))
End DoDot:1
IF '$GET(RI)
QUIT REBAL
+19 SET RDATA=$GET(^RMPR(661.9,RI,0))
+20 SET REBAL=$PIECE(RDATA,U,8)
+21 QUIT REBAL
+22 ;
TVAQT ;get total qty and cost from 661.7
+1 NEW R7I,R7J,R7DAT,R7QBAL,R7CBAL
+2 SET (RMPRQBAL,RMPRCBAL)=0
+3 FOR R7I=0:0
SET R7I=$ORDER(^RMPR(661.7,"XSHIDS",RS,RH,RM,R7I))
if R7I'>0
QUIT
FOR R7J=0:0
SET R7J=$ORDER(^RMPR(661.7,"XSHIDS",RS,RH,RM,R7I,1,R7J))
if R7J'>0
QUIT
Begin DoDot:1
+4 SET R7DAT=$GET(^RMPR(661.7,R7J,0))
+5 SET R7QBAL=$PIECE(R7DAT,U,7)
+6 SET R7CBAL=$PIECE(R7DAT,U,8)
+7 IF $GET(R7QBAL)
SET RMPRQBAL=RMPRQBAL+R7QBAL
+8 IF $GET(R7CBAL)
SET RMPRCBAL=RMPRCBAL+R7CBAL
End DoDot:1
+9 QUIT
+10 ;
UPCR(RX) ;UPDATE or CREATE entry in 661.9
+1 ;If an entry already exist, this subroutine will update the entry.
+2 ;If no entry exist, this subroutine will create an entry.
+3 ;The calling routine should check if $G(RMERROR), then error occured.
+4 ;
+5 ;pass variable station, hcpcs, hcpcs item, date, total quantity
+6 ;and total cost in RX local array.
+7 ; RX("STA") = station
+8 ; RX("HCP") = HCPCS
+9 ; RX("ITE") = HCPCS item
+10 ; RX("RDT") = date
+11 ; RX("TQTY")= net quantity to add to balance
+12 ; RX("TCST")= net cost to add to balance
+13 NEW X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
+14 NEW RMPRCBAL,RMPRQBAL
+15 SET RMERROR=0
+16 SET RS=RX("STA")
SET RH=RX("HCP")
SET RM=RX("ITE")
SET RD=RX("RDT")
+17 SET RQ=RX("TQTY")
SET RC=$JUSTIFY(RX("TCST"),0,2)
+18 IF (RS="")!(RH="")!(RD="")
SET RMERROR=1
QUIT RMERROR
+19 ;init quantity and cost balances
SET (RMPRQBAL,RMPRCBAL)=""
+20 LOCK +^RMPR(661.9,"ASHID",RS,RH,RM)
UPCRA KILL RI,RMDAT,RMERR,RDATA
+1 ;get the current total quntity and cost from 661.7.
+2 DO TVAQT
+3 SET RI=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RD,0))
+4 ;if there is an entry, update totals: (balance & cost).
+5 IF $GET(RI)
Begin DoDot:1
+6 SET RDATA=$GET(^RMPR(661.9,RI,0))
+7 ;S RMPRQBAL=$P(RDATA,U,8)
+8 ;S RMPRCBAL=$P(RDATA,U,9)
+9 SET RMDAT(661.9,RI_",",.01)=RD
+10 SET RMDAT(661.9,RI_",",1)=RH
+11 SET RMDAT(661.9,RI_",",2)=RM
+12 SET RMDAT(661.9,RI_",",4)=RS
+13 SET RMDAT(661.9,RI_",",7)=RMPRQBAL
+14 SET RMDAT(661.9,RI_",",8)=RMPRCBAL
+15 DO FILE^DIE("K","RMDAT","RMERR")
+16 IF $DATA(RMERR)
SET RMERROR=1
End DoDot:1
+17 ;if no entry, create an entry for the date being passed.
+18 IF '$TEST
Begin DoDot:1
+19 SET RX("RDT")=RD
+20 SET RMDAT(661.9,"+1,",.01)=RD
+21 SET RMDAT(661.9,"+1,",1)=RH
+22 SET RMDAT(661.9,"+1,",2)=RM
+23 SET RMDAT(661.9,"+1,",4)=RS
+24 SET RMDAT(661.9,"+1,",7)=RMPRQBAL
+25 SET RMDAT(661.9,"+1,",8)=RMPRCBAL
+26 DO UPDATE^DIE("","RMDAT","RI","RMERR")
+27 IF $DATA(RMERR)
SET RMERROR=1
End DoDot:1
+28 IF RMERROR
GOTO UPCRU
+29 ;
+30 ; Get next date and continue update so that all subsequent
+31 ; balances are correct
UPCRN SET RD=$ORDER(^RMPR(661.9,"ASHID",RS,RH,RM,RD))
+1 IF RD'=""
GOTO UPCRA
UPCRU LOCK -^RMPR(661.9,"ASHID",RS,RH,RM)
UPCRX QUIT RMERROR
+1 ;
ALLREC(RMA) ;reconcile all HCPCS in 661.9
+1 if RMA'="TEST"
QUIT
+2 NEW RM11,RM11DAT,RX
+3 SET U="^"
SET RMERR=0
+4 SET RX("TQTY")=0
+5 SET RX("TCST")=0
+6 SET RX("RDT")=DT
+7 FOR RM11=0:0
SET RM11=$ORDER(^RMPR(661.11,RM11))
if RM11'>0
QUIT
Begin DoDot:1
+8 SET RM11DAT=^RMPR(661.11,RM11,0)
+9 SET RX("HCP")=$PIECE(RM11DAT,U,1)
+10 SET RX("ITE")=$PIECE(RM11DAT,U,2)
+11 SET RX("STA")=$PIECE(RM11DAT,U,4)
+12 WRITE !,RX("HCP")," ",RX("ITE")," ",RX("STA")
+13 SET RMERR=$$UPCR^RMPRPIXJ(.RX)
End DoDot:1
+14 QUIT RMERR
+15 ;
NVAR ;new all variables
+1 NEW X,Y,RS,RH,RM,RD,RI,RQ,RC,RMERR,RMERROR,RMDAT,RDATA,RDATE,REBAL
+2 NEW RMPRCBAL,RMPRQBAL
+3 QUIT
