Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRPIUF

RMPRPIUF.m

Go to the documentation of this file.
  1. RMPRPIUF ;HINCIO/ODJ - APIs for Current Stock file 661.7 ;3/8/01
  1. ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
  1. Q
  1. ;*****
  1. ;
  1. ; Inputs:
  1. ; RMPR - an array with the following elements...
  1. ; RMPR("STATION IEN") - Station ien (ptr ^DIC(4,)
  1. ; RMPR("LOCATION IEN") - Location ien (ptr ^RMPR(661.5,)
  1. ; RMPR("VENDOR IEN") - Vendor ien
  1. ; RMPR("HCPCS") - HCPCS code (eg E0111)
  1. ; RMPR("ITEM") - HCPCS Item number (eg 1)
  1. ; RMPR("ISSUED QTY") - Quantity Issued
  1. ; RMPR("ISSUED VALUE") - Issue Value
  1. ;
  1. ; RMPRERR - function return...
  1. ; 0 - no errors
  1. ; 1 - null Station ien input
  1. ; 2 - null Location ien input
  1. ; 3 - null HCPCS code input
  1. ; 4 - null Item input
  1. ; 5 - issued qty not greater than 0
  1. ; 6 - problem with 661.7 file
  1. ; 7 - null Vendor input
  1. ; 8 - problem with 661.6 file
  1. FIFO(RMPR) ;
  1. N RMPRERR,RMPRK,RMPROLD,RMPREOF,RMPR7,RMPR7I,RMPRIBAL,RMPRVBAL
  1. N RMPRUVAL,RMPRI,RMPR6,RMPR6I,RMPR7U
  1. S RMPRERR=0
  1. S RMPRK("STATION")=$G(RMPR("STATION IEN"))
  1. I RMPRK("STATION")="" S RMPRERR=1 G FIFOX
  1. S RMPRK("LOCATION")=$G(RMPR("LOCATION IEN"))
  1. I RMPRK("LOCATION")="" S RMPRERR=2 G FIFOX
  1. S RMPRK("HCPCS")=$G(RMPR("HCPCS"))
  1. I RMPRK("HCPCS")="" S RMPRERR=3 G FIFOX
  1. S RMPRK("ITEM")=$G(RMPR("ITEM"))
  1. I RMPRK("ITEM")="" S RMPRERR=4 G FIFOX
  1. I $G(RMPR("VENDOR IEN"))="" S RMPRERR=7 G FIFOX
  1. I '+$G(RMPR("ISSUED QTY")) S RMPRERR=5 G FIFOX
  1. S RMPRIBAL=RMPR("ISSUED QTY") ; init issued qty. balance
  1. S RMPRVBAL=+$G(RMPR("ISSUED VALUE")) ; init issue value balance
  1. S RMPRUVAL=RMPRVBAL/RMPRIBAL ; unit cost per issued item
  1. ;
  1. ; Lock 661.7
  1. L +^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
  1. ;
  1. ; Primary loop on all records for Stn, Loc, HCPCS and Item until stock
  1. ; depleted by the issued amount
  1. FIFOA S RMPRERR=$$NEXT^RMPRPIXE(.RMPRK,"XSLHIDS","",1,.RMPROLD,.RMPREOF)
  1. I RMPRERR S RMPRERR=6 G FIFOU
  1. I RMPREOF G FIFOU
  1. I RMPRK("ITEM")'=RMPROLD("ITEM") G FIFOU
  1. I RMPRK("HCPCS")'=RMPROLD("HCPCS") G FIFOU
  1. I RMPRK("LOCATION")'=RMPROLD("LOCATION") G FIFOU
  1. I RMPRK("STATION")'=RMPROLD("STATION") G FIFOU
  1. K RMPR7 S RMPR7("IEN")=RMPRK("IEN")
  1. S RMPRERR=$$GET^RMPRPIX7(.RMPR7) ; read in current stock rec.
  1. I RMPRERR S RMPRERR=6 G FIFOU
  1. K RMPR7I
  1. S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
  1. I RMPRERR S RMPRERR=6 G FIFOU
  1. ;
  1. ; 2nd Loop on 661.6 transactions so as to match vendor
  1. S RMPRI=""
  1. FIFOB S RMPRI=$O(^RMPR(661.6,"XHDS",RMPR7I("HCPCS"),RMPR7I("DATE&TIME"),RMPR7I("SEQUENCE"),RMPRI))
  1. I RMPRI="" G FIFOA
  1. K RMPR6 S RMPR6("IEN")=RMPRI S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
  1. I RMPRERR S RMPRERR=8 G FIFOU
  1. S RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
  1. I RMPRERR S RMPRERR=8 G FIFOU
  1. I RMPR6("VENDOR IEN")'=RMPR("VENDOR IEN") G FIFOB
  1. K RMPR7U
  1. S RMPR7U("IEN")=RMPR7("IEN")
  1. S RMPR7U("QUANTITY")=RMPR7("QUANTITY")
  1. S RMPR7U("VALUE")=RMPR7("VALUE")
  1. ;
  1. ; If issued balance less than on-hand quantity then update
  1. ; the on-hand record
  1. I RMPRIBAL<RMPR7U("QUANTITY") D
  1. . S RMPR7U("QUANTITY")=RMPR7U("QUANTITY")-RMPRIBAL
  1. . S RMPR7U("VALUE")=RMPR7U("VALUE")-RMPRVBAL
  1. . S RMPRERR=$$UPD^RMPRPIX7(.RMPR7U,)
  1. . S RMPRIBAL=0
  1. . Q
  1. ;
  1. ; If issued balance not less than on-hand quantity then delete
  1. ; the on-hand record
  1. E D
  1. . S RMPRIBAL=RMPRIBAL-RMPR7U("QUANTITY")
  1. . S RMPRVBAL=RMPRVBAL-($J(RMPR7U("QUANTITY")*RMPRUVAL,0,2))
  1. . S RMPRERR=$$DEL^RMPRPIX7(.RMPR7U)
  1. . Q
  1. I RMPRERR S RMPRERR=6 G FIFOU
  1. G:RMPRIBAL FIFOB ; next transaction if still got issue balance
  1. ;
  1. ; exit points
  1. FIFOU L -^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
  1. FIFOX Q RMPRERR