source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYH.m@ 1800

RMPRPIYH ;HINCIO/ODJ - PIP Stock Receipt Prompts ;3/8/01
 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
 Q
 ;
 ;***** LOCNM - Prompt for receiving location
 ;              must be in 661.5 and active
LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
 N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
 D NOW^%DTC S RMPRTDT=X ;today's date
 S RMPREXC=""
 S RMPRERR=0
 S DIR(0)="FOA"
 S DIR("A")="Enter Receiving Location: "
 S DIR("?")="^D QM^RMPRPIYB"
 S DIR("??")="^D QM2^RMPRPIYB"
LOCNM1 D ^DIR
 I $D(DTOUT) S RMPREXC="T" G LOCNMX
 I $D(DIROUT) S RMPREXC="P" G LOCNMX
 I X=""!(X["^") S RMPREXC="^" G LOCNMX
 K RMPR5
 S RMPR5("STATION")=RMPRSTN
 S RMPR5("STATION IEN")=RMPRSTN
 D LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5)
 I RMPREXC'="" G LOCNM1
 I $G(RMPR5("IEN"))="" D  G LOCNM1
 . W !,"Please enter a valid Location"
 . Q
 ;
 ; exit
LOCNMX Q RMPRERR
 ;
 ; Get OK
OK(RMPRYN,RMPREXC) ;
 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
 S RMPREXC=""
 S DIR("A")="         ...OK"
 S DIR("B")="Yes"
 S DIR(0)="Y"
 D ^DIR
 I $D(DTOUT) S RMPREXC="T" G OKX
 I $D(DIROUT) S RMPREXC="P" G OKX
 I X=""!(X["^") S RMPREXC="^" G OKX
 S RMPRYN="N" S:Y RMPRYN="Y"
OKX Q
 ;
 ;***** HCPCS - Get a HCPCS code from 661.4
HCPCS(RMPR5,RMPR1,RMPREXC) ;
 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN,RMPRLCN,RMPR1N
 S DIR("A")="Select HCPCS to RECEIVE: "
 S RMPRERR=0
 S RMPREXC=""
 S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))
 S RMPRSTN=RMPR5("STATION")
 S RMPRLCN=RMPR5("IEN")
 S DIR(0)="FOA"
 S DIR("?")="^D QM^RMPRPIYC"
 S DIR("??")="^D QM2^RMPRPIYC"
HCPCS1 K RMPR1N D ^DIR
 I $D(DTOUT) S RMPREXC="T" G HCPCSX
 I $D(DIROUT) S RMPREXC="P" G HCPCSX
 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
 D LIKE^RMPRPIYC(RMPRSTN,RMPRLCN,X,.RMPREXC,.RMPR1N)
 I RMPREXC'="" G HCPCS1
 I $G(RMPR1N("IEN"))'="" G HCPCSU
 G HCPCS1
HCPCSU K RMPR1 M RMPR1=RMPR1N
HCPCSX Q RMPRERR
 ;
 ;***** ITEM - Get an Item - restrict choice to Location and HCPC
ITEM(RMPRSTN,RMPRLCN,RMPRHCPC,RMPR11,RMPR4,RMPREXC) ;
 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRYN
 S RMPRERR=0
 S RMPREXC=""
 I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX
 I $G(RMPRLCN)="" S RMPRERR=2 G ITEMX
 I $G(RMPRHCPC)="" S RMPRERR=3 G ITEMX
 K RMPR11,RMPR4
 S DIR(0)="FOA^1:50"
 S DIR("A")="Enter Item to RECEIVE: "
 S DIR("?")="^D QM^RMPRPIY8"
 S DIR("??")="^D QQM^RMPRPIY8"
ITEMA1 D ^DIR
 I $D(DTOUT) S RMPREXC="T" G ITEMX
 I $D(DIROUT) S RMPREXC="P" G ITEMX
 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G ITEMX
 D LIKE^RMPRPIY8(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11,.RMPR4)
 I RMPREXC="T" G ITEMX
 I RMPREXC="P" G ITEMX
 I RMPREXC="^" G ITEMA1
 I RMPR4("IEN")="" D  G ITEMA1
 . W !,"Cannot locate ITEM with this sequence NUMBER"
 . Q
 W "  ",RMPR11("HCPCS-ITEM"),"  ",RMPR11("DESCRIPTION")
 D OK(.RMPRYN,.RMPREXC)
 I RMPRYN'="Y" G ITEMA1
 G ITEMX
ITEMX Q RMPRERR
 ;
 ; Get Quantity
QTY(RMPRQTY,RMPREXC) ;
 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
 S RMPRQTY=$G(RMPRQTY)
 S RMPRERR=0
 S DIR(0)="NA^1:99999:0"
 S DIR("A")="Quantity to Receive: "
 S:RMPRQTY'="" DIR("B")=RMPRQTY
 D ^DIR
 I $D(DTOUT) S RMPREXC="T" G QTYX
 I $D(DIROUT) S RMPREXC="P" G QTYX
 I X=""!(X["^") S RMPREXC="^" G QTYX
 S RMPRQTY=Y
QTYX Q RMPRERR
 ;
 ; Get total $ value
TVAL(RMPRTVAL,RMPREXC) ;
 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
 S RMPRTVAL=$G(RMPRTVAL)
 S RMPRERR=0
 S DIR(0)="NOA^0:999999:2"
 S DIR("A")="Total Cost of Item: "
 D ^DIR
 I $D(DTOUT) S RMPREXC="T" G TVALX
 I $D(DIROUT) S RMPREXC="P" G TVALX
 I X["^" S RMPREXC="^" G TVALX
 I X="" G TVALX
 S RMPRTVAL=Y
TVALX Q RMPRERR