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

RMPRPIY9.m

Go to the documentation of this file.
  1. RMPRPIY9 ;HINCIO/ODJ - AE - Add/Edit Locations and Items ;3/8/01
  1. ;;3.0;PROSTHETICS;**61,108**;Feb 09, 1996
  1. Q
  1. ;
  1. ;***** AE - Add Inventory LOCATIONS and ITEMS
  1. ; option RMPR INV ADD
  1. ; Replaces AE option in old PIP (cf ^RMPR5NAE)
  1. ; no inputs required
  1. ; other than standard VISTA vars. (DUZ, etc)
  1. ;
  1. AE N RMPRERR,RMPRSTN,RMPREXC,RMPR5,RMPR1,RMPR11,RMPRVEND,RMPRTVAL,RMPRDUP
  1. N RMPRQTY,RMPRREO,RMPR61,RMPRUCST,RMPROVAL,RMPRI,RMPRUPDF
  1. ;
  1. ;***** STN - call prompt for Site/Station
  1. STN S RMPROVAL=$G(RMPRSTN("IEN"))
  1. W @IOF S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
  1. I RMPRERR G AEX
  1. I RMPREXC'="" G AEX
  1. I RMPROVAL'=RMPRSTN("IEN") K RMPR5
  1. ;
  1. ;***** LOCN - call prompt for Location
  1. LOCN W !!,"Adding Item to a Location.",!
  1. S RMPROVAL=$G(RMPR5("IEN"))
  1. S RMPRERR=$$LOCNM^RMPRPIY2(RMPRSTN("IEN"),.RMPR5,.RMPREXC)
  1. I RMPREXC="T"!(RMPREXC="^") G AEX
  1. I RMPREXC="P" G STN
  1. I RMPROVAL'=RMPR5("IEN") K RMPR1
  1. I $P($G(^RMPR(661.5,RMPR5("IEN"),0)),U,4)="I" W !!,"LOCATION IS INACTIVE AND CANNOT BE EDITED, OR ASSOCIATED ITEMS!!" K RMPR5 G LOCN
  1. LOCN2 S RMPR5("STATION")=RMPRSTN("IEN")
  1. S RMPR5("STATION IEN")=RMPRSTN("IEN")
  1. ;
  1. ;***** HCPCS - call prompt for HCPCS code
  1. HCPCS S RMPROVAL=$G(RMPR1("HCPCS"))
  1. S RMPR1("HCPCS")=""
  1. W ! S RMPRERR=$$HCPCS^RMPRPIY3(.RMPR5,.RMPR1,.RMPREXC)
  1. I RMPREXC="T"!(RMPREXC="^") G AEX
  1. I RMPREXC="P" G LOCN
  1. I RMPROVAL'=RMPR1("HCPCS") D
  1. . K RMPR11,RMPR61
  1. . S RMPR11("HCPCS")=RMPR1("HCPCS")
  1. . Q
  1. S RMPR11("STATION")=RMPRSTN("IEN")
  1. S RMPR11("STATION IEN")=RMPRSTN("IEN")
  1. ;
  1. ;***** MASIT - call prompt for master item (in 661->441)
  1. MASIT S RMPROVAL=$G(RMPR61("IEN"))
  1. D MASIT^RMPRPIY1(.RMPR61,.RMPREXC)
  1. I RMPREXC="T" G AEX
  1. I RMPREXC="P" G HCPCS
  1. I RMPREXC="^" G AEX
  1. I RMPROVAL'=RMPR61("IEN") D
  1. . S RMPRERR=$$GET^RMPRPIXD(.RMPR61)
  1. . K RMPRSRC,RMPRREO,RMPR4
  1. . S RMPR11("ITEM MASTER IEN")=RMPR61("IEN")
  1. . S RMPR11("DESCRIPTION")=RMPR61("ITEM MASTER")
  1. . S RMPR11("ITEM MASTER")=RMPR61("ITEM MASTER")
  1. . Q
  1. ;
  1. ;***** IDESC - call prompt for Item Description edit
  1. IDESC S RMPROVAL=$G(RMPR11("DESCRIPTION"))
  1. D ITED^RMPRPIY4(.RMPR11,.RMPREXC)
  1. I RMPREXC="T" G AEX
  1. I RMPREXC="P" G MASIT
  1. I RMPREXC="^" G HCPCS
  1. I $G(RMPR11("DESCRIPTION"))="" D
  1. . S RMPR11("DESCRIPTION")=RMPR61("ITEM MASTER")
  1. . S RMPR11("ITEM MASTER")=RMPR61("ITEM MASTER")
  1. . Q
  1. I RMPROVAL'=RMPR11("DESCRIPTION") D
  1. . K RMPRSRC,RMPRREO
  1. . Q
  1. ;
  1. ;***** SRC - call prompt for Source (Commercial or VA)
  1. SRC S RMPROVAL=$G(RMPRSRC)
  1. D SRC^RMPRPIY5(.RMPRSRC,.RMPREXC)
  1. I RMPREXC="P" G IDESC
  1. I RMPREXC="^" G HCPCS
  1. I RMPREXC="T" G AEX
  1. I RMPROVAL'=RMPRSRC K RMPRREO
  1. ;
  1. ; Update the inventory file (661.11)
  1. S RMPR11("SOURCE")=RMPRSRC
  1. S RMPR11("UNIT")=""
  1. S RMPRERR=0
  1. S RMPRUPDF=1 ;update flag
  1. ;
  1. ; Only create new record if one doesn't already exist
  1. I $D(^RMPR(661.11,"ASHMDI",RMPRSTN("IEN"),RMPR11("HCPCS"),RMPR61("IEN"),RMPR11("DESCRIPTION"))) D
  1. . S RMPRI=""
  1. . F S RMPRI=$O(^RMPR(661.11,"ASHMDI",RMPRSTN("IEN"),RMPR11("HCPCS"),RMPR61("IEN"),RMPR11("DESCRIPTION"),RMPRI)) Q:RMPRI="" D Q:'RMPRUPDF
  1. .. S RMPR11("ITEM")=RMPRI
  1. .. S RMPR11("IEN")=""
  1. .. S RMPRERR=$$DUP^RMPRPIX1(.RMPR11,.RMPRDUP)
  1. .. I RMPRERR S RMPRUPDF=0 Q
  1. .. I 'RMPRDUP S RMPRUPDF=0 Q
  1. .. Q
  1. . Q
  1. I RMPRUPDF D
  1. . S RMPR11("ITEM")=""
  1. . K RMPR11("IEN")
  1. . S RMPRERR=$$CRE^RMPRPIX1(.RMPR11)
  1. . S RMPR4("RE-ORDER QTY")=0
  1. . S RMPRERR=$$CRE^RMPRPIX4(.RMPR4,.RMPR11,.RMPR5)
  1. . Q
  1. I RMPRERR D G AEX
  1. . W !,"Problem updating inventory item file, please contact support."
  1. . H 3
  1. . Q
  1. ;
  1. ;***** REO - call prompt for Re-Order Quantity
  1. REO S RMPROVAL=$G(RMPRREO)
  1. D REO^RMPRPIY5(.RMPRREO,.RMPREXC)
  1. I RMPREXC="P" G SRC
  1. I RMPREXC="^" G HCPCS
  1. I RMPREXC="T" G AEX
  1. ;
  1. ; Update the reorder file (661.4)
  1. I RMPROVAL=RMPRREO G QTY
  1. S RMPR4("RE-ORDER QTY")=RMPRREO
  1. S RMPRERR=$$UPD^RMPRPIX4(.RMPR4,,)
  1. ;
  1. ; At this point the item has been added to inventory (661.11) and
  1. ; the re-order file (661.4)
  1. ; The following prompts are for receipting in a quantity of the item
  1. ;
  1. ;***** QTY - call prompt for Quantity
  1. QTY D QTY^RMPRPIY5(.RMPRQTY,.RMPREXC)
  1. I RMPREXC="P" G REO
  1. I RMPREXC="^" G HCPCS
  1. I RMPREXC="T" G AEX
  1. S RMPRQTY=+$G(RMPRQTY)
  1. I 'RMPRQTY G QTY
  1. ;
  1. ;***** UCST - call prompt for Unit Cost
  1. UCST D UCST^RMPRPIY5(.RMPRUCST,.RMPREXC)
  1. I RMPREXC="P" G QTY
  1. I RMPREXC="^" G HCPCS
  1. I RMPREXC="T" G AEX
  1. S RMPRUCST=+$G(RMPRUCST)
  1. ;
  1. ;***** TVAL - Total Value - use if Unit Cost not used
  1. TVAL I RMPRUCST D G VEND
  1. . S RMPRTVAL=$J(RMPRQTY*RMPRUCST,0,2)
  1. . W !,"TOTAL COST OF QUANTITY: "_RMPRTVAL
  1. . Q
  1. D TVAL^RMPRPIY5(.RMPRTVAL,.RMPREXC)
  1. I RMPREXC="P" G UCST
  1. I RMPREXC="^" G HCPCS
  1. I RMPREXC="T" G AEX
  1. ;
  1. ;***** VEND - call prompt for Vendor
  1. VEND D VEND^RMPRPIY5(.RMPRVEND,.RMPREXC)
  1. I RMPREXC="P" G UCST
  1. I RMPREXC="^" G HCPCS
  1. I RMPREXC="T" G AEX
  1. ;
  1. ;
  1. ;***** UNIT - call prompt for UNIT OF ISSUE
  1. UNIT D UNIT^RMPRPIY5(.RMPRUNI,.RMPREXC)
  1. I RMPREXC="P" G UCST
  1. I RMPREXC="^" G HCPCS
  1. I RMPREXC="T" G AEX
  1. ;
  1. ;***** TRANS - Create receipt record for adding an item
  1. TRANS S RMPR11("STATION")=RMPRSTN("IEN")
  1. S RMPR11("STATION IEN")=RMPRSTN("IEN")
  1. S RMPR6("QUANTITY")=RMPRQTY
  1. S RMPR6("VALUE")=RMPRTVAL
  1. S RMPR6("VENDOR")=RMPRVEND("IEN")
  1. S RMPR6("UNIT")=RMPRUNI("IEN")
  1. S RMPRERR=$$REC^RMPRPIU8(.RMPR6,.RMPR11,.RMPR5,1) ;receipt API
  1. TRANSX I RMPRERR D
  1. . W !!,"** Inventory could not be updated, please contact support",!
  1. . Q
  1. E D
  1. . W !!,"** Inventory updated.",!
  1. .;ask for number of labels and print barcode.
  1. . S RMPR11("HCPCS-ITEM")=RMPR11("HCPCS")_"-"_RMPR11("ITEM")
  1. . D NLAB^RMPRPIYY
  1. . Q
  1. K RMPR6,RMPRTVAL,RMPRQTY,RMPRUCST
  1. G HCPCS
  1. ;
  1. ;***** exit
  1. AEX D KILL^XUSCLEAN
  1. Q