RMPRPIUB ;HINCIO/ODJ - APIs for file 661.7 ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;
; Inputs:
; RMPR - an array with the following elements...
; RMPR("STATION IEN") - Station ien (ptr ^DIC(4,)
; RMPR("LOCATION IEN") - Location ien (ptr ^RMPR(661.5,)
; RMPR("HCPCS") - HCPCS code (eg E0111)
; RMPR("ITEM") - HCPCS Item number (eg 1)
; RMPR("ISSUED QTY") - Quantity Issued
; RMPR("ISSUED VALUE") - Issue Value
;
; RMPRERR - function return...
; 0 - no errors
; 1 - null Station ien input
; 2 - null Location ien input
; 3 - null HCPCS code input
; 4 - null Item input
; 5 - issued qty not greater than 0
; 6 - problem with 661.7 file
FIFO(RMPR) ;
N RMPRERR,RMPRK,RMPROLD,RMPREOF,RMPR7,RMPR7I,RMPRIBAL,RMPRVBAL
N RMPRUVAL
S RMPRERR=0
S RMPRK("STATION")=$G(RMPR("STATION IEN"))
I RMPRK("STATION")="" S RMPRERR=1 G FIFOX
S RMPRK("LOCATION")=$G(RMPR("LOCATION IEN"))
I RMPRK("LOCATION")="" S RMPRERR=2 G FIFOX
S RMPRK("HCPCS")=$G(RMPR("HCPCS"))
I RMPRK("HCPCS")="" S RMPRERR=3 G FIFOX
S RMPRK("ITEM")=$G(RMPR("ITEM"))
S RMPRK("IEN")=$G(RMPR("IEN"))
S RMPRK("DATE&TIME")=$G(RMPR("DATE&TIME"))
I RMPRK("ITEM")="" S RMPRERR=4 G FIFOX
I '+$G(RMPR("ISSUED QTY")) S RMPRERR=5 G FIFOX
S RMPRIBAL=RMPR("ISSUED QTY") ; init issued qty. balance
S RMPRVBAL=+$G(RMPR("ISSUED VALUE")) ; init issue value balance
S RMPRUVAL=RMPRVBAL/RMPRIBAL ; unit cost per issued item
L +^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
G PASS
;
; Loop on all records for Stn, Loc, HCPCS and Item until stock
; depleted by the issued amount
FIFOA S RMPRERR=$$NEXT^RMPRPIXE(.RMPRK,"XSLHIDS","",1,.RMPROLD,.RMPREOF)
I RMPRERR S RMPRERR=6 G FIFOU
I RMPREOF G FIFOU
I RMPRK("ITEM")'=RMPROLD("ITEM") G FIFOU
I RMPRK("HCPCS")'=RMPROLD("HCPCS") G FIFOU
I RMPRK("LOCATION")'=RMPROLD("LOCATION") G FIFOU
I RMPRK("STATION")'=RMPROLD("STATION") G FIFOU
PASS K RMPR7 M RMPR7=RMPRK
S RMPRERR=$$GET^RMPRPIX7(.RMPR7) ; read in current stock rec.
I RMPRERR S RMPRERR=6 G FIFOU
K RMPR7I
S RMPR7I("IEN")=RMPR7("IEN")
S RMPR7I("QUANTITY")=RMPR7("QUANTITY")
S RMPR7I("VALUE")=RMPR7("VALUE")
;
; If issued balance less than on-hand quantity then update
; the on-hand record
I RMPRIBAL<RMPR7I("QUANTITY") D
. S RMPR7I("QUANTITY")=RMPR7I("QUANTITY")-RMPRIBAL
. S RMPR7I("VALUE")=RMPR7I("VALUE")-RMPRVBAL
. S RMPRERR=$$UPD^RMPRPIX7(.RMPR7I,)
. S RMPRIBAL=0
. Q
;
; If issued balance not less than on-hand quantity the delete
; the on-hand record
E D
. S RMPRIBAL=RMPRIBAL-RMPR7I("QUANTITY")
. S RMPRVBAL=RMPRVBAL-($J(RMPR7I("QUANTITY")*RMPRUVAL,0,2))
. S RMPRERR=$$DEL^RMPRPIX7(.RMPR7I)
. Q
I RMPRERR S RMPRERR=6 G FIFOU
G:RMPRIBAL FIFOA ; next stock rec. if still got issue balance
;
; exit points
FIFOU L -^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
FIFOX Q RMPRERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIUB 3108 printed Sep 23, 2025@20:12:31 Page 2
RMPRPIUB ;HINCIO/ODJ - APIs for file 661.7 ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;
+5 ; Inputs:
+6 ; RMPR - an array with the following elements...
+7 ; RMPR("STATION IEN") - Station ien (ptr ^DIC(4,)
+8 ; RMPR("LOCATION IEN") - Location ien (ptr ^RMPR(661.5,)
+9 ; RMPR("HCPCS") - HCPCS code (eg E0111)
+10 ; RMPR("ITEM") - HCPCS Item number (eg 1)
+11 ; RMPR("ISSUED QTY") - Quantity Issued
+12 ; RMPR("ISSUED VALUE") - Issue Value
+13 ;
+14 ; RMPRERR - function return...
+15 ; 0 - no errors
+16 ; 1 - null Station ien input
+17 ; 2 - null Location ien input
+18 ; 3 - null HCPCS code input
+19 ; 4 - null Item input
+20 ; 5 - issued qty not greater than 0
+21 ; 6 - problem with 661.7 file
FIFO(RMPR) ;
+1 NEW RMPRERR,RMPRK,RMPROLD,RMPREOF,RMPR7,RMPR7I,RMPRIBAL,RMPRVBAL
+2 NEW RMPRUVAL
+3 SET RMPRERR=0
+4 SET RMPRK("STATION")=$GET(RMPR("STATION IEN"))
+5 IF RMPRK("STATION")=""
SET RMPRERR=1
GOTO FIFOX
+6 SET RMPRK("LOCATION")=$GET(RMPR("LOCATION IEN"))
+7 IF RMPRK("LOCATION")=""
SET RMPRERR=2
GOTO FIFOX
+8 SET RMPRK("HCPCS")=$GET(RMPR("HCPCS"))
+9 IF RMPRK("HCPCS")=""
SET RMPRERR=3
GOTO FIFOX
+10 SET RMPRK("ITEM")=$GET(RMPR("ITEM"))
+11 SET RMPRK("IEN")=$GET(RMPR("IEN"))
+12 SET RMPRK("DATE&TIME")=$GET(RMPR("DATE&TIME"))
+13 IF RMPRK("ITEM")=""
SET RMPRERR=4
GOTO FIFOX
+14 IF '+$GET(RMPR("ISSUED QTY"))
SET RMPRERR=5
GOTO FIFOX
+15 ; init issued qty. balance
SET RMPRIBAL=RMPR("ISSUED QTY")
+16 ; init issue value balance
SET RMPRVBAL=+$GET(RMPR("ISSUED VALUE"))
+17 ; unit cost per issued item
SET RMPRUVAL=RMPRVBAL/RMPRIBAL
+18 LOCK +^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
+19 GOTO PASS
+20 ;
+21 ; Loop on all records for Stn, Loc, HCPCS and Item until stock
+22 ; depleted by the issued amount
FIFOA SET RMPRERR=$$NEXT^RMPRPIXE(.RMPRK,"XSLHIDS","",1,.RMPROLD,.RMPREOF)
+1 IF RMPRERR
SET RMPRERR=6
GOTO FIFOU
+2 IF RMPREOF
GOTO FIFOU
+3 IF RMPRK("ITEM")'=RMPROLD("ITEM")
GOTO FIFOU
+4 IF RMPRK("HCPCS")'=RMPROLD("HCPCS")
GOTO FIFOU
+5 IF RMPRK("LOCATION")'=RMPROLD("LOCATION")
GOTO FIFOU
+6 IF RMPRK("STATION")'=RMPROLD("STATION")
GOTO FIFOU
PASS KILL RMPR7
MERGE RMPR7=RMPRK
+1 ; read in current stock rec.
SET RMPRERR=$$GET^RMPRPIX7(.RMPR7)
+2 IF RMPRERR
SET RMPRERR=6
GOTO FIFOU
+3 KILL RMPR7I
+4 SET RMPR7I("IEN")=RMPR7("IEN")
+5 SET RMPR7I("QUANTITY")=RMPR7("QUANTITY")
+6 SET RMPR7I("VALUE")=RMPR7("VALUE")
+7 ;
+8 ; If issued balance less than on-hand quantity then update
+9 ; the on-hand record
+10 IF RMPRIBAL<RMPR7I("QUANTITY")
Begin DoDot:1
+11 SET RMPR7I("QUANTITY")=RMPR7I("QUANTITY")-RMPRIBAL
+12 SET RMPR7I("VALUE")=RMPR7I("VALUE")-RMPRVBAL
+13 SET RMPRERR=$$UPD^RMPRPIX7(.RMPR7I,)
+14 SET RMPRIBAL=0
+15 QUIT
End DoDot:1
+16 ;
+17 ; If issued balance not less than on-hand quantity the delete
+18 ; the on-hand record
+19 IF '$TEST
Begin DoDot:1
+20 SET RMPRIBAL=RMPRIBAL-RMPR7I("QUANTITY")
+21 SET RMPRVBAL=RMPRVBAL-($JUSTIFY(RMPR7I("QUANTITY")*RMPRUVAL,0,2))
+22 SET RMPRERR=$$DEL^RMPRPIX7(.RMPR7I)
+23 QUIT
End DoDot:1
+24 IF RMPRERR
SET RMPRERR=6
GOTO FIFOU
+25 ; next stock rec. if still got issue balance
if RMPRIBAL
GOTO FIFOA
+26 ;
+27 ; exit points
FIFOU LOCK -^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
FIFOX QUIT RMPRERR
