- 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 Feb 19, 2025@00:02:53 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