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

RMPRPIU8.m

Go to the documentation of this file. 
  1. RMPRPIU8 ;HINCIO/ODJ - PIP STOCK RECEIPT UPDATE UTILITY ;3/8/01
  1.  ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
  1.  Q
  1.  ;
  1.  ;***** REC - Create a Stock Receipt Transaction for existing item
  1.  ;            Implements business rules for creating a receipt
  1.  ;            of an existing PIP HCPCS Item.
  1.  ;            called by RMPRPIYG,RMPRPIY6
  1.  ;
  1.  ; Inputs:
  1.  ;    RMPR6  - Transaction (661.6) array elements
  1.  ;    RMPR6("VENDOR")   - Vendor ien
  1.  ;    RMPR6("QUANTITY") - Receipt Quantity
  1.  ;    RMPR6("VALUE")    - Total $ value of received qty.
  1.  ;    RMPR6("COMMENT")  - (optional) comment
  1.  ;
  1.  ;    RMPR11 - HCPCS Item (661.11) array elements
  1.  ;    RMPR11("STATION") - Station ien
  1.  ;    RMPR11("HCPCS")   - HCPCS code
  1.  ;    RMPR11("ITEM")    - HCPCS Item number
  1.  ;
  1.  ;    RMPR5  - Location (661.5) array elements...
  1.  ;    RMPR5("IEN") - Location ien (ptr ^RMPR(661.5,)
  1.  ;
  1.  ;    RMPRUPO - flag true=> update, false=> dont update orders
  1.  ;    RMPR41  - array for orders
  1.  ;
  1.  ; Outputs:
  1.  ;    RMPRERR - returned by function
  1.  ;               0 - no errors
  1.  ;              19 - problem creating 661.6 rec.
  1.  ;              29 - problem creating 661.7 rec.
  1.  ;              39 - problem creating 661.9 rec.
  1.  ;              49 - problem updating 661.41 orders
  1.  ;
  1. REC(RMPR6,RMPR11,RMPR5,RMPRUPO,RMPR41) ;
  1.  N RMPRERR,RMPR6I,RMPRDIEN,RMPR7,RMPR9,RMPR41N,RMPRTOD,X
  1.  S RMPRERR=0
  1.  D NOW^%DTC S RMPRTOD=X ;today's date
  1.  ;
  1.  ; Lock current stock to prevent simultaneous access at HCPCS Item level
  1.  L +^RMPR(661.7,"XSHIDS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"))
  1.  ;
  1.  ; init. data elements for 661.6 transaction rec.
  1.  S RMPR6("COMMENT")=$G(RMPR6("COMMENT"))
  1.  S RMPR6("SEQUENCE")=1
  1.  S RMPR6("TRAN TYPE")=1 ;receipt
  1.  S RMPR6("LOCATION")=RMPR5("IEN")
  1.  S RMPR6("USER")=$G(DUZ)
  1.  S RMPR6("DATE&TIME")=""
  1.  I RMPR6("QUANTITY")=0 G RECU
  1.  ;
  1.  ; Create 661.6 transaction rec.
  1.  S RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
  1.  I RMPRERR S RMPRERR=19 G RECU ;error 19 problem with 661.6
  1.  ;
  1.  ; Update 661.7 current stock rec.
  1.  S RMPR7("DATE&TIME")=RMPR6("DATE&TIME")
  1.  S RMPR7("SEQUENCE")=RMPR6("SEQUENCE")
  1.  S RMPR7("QUANTITY")=RMPR6("QUANTITY")
  1.  S RMPR7("VALUE")=RMPR6("VALUE")
  1.  S RMPR7("UNIT")=RMPR6("UNIT")
  1.  S RMPR7("LOCATION")=RMPR6("LOCATION")
  1.  S RMPRERR=$$CRE^RMPRPIX7(.RMPR7,.RMPR11)
  1.  I RMPRERR S RMPRERR=29 G RECU ;error 29 problem with 661.7 create
  1.  ;
  1.  ; Update 661.9 daily running balance record
  1.  S RMPR9("STA")=RMPR11("STATION")
  1.  S RMPR9("HCP")=RMPR11("HCPCS")
  1.  S RMPR9("ITE")=RMPR11("ITEM")
  1.  S RMPR9("RDT")=$P(RMPR6("DATE&TIME"),".",1)
  1.  S RMPR9("TQTY")=RMPR6("QUANTITY")
  1.  S RMPR9("TCST")=RMPR6("VALUE")
  1.  S RMPRERR=$$UPCR^RMPRPIXJ(.RMPR9)
  1.  I RMPRERR S RMPRERR=39 G RECU ;error 39 problem with 661.9
  1.  ;
  1.  ; Update the orders file
  1.  I RMPRUPO,+$G(RMPR41("IEN")) D
  1.  . I RMPR6("QUANTITY")'<RMPR41("BALANCE QTY") D
  1.  .. S RMPR41N("RECEIVE QTY")=RMPR41("ORDER QTY")
  1.  .. Q
  1.  . E  D
  1.  .. S RMPR41N("RECEIVE QTY")=RMPR41("RECEIVE QTY")+RMPR6("QUANTITY")
  1.  .. Q
  1.  . S RMPR41N("STATUS")="R"
  1.  . S RMPR41N("ORDER QTY")=RMPR41("ORDER QTY")
  1.  . S RMPR41N("DATE RECEIVE")=RMPRTOD
  1.  . S RMPR41N("VENDOR")=RMPR41("VENDOR IEN")
  1.  . S RMPR41N("IEN")=RMPR41("IEN")
  1.  . S RMPRERR=$$UPD^RMPRPIXN(.RMPR41N,)
  1.  . Q
  1.  I RMPRERR S RMPRERR=49 G RECU ;error 49 problem updating 661.41 orders
  1.  ;
  1.  ; Exit points
  1. RECU L -^RMPR(661.7,"XSHIDS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"))
  1. RECX Q RMPRERR
  1.  ;
  1.  ;***** UPORD - Update Orders file for receipted item
  1.  ;              reduce outstanding balance starting with earliest,
  1.  ;              if outstanding balance reduced to 0 change status to R
  1.  ;
  1.  ; Inputs:
  1.  ;    RMPRS - Station ien
  1.  ;    RMPRH - HCPCS code
  1.  ;    RMPRI - HCPCS Item number
  1.  ;    RMPRQ - Received Quantity
  1.  ;    RMPRV - Vendor ien
  1.  ;
  1.  ; Outputs:
  1.  ;    RMPRERR - returned by function
  1.  ;               0 - no problems
  1.  ;              99 - problem with update
  1.  ;
  1. UPORD(RMPRS,RMPRH,RMPRI,RMPRQ,RMPRV) ;
  1.  N RMPRERR,RMPRD,RMPR41U,RMPR41,X,Y,RMPRTOD,RMPRX
  1.  S RMPRERR=0
  1.  D NOW^%DTC S RMPRTOD=X ;today's date
  1.  ;
  1.  ; loop on Order dates in chronologial order until receipt balance=0
  1.  ; process Open orders only and only those which match Vendor
  1.  S RMPRD=""
  1.  F  S RMPRD=$O(^RMPR(661.41,"ASSHID",RMPRS,"O",RMPRH,RMPRI,RMPRD)) Q:RMPRD=""  D  Q:RMPRERR!(RMPRQ=0)
  1.  . S RMPRX=""
  1.  . F  S RMPRX=$O(^RMPR(661.41,"ASSHID",RMPRS,"O",RMPRH,RMPRI,RMPRD,RMPRX)) Q:RMPRX=""  D  Q:RMPRERR!(RMPRQ=0)
  1.  .. S RMPR41("IEN")=RMPRX
  1.  .. S RMPRERR=$$GETI^RMPRPIXN(.RMPR41,)
  1.  .. Q:RMPR41("VENDOR")'=RMPRV
  1.  .. ;
  1.  .. ; balance less than or equal to received qty. so order completely
  1.  .. ; received
  1.  .. I RMPR41("BALANCE QTY")'>RMPRQ D
  1.  ... S RMPR41U("IEN")=RMPR41("IEN")
  1.  ... S RMPR41U("RECEIVE QTY")=RMPR41("ORDER QTY")
  1.  ... S RMPR41U("STATUS")="R" ;set status to received
  1.  ... S RMPR41U("DATE RECEIVE")=RMPRTOD ;set receive date to today
  1.  ... S RMPRQ=RMPRQ-RMPR41("BALANCE QTY")
  1.  ... S RMPRERR=$$UPD^RMPRPIXN(.RMPR41U,) ;update order
  1.  ... Q
  1.  .. ;
  1.  .. ; balance more than receipt balance so just add to received qty.
  1.  .. E  D
  1.  ... S RMPR41U("IEN")=RMPR41("IEN")
  1.  ... S RMPR41U("RECEIVE QTY")=RMPR41("RECEIVE QTY")+RMPRQ
  1.  ... S RMPR41U("DATE RECEIVE")=RMPRTOD ;set receive date to today
  1.  ... S RMPRERR=$$UPD^RMPRPIXN(.RMPR41U,) ;update order
  1.  ... S RMPRQ=0
  1.  ... Q
  1.  .. Q
  1.  . Q
  1.  I RMPRERR S RMPRERR=99 ; problem occurred
  1. UPORDX Q RMPRERR