128 lines
3.4 KiB
Mathematica
128 lines
3.4 KiB
Mathematica
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
|