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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYH 3608 printed Sep 23, 2025@20:13:15 Page 2
RMPRPIYH ;HINCIO/ODJ - PIP Stock Receipt Prompts ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** LOCNM - Prompt for receiving location
+5 ; must be in 661.5 and active
LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
+2 ;today's date
DO NOW^%DTC
SET RMPRTDT=X
+3 SET RMPREXC=""
+4 SET RMPRERR=0
+5 SET DIR(0)="FOA"
+6 SET DIR("A")="Enter Receiving Location: "
+7 SET DIR("?")="^D QM^RMPRPIYB"
+8 SET DIR("??")="^D QM2^RMPRPIYB"
LOCNM1 DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LOCNMX
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LOCNMX
+3 IF X=""!(X["^")
SET RMPREXC="^"
GOTO LOCNMX
+4 KILL RMPR5
+5 SET RMPR5("STATION")=RMPRSTN
+6 SET RMPR5("STATION IEN")=RMPRSTN
+7 DO LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5)
+8 IF RMPREXC'=""
GOTO LOCNM1
+9 IF $GET(RMPR5("IEN"))=""
Begin DoDot:1
+10 WRITE !,"Please enter a valid Location"
+11 QUIT
End DoDot:1
GOTO LOCNM1
+12 ;
+13 ; exit
LOCNMX QUIT RMPRERR
+1 ;
+2 ; Get OK
OK(RMPRYN,RMPREXC) ;
+1 NEW DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
+2 SET RMPREXC=""
+3 SET DIR("A")=" ...OK"
+4 SET DIR("B")="Yes"
+5 SET DIR(0)="Y"
+6 DO ^DIR
+7 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO OKX
+8 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO OKX
+9 IF X=""!(X["^")
SET RMPREXC="^"
GOTO OKX
+10 SET RMPRYN="N"
if Y
SET RMPRYN="Y"
OKX QUIT
+1 ;
+2 ;***** HCPCS - Get a HCPCS code from 661.4
HCPCS(RMPR5,RMPR1,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN,RMPRLCN,RMPR1N
+2 SET DIR("A")="Select HCPCS to RECEIVE: "
+3 SET RMPRERR=0
+4 SET RMPREXC=""
+5 SET RMPR1("HCPCS")=$GET(RMPR1("HCPCS"))
+6 SET RMPRSTN=RMPR5("STATION")
+7 SET RMPRLCN=RMPR5("IEN")
+8 SET DIR(0)="FOA"
+9 SET DIR("?")="^D QM^RMPRPIYC"
+10 SET DIR("??")="^D QM2^RMPRPIYC"
HCPCS1 KILL RMPR1N
DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO HCPCSX
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO HCPCSX
+3 IF X=""!(X["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO HCPCSX
+4 DO LIKE^RMPRPIYC(RMPRSTN,RMPRLCN,X,.RMPREXC,.RMPR1N)
+5 IF RMPREXC'=""
GOTO HCPCS1
+6 IF $GET(RMPR1N("IEN"))'=""
GOTO HCPCSU
+7 GOTO HCPCS1
HCPCSU KILL RMPR1
MERGE RMPR1=RMPR1N
HCPCSX QUIT RMPRERR
+1 ;
+2 ;***** ITEM - Get an Item - restrict choice to Location and HCPC
ITEM(RMPRSTN,RMPRLCN,RMPRHCPC,RMPR11,RMPR4,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRYN
+2 SET RMPRERR=0
+3 SET RMPREXC=""
+4 IF $GET(RMPRSTN)=""
SET RMPRERR=1
GOTO ITEMX
+5 IF $GET(RMPRLCN)=""
SET RMPRERR=2
GOTO ITEMX
+6 IF $GET(RMPRHCPC)=""
SET RMPRERR=3
GOTO ITEMX
+7 KILL RMPR11,RMPR4
+8 SET DIR(0)="FOA^1:50"
+9 SET DIR("A")="Enter Item to RECEIVE: "
+10 SET DIR("?")="^D QM^RMPRPIY8"
+11 SET DIR("??")="^D QQM^RMPRPIY8"
ITEMA1 DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO ITEMX
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO ITEMX
+3 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO ITEMX
+4 DO LIKE^RMPRPIY8(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11,.RMPR4)
+5 IF RMPREXC="T"
GOTO ITEMX
+6 IF RMPREXC="P"
GOTO ITEMX
+7 IF RMPREXC="^"
GOTO ITEMA1
+8 IF RMPR4("IEN")=""
Begin DoDot:1
+9 WRITE !,"Cannot locate ITEM with this sequence NUMBER"
+10 QUIT
End DoDot:1
GOTO ITEMA1
+11 WRITE " ",RMPR11("HCPCS-ITEM")," ",RMPR11("DESCRIPTION")
+12 DO OK(.RMPRYN,.RMPREXC)
+13 IF RMPRYN'="Y"
GOTO ITEMA1
+14 GOTO ITEMX
ITEMX QUIT RMPRERR
+1 ;
+2 ; Get Quantity
QTY(RMPRQTY,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
+2 SET RMPRQTY=$GET(RMPRQTY)
+3 SET RMPRERR=0
+4 SET DIR(0)="NA^1:99999:0"
+5 SET DIR("A")="Quantity to Receive: "
+6 if RMPRQTY'=""
SET DIR("B")=RMPRQTY
+7 DO ^DIR
+8 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO QTYX
+9 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO QTYX
+10 IF X=""!(X["^")
SET RMPREXC="^"
GOTO QTYX
+11 SET RMPRQTY=Y
QTYX QUIT RMPRERR
+1 ;
+2 ; Get total $ value
TVAL(RMPRTVAL,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
+2 SET RMPRTVAL=$GET(RMPRTVAL)
+3 SET RMPRERR=0
+4 SET DIR(0)="NOA^0:999999:2"
+5 SET DIR("A")="Total Cost of Item: "
+6 DO ^DIR
+7 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO TVALX
+8 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO TVALX
+9 IF X["^"
SET RMPREXC="^"
GOTO TVALX
+10 IF X=""
GOTO TVALX
+11 SET RMPRTVAL=Y
TVALX QUIT RMPRERR
