RMPRPIU8 ;HINCIO/ODJ - PIP STOCK RECEIPT UPDATE UTILITY ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;***** REC - Create a Stock Receipt Transaction for existing item
; Implements business rules for creating a receipt
; of an existing PIP HCPCS Item.
; called by RMPRPIYG,RMPRPIY6
;
; Inputs:
; RMPR6 - Transaction (661.6) array elements
; RMPR6("VENDOR") - Vendor ien
; RMPR6("QUANTITY") - Receipt Quantity
; RMPR6("VALUE") - Total $ value of received qty.
; RMPR6("COMMENT") - (optional) comment
;
; RMPR11 - HCPCS Item (661.11) array elements
; RMPR11("STATION") - Station ien
; RMPR11("HCPCS") - HCPCS code
; RMPR11("ITEM") - HCPCS Item number
;
; RMPR5 - Location (661.5) array elements...
; RMPR5("IEN") - Location ien (ptr ^RMPR(661.5,)
;
; RMPRUPO - flag true=> update, false=> dont update orders
; RMPR41 - array for orders
;
; Outputs:
; RMPRERR - returned by function
; 0 - no errors
; 19 - problem creating 661.6 rec.
; 29 - problem creating 661.7 rec.
; 39 - problem creating 661.9 rec.
; 49 - problem updating 661.41 orders
;
REC(RMPR6,RMPR11,RMPR5,RMPRUPO,RMPR41) ;
N RMPRERR,RMPR6I,RMPRDIEN,RMPR7,RMPR9,RMPR41N,RMPRTOD,X
S RMPRERR=0
D NOW^%DTC S RMPRTOD=X ;today's date
;
; Lock current stock to prevent simultaneous access at HCPCS Item level
L +^RMPR(661.7,"XSHIDS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"))
;
; init. data elements for 661.6 transaction rec.
S RMPR6("COMMENT")=$G(RMPR6("COMMENT"))
S RMPR6("SEQUENCE")=1
S RMPR6("TRAN TYPE")=1 ;receipt
S RMPR6("LOCATION")=RMPR5("IEN")
S RMPR6("USER")=$G(DUZ)
S RMPR6("DATE&TIME")=""
I RMPR6("QUANTITY")=0 G RECU
;
; Create 661.6 transaction rec.
S RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
I RMPRERR S RMPRERR=19 G RECU ;error 19 problem with 661.6
;
; Update 661.7 current stock rec.
S RMPR7("DATE&TIME")=RMPR6("DATE&TIME")
S RMPR7("SEQUENCE")=RMPR6("SEQUENCE")
S RMPR7("QUANTITY")=RMPR6("QUANTITY")
S RMPR7("VALUE")=RMPR6("VALUE")
S RMPR7("UNIT")=RMPR6("UNIT")
S RMPR7("LOCATION")=RMPR6("LOCATION")
S RMPRERR=$$CRE^RMPRPIX7(.RMPR7,.RMPR11)
I RMPRERR S RMPRERR=29 G RECU ;error 29 problem with 661.7 create
;
; Update 661.9 daily running balance record
S RMPR9("STA")=RMPR11("STATION")
S RMPR9("HCP")=RMPR11("HCPCS")
S RMPR9("ITE")=RMPR11("ITEM")
S RMPR9("RDT")=$P(RMPR6("DATE&TIME"),".",1)
S RMPR9("TQTY")=RMPR6("QUANTITY")
S RMPR9("TCST")=RMPR6("VALUE")
S RMPRERR=$$UPCR^RMPRPIXJ(.RMPR9)
I RMPRERR S RMPRERR=39 G RECU ;error 39 problem with 661.9
;
; Update the orders file
I RMPRUPO,+$G(RMPR41("IEN")) D
. I RMPR6("QUANTITY")'<RMPR41("BALANCE QTY") D
.. S RMPR41N("RECEIVE QTY")=RMPR41("ORDER QTY")
.. Q
. E D
.. S RMPR41N("RECEIVE QTY")=RMPR41("RECEIVE QTY")+RMPR6("QUANTITY")
.. Q
. S RMPR41N("STATUS")="R"
. S RMPR41N("ORDER QTY")=RMPR41("ORDER QTY")
. S RMPR41N("DATE RECEIVE")=RMPRTOD
. S RMPR41N("VENDOR")=RMPR41("VENDOR IEN")
. S RMPR41N("IEN")=RMPR41("IEN")
. S RMPRERR=$$UPD^RMPRPIXN(.RMPR41N,)
. Q
I RMPRERR S RMPRERR=49 G RECU ;error 49 problem updating 661.41 orders
;
; Exit points
RECU L -^RMPR(661.7,"XSHIDS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"))
RECX Q RMPRERR
;
;***** UPORD - Update Orders file for receipted item
; reduce outstanding balance starting with earliest,
; if outstanding balance reduced to 0 change status to R
;
; Inputs:
; RMPRS - Station ien
; RMPRH - HCPCS code
; RMPRI - HCPCS Item number
; RMPRQ - Received Quantity
; RMPRV - Vendor ien
;
; Outputs:
; RMPRERR - returned by function
; 0 - no problems
; 99 - problem with update
;
UPORD(RMPRS,RMPRH,RMPRI,RMPRQ,RMPRV) ;
N RMPRERR,RMPRD,RMPR41U,RMPR41,X,Y,RMPRTOD,RMPRX
S RMPRERR=0
D NOW^%DTC S RMPRTOD=X ;today's date
;
; loop on Order dates in chronologial order until receipt balance=0
; process Open orders only and only those which match Vendor
S RMPRD=""
F S RMPRD=$O(^RMPR(661.41,"ASSHID",RMPRS,"O",RMPRH,RMPRI,RMPRD)) Q:RMPRD="" D Q:RMPRERR!(RMPRQ=0)
. S RMPRX=""
. F S RMPRX=$O(^RMPR(661.41,"ASSHID",RMPRS,"O",RMPRH,RMPRI,RMPRD,RMPRX)) Q:RMPRX="" D Q:RMPRERR!(RMPRQ=0)
.. S RMPR41("IEN")=RMPRX
.. S RMPRERR=$$GETI^RMPRPIXN(.RMPR41,)
.. Q:RMPR41("VENDOR")'=RMPRV
.. ;
.. ; balance less than or equal to received qty. so order completely
.. ; received
.. I RMPR41("BALANCE QTY")'>RMPRQ D
... S RMPR41U("IEN")=RMPR41("IEN")
... S RMPR41U("RECEIVE QTY")=RMPR41("ORDER QTY")
... S RMPR41U("STATUS")="R" ;set status to received
... S RMPR41U("DATE RECEIVE")=RMPRTOD ;set receive date to today
... S RMPRQ=RMPRQ-RMPR41("BALANCE QTY")
... S RMPRERR=$$UPD^RMPRPIXN(.RMPR41U,) ;update order
... Q
.. ;
.. ; balance more than receipt balance so just add to received qty.
.. E D
... S RMPR41U("IEN")=RMPR41("IEN")
... S RMPR41U("RECEIVE QTY")=RMPR41("RECEIVE QTY")+RMPRQ
... S RMPR41U("DATE RECEIVE")=RMPRTOD ;set receive date to today
... S RMPRERR=$$UPD^RMPRPIXN(.RMPR41U,) ;update order
... S RMPRQ=0
... Q
.. Q
. Q
I RMPRERR S RMPRERR=99 ; problem occurred
UPORDX Q RMPRERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIU8 5385 printed Sep 23, 2025@20:12:28 Page 2
RMPRPIU8 ;HINCIO/ODJ - PIP STOCK RECEIPT UPDATE UTILITY ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** REC - Create a Stock Receipt Transaction for existing item
+5 ; Implements business rules for creating a receipt
+6 ; of an existing PIP HCPCS Item.
+7 ; called by RMPRPIYG,RMPRPIY6
+8 ;
+9 ; Inputs:
+10 ; RMPR6 - Transaction (661.6) array elements
+11 ; RMPR6("VENDOR") - Vendor ien
+12 ; RMPR6("QUANTITY") - Receipt Quantity
+13 ; RMPR6("VALUE") - Total $ value of received qty.
+14 ; RMPR6("COMMENT") - (optional) comment
+15 ;
+16 ; RMPR11 - HCPCS Item (661.11) array elements
+17 ; RMPR11("STATION") - Station ien
+18 ; RMPR11("HCPCS") - HCPCS code
+19 ; RMPR11("ITEM") - HCPCS Item number
+20 ;
+21 ; RMPR5 - Location (661.5) array elements...
+22 ; RMPR5("IEN") - Location ien (ptr ^RMPR(661.5,)
+23 ;
+24 ; RMPRUPO - flag true=> update, false=> dont update orders
+25 ; RMPR41 - array for orders
+26 ;
+27 ; Outputs:
+28 ; RMPRERR - returned by function
+29 ; 0 - no errors
+30 ; 19 - problem creating 661.6 rec.
+31 ; 29 - problem creating 661.7 rec.
+32 ; 39 - problem creating 661.9 rec.
+33 ; 49 - problem updating 661.41 orders
+34 ;
REC(RMPR6,RMPR11,RMPR5,RMPRUPO,RMPR41) ;
+1 NEW RMPRERR,RMPR6I,RMPRDIEN,RMPR7,RMPR9,RMPR41N,RMPRTOD,X
+2 SET RMPRERR=0
+3 ;today's date
DO NOW^%DTC
SET RMPRTOD=X
+4 ;
+5 ; Lock current stock to prevent simultaneous access at HCPCS Item level
+6 LOCK +^RMPR(661.7,"XSHIDS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"))
+7 ;
+8 ; init. data elements for 661.6 transaction rec.
+9 SET RMPR6("COMMENT")=$GET(RMPR6("COMMENT"))
+10 SET RMPR6("SEQUENCE")=1
+11 ;receipt
SET RMPR6("TRAN TYPE")=1
+12 SET RMPR6("LOCATION")=RMPR5("IEN")
+13 SET RMPR6("USER")=$GET(DUZ)
+14 SET RMPR6("DATE&TIME")=""
+15 IF RMPR6("QUANTITY")=0
GOTO RECU
+16 ;
+17 ; Create 661.6 transaction rec.
+18 SET RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
+19 ;error 19 problem with 661.6
IF RMPRERR
SET RMPRERR=19
GOTO RECU
+20 ;
+21 ; Update 661.7 current stock rec.
+22 SET RMPR7("DATE&TIME")=RMPR6("DATE&TIME")
+23 SET RMPR7("SEQUENCE")=RMPR6("SEQUENCE")
+24 SET RMPR7("QUANTITY")=RMPR6("QUANTITY")
+25 SET RMPR7("VALUE")=RMPR6("VALUE")
+26 SET RMPR7("UNIT")=RMPR6("UNIT")
+27 SET RMPR7("LOCATION")=RMPR6("LOCATION")
+28 SET RMPRERR=$$CRE^RMPRPIX7(.RMPR7,.RMPR11)
+29 ;error 29 problem with 661.7 create
IF RMPRERR
SET RMPRERR=29
GOTO RECU
+30 ;
+31 ; Update 661.9 daily running balance record
+32 SET RMPR9("STA")=RMPR11("STATION")
+33 SET RMPR9("HCP")=RMPR11("HCPCS")
+34 SET RMPR9("ITE")=RMPR11("ITEM")
+35 SET RMPR9("RDT")=$PIECE(RMPR6("DATE&TIME"),".",1)
+36 SET RMPR9("TQTY")=RMPR6("QUANTITY")
+37 SET RMPR9("TCST")=RMPR6("VALUE")
+38 SET RMPRERR=$$UPCR^RMPRPIXJ(.RMPR9)
+39 ;error 39 problem with 661.9
IF RMPRERR
SET RMPRERR=39
GOTO RECU
+40 ;
+41 ; Update the orders file
+42 IF RMPRUPO
IF +$GET(RMPR41("IEN"))
Begin DoDot:1
+43 IF RMPR6("QUANTITY")'<RMPR41("BALANCE QTY")
Begin DoDot:2
+44 SET RMPR41N("RECEIVE QTY")=RMPR41("ORDER QTY")
+45 QUIT
End DoDot:2
+46 IF '$TEST
Begin DoDot:2
+47 SET RMPR41N("RECEIVE QTY")=RMPR41("RECEIVE QTY")+RMPR6("QUANTITY")
+48 QUIT
End DoDot:2
+49 SET RMPR41N("STATUS")="R"
+50 SET RMPR41N("ORDER QTY")=RMPR41("ORDER QTY")
+51 SET RMPR41N("DATE RECEIVE")=RMPRTOD
+52 SET RMPR41N("VENDOR")=RMPR41("VENDOR IEN")
+53 SET RMPR41N("IEN")=RMPR41("IEN")
+54 SET RMPRERR=$$UPD^RMPRPIXN(.RMPR41N,)
+55 QUIT
End DoDot:1
+56 ;error 49 problem updating 661.41 orders
IF RMPRERR
SET RMPRERR=49
GOTO RECU
+57 ;
+58 ; Exit points
RECU LOCK -^RMPR(661.7,"XSHIDS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"))
RECX QUIT RMPRERR
+1 ;
+2 ;***** UPORD - Update Orders file for receipted item
+3 ; reduce outstanding balance starting with earliest,
+4 ; if outstanding balance reduced to 0 change status to R
+5 ;
+6 ; Inputs:
+7 ; RMPRS - Station ien
+8 ; RMPRH - HCPCS code
+9 ; RMPRI - HCPCS Item number
+10 ; RMPRQ - Received Quantity
+11 ; RMPRV - Vendor ien
+12 ;
+13 ; Outputs:
+14 ; RMPRERR - returned by function
+15 ; 0 - no problems
+16 ; 99 - problem with update
+17 ;
UPORD(RMPRS,RMPRH,RMPRI,RMPRQ,RMPRV) ;
+1 NEW RMPRERR,RMPRD,RMPR41U,RMPR41,X,Y,RMPRTOD,RMPRX
+2 SET RMPRERR=0
+3 ;today's date
DO NOW^%DTC
SET RMPRTOD=X
+4 ;
+5 ; loop on Order dates in chronologial order until receipt balance=0
+6 ; process Open orders only and only those which match Vendor
+7 SET RMPRD=""
+8 FOR
SET RMPRD=$ORDER(^RMPR(661.41,"ASSHID",RMPRS,"O",RMPRH,RMPRI,RMPRD))
if RMPRD=""
QUIT
Begin DoDot:1
+9 SET RMPRX=""
+10 FOR
SET RMPRX=$ORDER(^RMPR(661.41,"ASSHID",RMPRS,"O",RMPRH,RMPRI,RMPRD,RMPRX))
if RMPRX=""
QUIT
Begin DoDot:2
+11 SET RMPR41("IEN")=RMPRX
+12 SET RMPRERR=$$GETI^RMPRPIXN(.RMPR41,)
+13 if RMPR41("VENDOR")'=RMPRV
QUIT
+14 ;
+15 ; balance less than or equal to received qty. so order completely
+16 ; received
+17 IF RMPR41("BALANCE QTY")'>RMPRQ
Begin DoDot:3
+18 SET RMPR41U("IEN")=RMPR41("IEN")
+19 SET RMPR41U("RECEIVE QTY")=RMPR41("ORDER QTY")
+20 ;set status to received
SET RMPR41U("STATUS")="R"
+21 ;set receive date to today
SET RMPR41U("DATE RECEIVE")=RMPRTOD
+22 SET RMPRQ=RMPRQ-RMPR41("BALANCE QTY")
+23 ;update order
SET RMPRERR=$$UPD^RMPRPIXN(.RMPR41U,)
+24 QUIT
End DoDot:3
+25 ;
+26 ; balance more than receipt balance so just add to received qty.
+27 IF '$TEST
Begin DoDot:3
+28 SET RMPR41U("IEN")=RMPR41("IEN")
+29 SET RMPR41U("RECEIVE QTY")=RMPR41("RECEIVE QTY")+RMPRQ
+30 ;set receive date to today
SET RMPR41U("DATE RECEIVE")=RMPRTOD
+31 ;update order
SET RMPRERR=$$UPD^RMPRPIXN(.RMPR41U,)
+32 SET RMPRQ=0
+33 QUIT
End DoDot:3
+34 QUIT
End DoDot:2
if RMPRERR!(RMPRQ=0)
QUIT
+35 QUIT
End DoDot:1
if RMPRERR!(RMPRQ=0)
QUIT
+36 ; problem occurred
IF RMPRERR
SET RMPRERR=99
UPORDX QUIT RMPRERR
