RMPRPIUF ;HINCIO/ODJ - APIs for Current Stock 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("VENDOR IEN") - Vendor ien
; 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
; 7 - null Vendor input
; 8 - problem with 661.6 file
FIFO(RMPR) ;
N RMPRERR,RMPRK,RMPROLD,RMPREOF,RMPR7,RMPR7I,RMPRIBAL,RMPRVBAL
N RMPRUVAL,RMPRI,RMPR6,RMPR6I,RMPR7U
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"))
I RMPRK("ITEM")="" S RMPRERR=4 G FIFOX
I $G(RMPR("VENDOR IEN"))="" S RMPRERR=7 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
;
; Lock 661.7
L +^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
;
; Primary 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
K RMPR7 S RMPR7("IEN")=RMPRK("IEN")
S RMPRERR=$$GET^RMPRPIX7(.RMPR7) ; read in current stock rec.
I RMPRERR S RMPRERR=6 G FIFOU
K RMPR7I
S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
I RMPRERR S RMPRERR=6 G FIFOU
;
; 2nd Loop on 661.6 transactions so as to match vendor
S RMPRI=""
FIFOB S RMPRI=$O(^RMPR(661.6,"XHDS",RMPR7I("HCPCS"),RMPR7I("DATE&TIME"),RMPR7I("SEQUENCE"),RMPRI))
I RMPRI="" G FIFOA
K RMPR6 S RMPR6("IEN")=RMPRI S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
I RMPRERR S RMPRERR=8 G FIFOU
S RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
I RMPRERR S RMPRERR=8 G FIFOU
I RMPR6("VENDOR IEN")'=RMPR("VENDOR IEN") G FIFOB
K RMPR7U
S RMPR7U("IEN")=RMPR7("IEN")
S RMPR7U("QUANTITY")=RMPR7("QUANTITY")
S RMPR7U("VALUE")=RMPR7("VALUE")
;
; If issued balance less than on-hand quantity then update
; the on-hand record
I RMPRIBAL<RMPR7U("QUANTITY") D
. S RMPR7U("QUANTITY")=RMPR7U("QUANTITY")-RMPRIBAL
. S RMPR7U("VALUE")=RMPR7U("VALUE")-RMPRVBAL
. S RMPRERR=$$UPD^RMPRPIX7(.RMPR7U,)
. S RMPRIBAL=0
. Q
;
; If issued balance not less than on-hand quantity then delete
; the on-hand record
E D
. S RMPRIBAL=RMPRIBAL-RMPR7U("QUANTITY")
. S RMPRVBAL=RMPRVBAL-($J(RMPR7U("QUANTITY")*RMPRUVAL,0,2))
. S RMPRERR=$$DEL^RMPRPIX7(.RMPR7U)
. Q
I RMPRERR S RMPRERR=6 G FIFOU
G:RMPRIBAL FIFOB ; next transaction 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[HRMPRPIUF 3782 printed Apr 09, 2024@21:38:30 Page 2
RMPRPIUF ;HINCIO/ODJ - APIs for Current Stock 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("VENDOR IEN") - Vendor ien
+10 ; RMPR("HCPCS") - HCPCS code (eg E0111)
+11 ; RMPR("ITEM") - HCPCS Item number (eg 1)
+12 ; RMPR("ISSUED QTY") - Quantity Issued
+13 ; RMPR("ISSUED VALUE") - Issue Value
+14 ;
+15 ; RMPRERR - function return...
+16 ; 0 - no errors
+17 ; 1 - null Station ien input
+18 ; 2 - null Location ien input
+19 ; 3 - null HCPCS code input
+20 ; 4 - null Item input
+21 ; 5 - issued qty not greater than 0
+22 ; 6 - problem with 661.7 file
+23 ; 7 - null Vendor input
+24 ; 8 - problem with 661.6 file
FIFO(RMPR) ;
+1 NEW RMPRERR,RMPRK,RMPROLD,RMPREOF,RMPR7,RMPR7I,RMPRIBAL,RMPRVBAL
+2 NEW RMPRUVAL,RMPRI,RMPR6,RMPR6I,RMPR7U
+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 IF RMPRK("ITEM")=""
SET RMPRERR=4
GOTO FIFOX
+12 IF $GET(RMPR("VENDOR IEN"))=""
SET RMPRERR=7
GOTO FIFOX
+13 IF '+$GET(RMPR("ISSUED QTY"))
SET RMPRERR=5
GOTO FIFOX
+14 ; init issued qty. balance
SET RMPRIBAL=RMPR("ISSUED QTY")
+15 ; init issue value balance
SET RMPRVBAL=+$GET(RMPR("ISSUED VALUE"))
+16 ; unit cost per issued item
SET RMPRUVAL=RMPRVBAL/RMPRIBAL
+17 ;
+18 ; Lock 661.7
+19 LOCK +^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
+20 ;
+21 ; Primary 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
+7 KILL RMPR7
SET RMPR7("IEN")=RMPRK("IEN")
+8 ; read in current stock rec.
SET RMPRERR=$$GET^RMPRPIX7(.RMPR7)
+9 IF RMPRERR
SET RMPRERR=6
GOTO FIFOU
+10 KILL RMPR7I
+11 SET RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
+12 IF RMPRERR
SET RMPRERR=6
GOTO FIFOU
+13 ;
+14 ; 2nd Loop on 661.6 transactions so as to match vendor
+15 SET RMPRI=""
FIFOB SET RMPRI=$ORDER(^RMPR(661.6,"XHDS",RMPR7I("HCPCS"),RMPR7I("DATE&TIME"),RMPR7I("SEQUENCE"),RMPRI))
+1 IF RMPRI=""
GOTO FIFOA
+2 KILL RMPR6
SET RMPR6("IEN")=RMPRI
SET RMPRERR=$$GET^RMPRPIX6(.RMPR6)
+3 IF RMPRERR
SET RMPRERR=8
GOTO FIFOU
+4 SET RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
+5 IF RMPRERR
SET RMPRERR=8
GOTO FIFOU
+6 IF RMPR6("VENDOR IEN")'=RMPR("VENDOR IEN")
GOTO FIFOB
+7 KILL RMPR7U
+8 SET RMPR7U("IEN")=RMPR7("IEN")
+9 SET RMPR7U("QUANTITY")=RMPR7("QUANTITY")
+10 SET RMPR7U("VALUE")=RMPR7("VALUE")
+11 ;
+12 ; If issued balance less than on-hand quantity then update
+13 ; the on-hand record
+14 IF RMPRIBAL<RMPR7U("QUANTITY")
Begin DoDot:1
+15 SET RMPR7U("QUANTITY")=RMPR7U("QUANTITY")-RMPRIBAL
+16 SET RMPR7U("VALUE")=RMPR7U("VALUE")-RMPRVBAL
+17 SET RMPRERR=$$UPD^RMPRPIX7(.RMPR7U,)
+18 SET RMPRIBAL=0
+19 QUIT
End DoDot:1
+20 ;
+21 ; If issued balance not less than on-hand quantity then delete
+22 ; the on-hand record
+23 IF '$TEST
Begin DoDot:1
+24 SET RMPRIBAL=RMPRIBAL-RMPR7U("QUANTITY")
+25 SET RMPRVBAL=RMPRVBAL-($JUSTIFY(RMPR7U("QUANTITY")*RMPRUVAL,0,2))
+26 SET RMPRERR=$$DEL^RMPRPIX7(.RMPR7U)
+27 QUIT
End DoDot:1
+28 IF RMPRERR
SET RMPRERR=6
GOTO FIFOU
+29 ; next transaction if still got issue balance
if RMPRIBAL
GOTO FIFOB
+30 ;
+31 ; exit points
FIFOU LOCK -^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
FIFOX QUIT RMPRERR
