RMPRPIUT ;HINCIO/ODJ - STOCK TRANSFER TRANSACTION ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;***** TRNF - create stock transfer transaction.
; implements business rules for transferring stock
; from one location to another.
;
; Inputs:
; RMPR - array with following elements...
; RMPR("QUANTITY")
; RMPR("VENDOR IEN")
;
; RMPR5F - array with 'From' Location data elements (661.5)...
; RMPR5F("IEN") - ien of 'From' Location
;
; RMPR5T - array with 'To' Location data elements (661.5)...
; RMPR5T("IEN") - ien of 'To' Location
;
; RMPR11 - array with HCPCS Item data elements (661.11)...
; RMPR11("STATION IEN") - Station number (ptr DIC(4,)
; RMPR11("HCPCS") - HCPCS Code
; RMPR11("ITEM") - HCPCS Item number
;
; Outputs:
; RMPRERR - error status returned by function
; 0 - no problems
; 1 - insufficient stock level at 'From' Location
; 19 - problem getting current stock level
; 29 - problem creating 'From' transfer
; 39 - problem creating 'To' transfer
;
TRNF(RMPR,RMPR5F,RMPR5T,RMPR11) ;
N RMPRERR,RMPR6,RMPR7,RMPR7E,RMPR4,RMPRTCOS
S RMPRERR=0
S RMPR11("STATION")=RMPR11("STATION IEN")
S RMPR7("STATION IEN")=RMPR11("STATION IEN")
S RMPR7("LOCATION IEN")=RMPR5F("IEN")
S RMPR7("HCPCS")=RMPR11("HCPCS")
S RMPR7("ITEM")=RMPR11("ITEM")
S RMPR7("UNIT")=$G(RMPR5F("UNIT"))
S RMPR7("VENDOR IEN")=RMPR("VENDOR IEN")
;
; Lock file so that -ve stock not possible
L +^RMPR(661.7,"XSLHIDS",RMPR7("STATION IEN"),RMPR7("LOCATION IEN"),RMPR7("HCPCS"),RMPR7("ITEM"))
;
; Get item's total current stock for location and vendor
S RMPRERR=$$STOCK^RMPRPIUE(.RMPR7)
I RMPRERR S RMPRERR=19 G TRNFU ;error 19 problem getting cur. qty.
;
; If not enough available stock set error code 1 and exit
I RMPR("QUANTITY")>RMPR7("QOH") D G TRNFU
. S RMPRERR=1
. S RMPR("QOH")=RMPR7("QOH")
. Q
;
; Continue the transaction
S RMPR("STATION")=RMPR11("STATION IEN")
S RMPR("LOCATION")=RMPR5F("IEN")
S RMPR("HCPCS")=RMPR11("HCPCS")
S RMPR("ITEM")=RMPR11("ITEM")
S RMPRERR=$$QCOST(.RMPR,RMPR("QUANTITY"),.RMPRTCOS)
S RMPR("VALUE")=RMPRTCOS
;
; Create transfer 'OUT' transaction (661.6)
K RMPR6
S RMPR6("SEQUENCE")=1
S RMPR6("TRAN TYPE")=7
S RMPR6("COMMENT")=$G(RMPR("COMMENT"))
S RMPR6("QUANTITY")=0-RMPR("QUANTITY")
S RMPR6("VALUE")=0-RMPR("VALUE")
S RMPR6("USER")=RMPR("USER")
S RMPR6("LOCATION")=RMPR5F("IEN")
S RMPR6("UNIT")=$G(RMPR5F("UNIT"))
S RMPR6("VENDOR")=RMPR7("VENDOR IEN")
S RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
I RMPRERR S RMPRERR=29 G TRNFU ;error 29 'From' transfer 661.6 problem
;
; Create transfer 'IN' transaction (661.6)
S RMPR6("QUANTITY")=RMPR("QUANTITY")
S RMPR6("VALUE")=RMPR("VALUE")
S RMPR6("LOCATION")=RMPR5T("IEN")
S RMPR6("UNIT")=$G(RMPR5T("UNIT"))
S RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
I RMPRERR S RMPRERR=39 G TRNFU ;error 39 'To' transfer 661.6 problem
;
; See if need to create a PIP record in 661.4
I '$D(^RMPR(661.4,"ASLHI",RMPR11("STATION IEN"),RMPR5T("IEN"),RMPR11("HCPCS"),RMPR11("ITEM"))) D
. K RMPR4
. S RMPR4("RE-ORDER QTY")=0
. S RMPRERR=$$CRE^RMPRPIX4(.RMPR4,.RMPR11,.RMPR5T)
. Q
I RMPRERR S RMPRERR=39 G TRNFU
;
; Update current stock
K RMPR7E
S RMPR7E("TRNF QTY")=RMPR("QUANTITY")
S RMPR7E("TRNF VALUE")=RMPR("VALUE")
S RMPR7E("VENDOR IEN")=RMPR("VENDOR IEN")
S RMPR7E("UNIT")=$G(RMPR("UNIT"))
S RMPRERR=$$TRNF^RMPRPIUC(.RMPR11,.RMPR5F,.RMPR5T,.RMPR7E)
I RMPRERR S RMPRERR=49 G TRNFU ;error 49 current stock update problem
;
; exit points
TRNFU L -^RMPR(661.7,"XSLHIDS",RMPR7("STATION IEN"),RMPR7("LOCATION IEN"),RMPR7("HCPCS"),RMPR7("ITEM"))
TRNFX Q RMPRERR
;
; Work out total cost of quantity based on FIFO principles
QCOST(RMPRK,RMPRQTY,RMPRTCOS) ;
N RMPRERR,RMPR,RMPR6,RMPR7,RMPRVNDR,RMPRQ,RMPRUVAL,RMPROLD,RMPREOF
S RMPRERR=0
S RMPRTCOS=0
S RMPRQ=RMPRQTY
M RMPR=RMPRK
S RMPRVNDR=RMPRK("VENDOR IEN")
QCOST1 S RMPRERR=$$NEXT^RMPRPIXE(.RMPR,"XSLHIDS","",1,.RMPROLD,.RMPREOF)
I RMPRERR S RMPRERR=1 G QCOSTX
I RMPREOF G QCOSTX
I RMPR("STATION")'=RMPRK("STATION") G QCOSTX
I RMPR("LOCATION")'=RMPRK("LOCATION") G QCOSTX
I RMPR("HCPCS")'=RMPRK("HCPCS") G QCOSTX
I RMPR("ITEM")'=RMPRK("ITEM") G QCOSTX
K RMPR7 M RMPR7=RMPR
S RMPRERR=$$GET^RMPRPIX7(.RMPR7)
I RMPRERR S RMPRERR=1 G QCOSTX
K RMPR6 M RMPR6=RMPR S RMPR6("IEN")=""
S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
S RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
I RMPRERR S RMPRERR=1 G QCOSTX
I RMPR6("VENDOR IEN")'=RMPRVNDR G QCOST1
S RMPRUVAL=$J(RMPR7("VALUE")/RMPR7("QUANTITY"),"",2)
S RMPRTCOS=RMPRTCOS+(RMPRQ*RMPRUVAL)
I RMPR7("QUANTITY")<RMPRQ S RMPRQ=RMPRQ-RMPR7("QUANTITY") G QCOST1
QCOSTX Q RMPRERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIUT 4868 printed Sep 23, 2025@20:12:41 Page 2
RMPRPIUT ;HINCIO/ODJ - STOCK TRANSFER TRANSACTION ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** TRNF - create stock transfer transaction.
+5 ; implements business rules for transferring stock
+6 ; from one location to another.
+7 ;
+8 ; Inputs:
+9 ; RMPR - array with following elements...
+10 ; RMPR("QUANTITY")
+11 ; RMPR("VENDOR IEN")
+12 ;
+13 ; RMPR5F - array with 'From' Location data elements (661.5)...
+14 ; RMPR5F("IEN") - ien of 'From' Location
+15 ;
+16 ; RMPR5T - array with 'To' Location data elements (661.5)...
+17 ; RMPR5T("IEN") - ien of 'To' Location
+18 ;
+19 ; RMPR11 - array with HCPCS Item data elements (661.11)...
+20 ; RMPR11("STATION IEN") - Station number (ptr DIC(4,)
+21 ; RMPR11("HCPCS") - HCPCS Code
+22 ; RMPR11("ITEM") - HCPCS Item number
+23 ;
+24 ; Outputs:
+25 ; RMPRERR - error status returned by function
+26 ; 0 - no problems
+27 ; 1 - insufficient stock level at 'From' Location
+28 ; 19 - problem getting current stock level
+29 ; 29 - problem creating 'From' transfer
+30 ; 39 - problem creating 'To' transfer
+31 ;
TRNF(RMPR,RMPR5F,RMPR5T,RMPR11) ;
+1 NEW RMPRERR,RMPR6,RMPR7,RMPR7E,RMPR4,RMPRTCOS
+2 SET RMPRERR=0
+3 SET RMPR11("STATION")=RMPR11("STATION IEN")
+4 SET RMPR7("STATION IEN")=RMPR11("STATION IEN")
+5 SET RMPR7("LOCATION IEN")=RMPR5F("IEN")
+6 SET RMPR7("HCPCS")=RMPR11("HCPCS")
+7 SET RMPR7("ITEM")=RMPR11("ITEM")
+8 SET RMPR7("UNIT")=$GET(RMPR5F("UNIT"))
+9 SET RMPR7("VENDOR IEN")=RMPR("VENDOR IEN")
+10 ;
+11 ; Lock file so that -ve stock not possible
+12 LOCK +^RMPR(661.7,"XSLHIDS",RMPR7("STATION IEN"),RMPR7("LOCATION IEN"),RMPR7("HCPCS"),RMPR7("ITEM"))
+13 ;
+14 ; Get item's total current stock for location and vendor
+15 SET RMPRERR=$$STOCK^RMPRPIUE(.RMPR7)
+16 ;error 19 problem getting cur. qty.
IF RMPRERR
SET RMPRERR=19
GOTO TRNFU
+17 ;
+18 ; If not enough available stock set error code 1 and exit
+19 IF RMPR("QUANTITY")>RMPR7("QOH")
Begin DoDot:1
+20 SET RMPRERR=1
+21 SET RMPR("QOH")=RMPR7("QOH")
+22 QUIT
End DoDot:1
GOTO TRNFU
+23 ;
+24 ; Continue the transaction
+25 SET RMPR("STATION")=RMPR11("STATION IEN")
+26 SET RMPR("LOCATION")=RMPR5F("IEN")
+27 SET RMPR("HCPCS")=RMPR11("HCPCS")
+28 SET RMPR("ITEM")=RMPR11("ITEM")
+29 SET RMPRERR=$$QCOST(.RMPR,RMPR("QUANTITY"),.RMPRTCOS)
+30 SET RMPR("VALUE")=RMPRTCOS
+31 ;
+32 ; Create transfer 'OUT' transaction (661.6)
+33 KILL RMPR6
+34 SET RMPR6("SEQUENCE")=1
+35 SET RMPR6("TRAN TYPE")=7
+36 SET RMPR6("COMMENT")=$GET(RMPR("COMMENT"))
+37 SET RMPR6("QUANTITY")=0-RMPR("QUANTITY")
+38 SET RMPR6("VALUE")=0-RMPR("VALUE")
+39 SET RMPR6("USER")=RMPR("USER")
+40 SET RMPR6("LOCATION")=RMPR5F("IEN")
+41 SET RMPR6("UNIT")=$GET(RMPR5F("UNIT"))
+42 SET RMPR6("VENDOR")=RMPR7("VENDOR IEN")
+43 SET RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
+44 ;error 29 'From' transfer 661.6 problem
IF RMPRERR
SET RMPRERR=29
GOTO TRNFU
+45 ;
+46 ; Create transfer 'IN' transaction (661.6)
+47 SET RMPR6("QUANTITY")=RMPR("QUANTITY")
+48 SET RMPR6("VALUE")=RMPR("VALUE")
+49 SET RMPR6("LOCATION")=RMPR5T("IEN")
+50 SET RMPR6("UNIT")=$GET(RMPR5T("UNIT"))
+51 SET RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
+52 ;error 39 'To' transfer 661.6 problem
IF RMPRERR
SET RMPRERR=39
GOTO TRNFU
+53 ;
+54 ; See if need to create a PIP record in 661.4
+55 IF '$DATA(^RMPR(661.4,"ASLHI",RMPR11("STATION IEN"),RMPR5T("IEN"),RMPR11("HCPCS"),RMPR11("ITEM")))
Begin DoDot:1
+56 KILL RMPR4
+57 SET RMPR4("RE-ORDER QTY")=0
+58 SET RMPRERR=$$CRE^RMPRPIX4(.RMPR4,.RMPR11,.RMPR5T)
+59 QUIT
End DoDot:1
+60 IF RMPRERR
SET RMPRERR=39
GOTO TRNFU
+61 ;
+62 ; Update current stock
+63 KILL RMPR7E
+64 SET RMPR7E("TRNF QTY")=RMPR("QUANTITY")
+65 SET RMPR7E("TRNF VALUE")=RMPR("VALUE")
+66 SET RMPR7E("VENDOR IEN")=RMPR("VENDOR IEN")
+67 SET RMPR7E("UNIT")=$GET(RMPR("UNIT"))
+68 SET RMPRERR=$$TRNF^RMPRPIUC(.RMPR11,.RMPR5F,.RMPR5T,.RMPR7E)
+69 ;error 49 current stock update problem
IF RMPRERR
SET RMPRERR=49
GOTO TRNFU
+70 ;
+71 ; exit points
TRNFU LOCK -^RMPR(661.7,"XSLHIDS",RMPR7("STATION IEN"),RMPR7("LOCATION IEN"),RMPR7("HCPCS"),RMPR7("ITEM"))
TRNFX QUIT RMPRERR
+1 ;
+2 ; Work out total cost of quantity based on FIFO principles
QCOST(RMPRK,RMPRQTY,RMPRTCOS) ;
+1 NEW RMPRERR,RMPR,RMPR6,RMPR7,RMPRVNDR,RMPRQ,RMPRUVAL,RMPROLD,RMPREOF
+2 SET RMPRERR=0
+3 SET RMPRTCOS=0
+4 SET RMPRQ=RMPRQTY
+5 MERGE RMPR=RMPRK
+6 SET RMPRVNDR=RMPRK("VENDOR IEN")
QCOST1 SET RMPRERR=$$NEXT^RMPRPIXE(.RMPR,"XSLHIDS","",1,.RMPROLD,.RMPREOF)
+1 IF RMPRERR
SET RMPRERR=1
GOTO QCOSTX
+2 IF RMPREOF
GOTO QCOSTX
+3 IF RMPR("STATION")'=RMPRK("STATION")
GOTO QCOSTX
+4 IF RMPR("LOCATION")'=RMPRK("LOCATION")
GOTO QCOSTX
+5 IF RMPR("HCPCS")'=RMPRK("HCPCS")
GOTO QCOSTX
+6 IF RMPR("ITEM")'=RMPRK("ITEM")
GOTO QCOSTX
+7 KILL RMPR7
MERGE RMPR7=RMPR
+8 SET RMPRERR=$$GET^RMPRPIX7(.RMPR7)
+9 IF RMPRERR
SET RMPRERR=1
GOTO QCOSTX
+10 KILL RMPR6
MERGE RMPR6=RMPR
SET RMPR6("IEN")=""
+11 SET RMPRERR=$$GET^RMPRPIX6(.RMPR6)
+12 SET RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
+13 IF RMPRERR
SET RMPRERR=1
GOTO QCOSTX
+14 IF RMPR6("VENDOR IEN")'=RMPRVNDR
GOTO QCOST1
+15 SET RMPRUVAL=$JUSTIFY(RMPR7("VALUE")/RMPR7("QUANTITY"),"",2)
+16 SET RMPRTCOS=RMPRTCOS+(RMPRQ*RMPRUVAL)
+17 IF RMPR7("QUANTITY")<RMPRQ
SET RMPRQ=RMPRQ-RMPR7("QUANTITY")
GOTO QCOST1
QCOSTX QUIT RMPRERR
