RMPRPIYU ;HINCIO/ODJ - PIP Data Prompts;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
;DBIA #800
Q
;
;***** QTY - Prompt for Quantity (Transfer Option RMPRPIYT)
QTY(RMPRQTY,RMPREXC,RMPR5,RMPR11) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA,RMPRSTK
S RMPRQTY=$G(RMPRQTY)
S RMPREXC=""
S RMPRERR=0
S RMPRSTK("STATION IEN")=RMPR11("STATION IEN")
S RMPRSTK("HCPCS")=RMPR11("HCPCS")
S RMPRSTK("ITEM")=RMPR11("ITEM")
S RMPRSTK("LOCATION IEN")=RMPR5("IEN")
S RMPRSTK("VENDOR IEN")=""
S RMPRERR=$$STOCK^RMPRPIUE(.RMPRSTK)
I +RMPRSTK("QOH")<1 S RMPRERR=99 G QTYX
S DIR(0)="NAO^1:"_+RMPRSTK("QOH")_":0"
S DIR("A")="Enter Quantity to transfer: "
S DIR("?")="^D QM^RMPRPIYU"
D ^DIR
I $D(DTOUT) S RMPREXC="T" G QTYX
I $D(DIROUT) S RMPREXC="P" G QTYX
I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G QTYX
S RMPRQTY=Y
S RMPREXC=""
QTYX Q RMPRERR
;
; On help get current stock and display
; only call from QTY^RMPRPIYU
QM N RMPRERR
S RMPRERR=$$STOCK^RMPRPIUE(.RMPRSTK)
W !,"Current balance is = "_RMPRSTK("QOH")
W !,"Enter quantity 1 to "_RMPRSTK("QOH")_" or enter '^' to QUIT?"
Q
;
;***** VEND - prompt for Vendor (Transfer option RMPRPIYT)
VEND(RMPRV,RMPRVNDR,RMPREXC) ;
N DIC,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
S RMPREXC=""
S DIC(0)="AEQM"
S DIC("A")="Vendor: "
S DIC=440
S DIC("S")="I $D(RMPRV(+Y))"
D ^DIC
I $D(DTOUT) S RMPREXC="T" G VENDX
I $D(DIROUT) S RMPREXC="P" G VENDX
I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G VENDX
S RMPRVNDR=+Y
VENDX Q
;
;***** LOCNM - Prompt for transfer 'To' location
; must be in 661.5 and active
LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
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"
S RMPR5("IEN")=""
LOCNM1 D ^DIR
I $G(RMPR5("IEN"))'="" S RMPREXC="" G LOCNMX
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
;
;***** OK - Prompt for an OK
OK(RMPRYN,RMPREXC) ;
N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
S RMPREXC=""
S RMPRYN="N"
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYU 2649 printed Sep 23, 2025@20:13:27 Page 2
RMPRPIYU ;HINCIO/ODJ - PIP Data Prompts;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 ;DBIA #800
+3 QUIT
+4 ;
+5 ;***** QTY - Prompt for Quantity (Transfer Option RMPRPIYT)
QTY(RMPRQTY,RMPREXC,RMPR5,RMPR11) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA,RMPRSTK
+2 SET RMPRQTY=$GET(RMPRQTY)
+3 SET RMPREXC=""
+4 SET RMPRERR=0
+5 SET RMPRSTK("STATION IEN")=RMPR11("STATION IEN")
+6 SET RMPRSTK("HCPCS")=RMPR11("HCPCS")
+7 SET RMPRSTK("ITEM")=RMPR11("ITEM")
+8 SET RMPRSTK("LOCATION IEN")=RMPR5("IEN")
+9 SET RMPRSTK("VENDOR IEN")=""
+10 SET RMPRERR=$$STOCK^RMPRPIUE(.RMPRSTK)
+11 IF +RMPRSTK("QOH")<1
SET RMPRERR=99
GOTO QTYX
+12 SET DIR(0)="NAO^1:"_+RMPRSTK("QOH")_":0"
+13 SET DIR("A")="Enter Quantity to transfer: "
+14 SET DIR("?")="^D QM^RMPRPIYU"
+15 DO ^DIR
+16 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO QTYX
+17 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO QTYX
+18 IF X=""!(X["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO QTYX
+19 SET RMPRQTY=Y
+20 SET RMPREXC=""
QTYX QUIT RMPRERR
+1 ;
+2 ; On help get current stock and display
+3 ; only call from QTY^RMPRPIYU
QM NEW RMPRERR
+1 SET RMPRERR=$$STOCK^RMPRPIUE(.RMPRSTK)
+2 WRITE !,"Current balance is = "_RMPRSTK("QOH")
+3 WRITE !,"Enter quantity 1 to "_RMPRSTK("QOH")_" or enter '^' to QUIT?"
+4 QUIT
+5 ;
+6 ;***** VEND - prompt for Vendor (Transfer option RMPRPIYT)
VEND(RMPRV,RMPRVNDR,RMPREXC) ;
+1 NEW DIC,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
+2 SET RMPREXC=""
+3 SET DIC(0)="AEQM"
+4 SET DIC("A")="Vendor: "
+5 SET DIC=440
+6 SET DIC("S")="I $D(RMPRV(+Y))"
+7 DO ^DIC
+8 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO VENDX
+9 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO VENDX
+10 IF X=""!(X["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO VENDX
+11 SET RMPRVNDR=+Y
VENDX QUIT
+1 ;
+2 ;***** LOCNM - Prompt for transfer 'To' location
+3 ; must be in 661.5 and active
LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
+2 SET RMPREXC=""
+3 SET RMPRERR=0
+4 SET DIR(0)="FOA"
+5 SET DIR("A")="Enter Receiving Location: "
+6 SET DIR("?")="^D QM^RMPRPIYB"
+7 SET DIR("??")="^D QM2^RMPRPIYB"
+8 SET RMPR5("IEN")=""
LOCNM1 DO ^DIR
+1 IF $GET(RMPR5("IEN"))'=""
SET RMPREXC=""
GOTO LOCNMX
+2 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LOCNMX
+3 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LOCNMX
+4 IF X=""!(X["^")
SET RMPREXC="^"
GOTO LOCNMX
+5 KILL RMPR5
+6 SET RMPR5("STATION")=RMPRSTN
+7 SET RMPR5("STATION IEN")=RMPRSTN
+8 DO LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5)
+9 IF RMPREXC'=""
GOTO LOCNM1
+10 IF $GET(RMPR5("IEN"))=""
Begin DoDot:1
+11 WRITE !,"Please enter a valid Location"
+12 QUIT
End DoDot:1
GOTO LOCNM1
+13 ;
+14 ; exit
LOCNMX QUIT
+1 ;
+2 ;***** OK - Prompt for an OK
OK(RMPRYN,RMPREXC) ;
+1 NEW DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
+2 SET RMPREXC=""
+3 SET RMPRYN="N"
+4 SET DIR("A")=" ...OK"
+5 SET DIR("B")="Yes"
+6 SET DIR(0)="Y"
+7 DO ^DIR
+8 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO OKX
+9 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO OKX
+10 IF X=""!(X["^")
SET RMPREXC="^"
GOTO OKX
+11 SET RMPRYN="N"
if Y
SET RMPRYN="Y"
OKX QUIT
