RMPRPIY7 ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/18/02 15:17
;;3.0;PROSTHETICS;**61,118,139,173**;Feb 09, 1996;Build 29
;
;DBIA # 800 - FILEMAN read of file #440.
Q
;
;RMPR*3.0*173 Modify HCPCS item lookup code to reject if entry
; flagged as inactive in file 661.11
; The following subroutines are a series of prompts called
; by Edit LOCATION/HCPCS/ITEM option (EI^RMPRPIY6)
;
;***** LOCNM - Prompt for 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 Pros Location: "
I $G(RMPR5("NAME"))'="" S DIR("B")=RMPR5("NAME")
S DIR("?")="^D QM^RMPRPIYB"
S DIR("??")="^D QM2^RMPRPIYB"
S RMPR5("IEN")=""
LOCNM1 D ^DIR
;Patch *139 removes upper case translation to allow access to lower
;case entries used in location creation option
;S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
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
;
;***** HCPCS - Prompt for HCPCS
HCPCS(RMPRSTN,RMPRHPTX,RMPR1,RMPR11,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPR1N,RMSTN
N RM6610
S DIR("A")="Select HCPCS: ",RMSTN=RMPRSTN
S DIR("S")="I $P(^RMPR(661.11,+Y,0),U,4)=RMSTN"
S RMPRERR=0
S RMPREXC=""
S RMPRHPTX=$G(RMPRHPTX)
I RMPRHPTX'="" S DIR("B")=RMPRHPTX
S DIR(0)="FOA"
S DIR("?")="^D QM2^RMPRPIYC"
S DIR("??")="^D QM2^RMPRPIYC"
S DIR("???")="^D QM2^RMPRPIYC"
HCPCS1 K RMPR1N D ^DIR
I $G(RMPR1N("IEN"))'="" S RMPRHPTX=RMPR1N("HCPCS") G CHECK
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,X,.RMPREXC,.RMPR1N,.RMPR11)
I RMPREXC'="" G HCPCS1
I $G(RMPR1N("IEN"))'="",$G(RMPR1("REMOVE")) G HCPCSU
CHECK I $G(RMPR1N("IEN")),$D(^RMPR(661.1,$G(RMPR1N("IEN")),0)),'($P(^RMPR(661.1,RMPR1N("IEN"),0),U,5)) W !,"** No HCPCS Selected or Unable to Select Inactive HCPCS..." G HCPCS1
I $G(RMPR11("IEN")),$D(^RMPR(661.11,$G(RMPR11("IEN")),0)),$P(^RMPR(661.11,$G(RMPR11("IEN")),0),U,9) W !,"** Unable to Select Inactive HCPCS item..." G HCPCS1 ;RMPR*3.0*173 If HCPCS item inactive in file 661.11 reject lookup as Inactive
I $G(RMPR1N("IEN"))'="" G HCPCSU
G HCPCS1
HCPCSU K RMPR1 M RMPR1=RMPR1N
HCPCSX Q
;
;***** ITEM - Prompt for 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 PSAS Item to Edit: "
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
;
;***** QTY - Prompt for 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: "
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
;
;***** TVAL - Prompt for 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 QUANTITY: "
S:RMPRTVAL'="" DIR("B")=RMPRTVAL
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
;
;***** REO - Prompt for Re-Order Level
REO(RMPRREO,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
S RMPRREO=$G(RMPRREO)
S RMPRERR=0
S DIR(0)="NOA^0::0"
S DIR("A")="RE-ORDER LEVEL: "
S:RMPRREO'="" DIR("B")=RMPRREO
D ^DIR
I $D(DTOUT) S RMPREXC="T" G REOX
I $D(DIROUT) S RMPREXC="P" G REOX
I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G REOX
S RMPRREO=Y
REOX Q RMPRERR
;
;***** VEND - Prompt for Vendor
VEND(RMPRVEND,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
S RMPRVEND=$G(RMPRVEND("IEN"))
S RMPRERR=0
S DIR(0)="P^440:EMZ"
S DIR("A")="VENDOR"
S:RMPRVEND'="" DIR("B")=RMPRVEND("NAME")
D ^DIR
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 RMPRVEND("IEN")=$P(Y,"^",1)
S RMPRVEND("NAME")=$P(Y,"^",2)
VENDX Q RMPRERR
;
;***** PVEN - Pick the current stock record to edit
PVEN(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM,RMPR6,RMPR7,RMPREXC) ;
N DIR,X,Y,DA,RMPRGBL,RMPRLIN,RMPRA,RMPRERR,RMPRX,RMPRY,RMPRB
N RMPR7I
S RMPREXC=""
S RMPRX="",RMPRY=0
S RMPRLIN=0
S RMPRGBL=$Q(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM))
G PVEN1A
PVEN1 S RMPRGBL=$Q(@RMPRGBL)
PVEN1A I $QS(RMPRGBL,1)'=661.7 G PVEN2
I $QS(RMPRGBL,2)'="XSLHIDS" G PVEN2
I $QS(RMPRGBL,3)'=RMPRSTN G PVEN2
I $QS(RMPRGBL,4)'=RMPRLCN G PVEN2
I $QS(RMPRGBL,5)'=RMPRHCPC G PVEN2
I $QS(RMPRGBL,6)'=RMPRITM G PVEN2
S RMPRLIN=RMPRLIN+1
S RMPRA(RMPRLIN)=$QS(RMPRGBL,9)
G PVEN1
PVEN2 I RMPRLIN=0 G PVENX
I RMPRLIN=1 S X=1 G PVEN3
W !,"Select a current Stock Record to edit...",!
W !,?7,"Date",?21,"Quantity",?35,"Value",?42,"Vendor"
S RMPRX="",RMPRLIN=0
F S RMPRX=$O(RMPRA(RMPRX)) Q:RMPRX="" D
. S RMPRLIN=RMPRLIN+1
. K RMPR7
. S RMPR7("IEN")=RMPRA(RMPRX)
. S RMPRERR=$$GET^RMPRPIX7(.RMPR7)
. W !,?2,$J(RMPRLIN,2)
. W ?7,$P(RMPR7("DATE&TIME"),"@",1)
. W ?21,$J(RMPR7("QUANTITY"),8,0)
. W ?30,$J(RMPR7("VALUE"),10,2)
. K RMPR7I
. S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
. K RMPR6
. S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME")
. S RMPR6("HCPCS")=RMPRHCPC
. S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
. W ?42,RMPR6("VENDOR")
. Q
K RMPR7,RMPR6
S DIR(0)="NAO^1:"_RMPRLIN_": "
S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
D ^DIR
I $D(DTOUT) S RMPREXC="T" G PVENX
I $D(DIROUT) S RMPREXC="P" G PVENX
I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G PVENX
PVEN3 S RMPR7("IEN")=RMPRA(X)
S RMPRERR=$$GET^RMPRPIX7(.RMPR7)
K RMPR7I
S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME")
S RMPR6("HCPCS")=RMPRHCPC
S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
PVENX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIY7 7537 printed Sep 23, 2025@20:13:05 Page 2
RMPRPIY7 ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/18/02 15:17
+1 ;;3.0;PROSTHETICS;**61,118,139,173**;Feb 09, 1996;Build 29
+2 ;
+3 ;DBIA # 800 - FILEMAN read of file #440.
+4 QUIT
+5 ;
+6 ;RMPR*3.0*173 Modify HCPCS item lookup code to reject if entry
+7 ; flagged as inactive in file 661.11
+8 ; The following subroutines are a series of prompts called
+9 ; by Edit LOCATION/HCPCS/ITEM option (EI^RMPRPIY6)
+10 ;
+11 ;***** LOCNM - Prompt for location
+12 ; 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 Pros Location: "
+7 IF $GET(RMPR5("NAME"))'=""
SET DIR("B")=RMPR5("NAME")
+8 SET DIR("?")="^D QM^RMPRPIYB"
+9 SET DIR("??")="^D QM2^RMPRPIYB"
+10 SET RMPR5("IEN")=""
LOCNM1 DO ^DIR
+1 ;Patch *139 removes upper case translation to allow access to lower
+2 ;case entries used in location creation option
+3 ;S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+4 IF $GET(RMPR5("IEN"))'=""
SET RMPREXC=""
GOTO LOCNMX
+5 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LOCNMX
+6 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LOCNMX
+7 IF X=""!(X["^")
SET RMPREXC="^"
GOTO LOCNMX
+8 KILL RMPR5
+9 SET RMPR5("STATION")=RMPRSTN
+10 SET RMPR5("STATION IEN")=RMPRSTN
+11 DO LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5)
+12 IF RMPREXC'=""
GOTO LOCNM1
+13 IF $GET(RMPR5("IEN"))=""
Begin DoDot:1
+14 WRITE !,"Please enter a valid Location"
+15 QUIT
End DoDot:1
GOTO LOCNM1
+16 ;
+17 ; 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
+1 ;
+2 ;***** HCPCS - Prompt for HCPCS
HCPCS(RMPRSTN,RMPRHPTX,RMPR1,RMPR11,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPR1N,RMSTN
+2 NEW RM6610
+3 SET DIR("A")="Select HCPCS: "
SET RMSTN=RMPRSTN
+4 SET DIR("S")="I $P(^RMPR(661.11,+Y,0),U,4)=RMSTN"
+5 SET RMPRERR=0
+6 SET RMPREXC=""
+7 SET RMPRHPTX=$GET(RMPRHPTX)
+8 IF RMPRHPTX'=""
SET DIR("B")=RMPRHPTX
+9 SET DIR(0)="FOA"
+10 SET DIR("?")="^D QM2^RMPRPIYC"
+11 SET DIR("??")="^D QM2^RMPRPIYC"
+12 SET DIR("???")="^D QM2^RMPRPIYC"
HCPCS1 KILL RMPR1N
DO ^DIR
+1 IF $GET(RMPR1N("IEN"))'=""
SET RMPRHPTX=RMPR1N("HCPCS")
GOTO CHECK
+2 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO HCPCSX
+3 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO HCPCSX
+4 IF X=""!(X["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO HCPCSX
+5 DO LIKE^RMPRPIYC(RMPRSTN,X,.RMPREXC,.RMPR1N,.RMPR11)
+6 IF RMPREXC'=""
GOTO HCPCS1
+7 IF $GET(RMPR1N("IEN"))'=""
IF $GET(RMPR1("REMOVE"))
GOTO HCPCSU
CHECK IF $GET(RMPR1N("IEN"))
IF $DATA(^RMPR(661.1,$GET(RMPR1N("IEN")),0))
IF '($PIECE(^RMPR(661.1,RMPR1N("IEN"),0),U,5))
WRITE !,"** No HCPCS Selected or Unable to Select Inactive HCPCS..."
GOTO HCPCS1
+1 ;RMPR*3.0*173 If HCPCS item inactive in file 661.11 reject lookup as Inactive
IF $GET(RMPR11("IEN"))
IF $DATA(^RMPR(661.11,$GET(RMPR11("IEN")),0))
IF $PIECE(^RMPR(661.11,$GET(RMPR11("IEN")),0),U,9)
WRITE !,"** Unable to Select Inactive HCPCS item..."
GOTO HCPCS1
+2 IF $GET(RMPR1N("IEN"))'=""
GOTO HCPCSU
+3 GOTO HCPCS1
HCPCSU KILL RMPR1
MERGE RMPR1=RMPR1N
HCPCSX QUIT
+1 ;
+2 ;***** ITEM - Prompt for 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 PSAS Item to Edit: "
+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 ;***** QTY - Prompt for 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: "
+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 ;***** TVAL - Prompt for 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 QUANTITY: "
+6 if RMPRTVAL'=""
SET DIR("B")=RMPRTVAL
+7 DO ^DIR
+8 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO TVALX
+9 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO TVALX
+10 IF X["^"
SET RMPREXC="^"
GOTO TVALX
+11 IF X=""
GOTO TVALX
+12 SET RMPRTVAL=Y
TVALX QUIT RMPRERR
+1 ;
+2 ;***** REO - Prompt for Re-Order Level
REO(RMPRREO,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
+2 SET RMPRREO=$GET(RMPRREO)
+3 SET RMPRERR=0
+4 SET DIR(0)="NOA^0::0"
+5 SET DIR("A")="RE-ORDER LEVEL: "
+6 if RMPRREO'=""
SET DIR("B")=RMPRREO
+7 DO ^DIR
+8 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO REOX
+9 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO REOX
+10 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO REOX
+11 SET RMPRREO=Y
REOX QUIT RMPRERR
+1 ;
+2 ;***** VEND - Prompt for Vendor
VEND(RMPRVEND,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
+2 SET RMPRVEND=$GET(RMPRVEND("IEN"))
+3 SET RMPRERR=0
+4 SET DIR(0)="P^440:EMZ"
+5 SET DIR("A")="VENDOR"
+6 if RMPRVEND'=""
SET DIR("B")=RMPRVEND("NAME")
+7 DO ^DIR
+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 RMPRVEND("IEN")=$PIECE(Y,"^",1)
+12 SET RMPRVEND("NAME")=$PIECE(Y,"^",2)
VENDX QUIT RMPRERR
+1 ;
+2 ;***** PVEN - Pick the current stock record to edit
PVEN(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM,RMPR6,RMPR7,RMPREXC) ;
+1 NEW DIR,X,Y,DA,RMPRGBL,RMPRLIN,RMPRA,RMPRERR,RMPRX,RMPRY,RMPRB
+2 NEW RMPR7I
+3 SET RMPREXC=""
+4 SET RMPRX=""
SET RMPRY=0
+5 SET RMPRLIN=0
+6 SET RMPRGBL=$QUERY(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM))
+7 GOTO PVEN1A
PVEN1 SET RMPRGBL=$QUERY(@RMPRGBL)
PVEN1A IF $QSUBSCRIPT(RMPRGBL,1)'=661.7
GOTO PVEN2
+1 IF $QSUBSCRIPT(RMPRGBL,2)'="XSLHIDS"
GOTO PVEN2
+2 IF $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
GOTO PVEN2
+3 IF $QSUBSCRIPT(RMPRGBL,4)'=RMPRLCN
GOTO PVEN2
+4 IF $QSUBSCRIPT(RMPRGBL,5)'=RMPRHCPC
GOTO PVEN2
+5 IF $QSUBSCRIPT(RMPRGBL,6)'=RMPRITM
GOTO PVEN2
+6 SET RMPRLIN=RMPRLIN+1
+7 SET RMPRA(RMPRLIN)=$QSUBSCRIPT(RMPRGBL,9)
+8 GOTO PVEN1
PVEN2 IF RMPRLIN=0
GOTO PVENX
+1 IF RMPRLIN=1
SET X=1
GOTO PVEN3
+2 WRITE !,"Select a current Stock Record to edit...",!
+3 WRITE !,?7,"Date",?21,"Quantity",?35,"Value",?42,"Vendor"
+4 SET RMPRX=""
SET RMPRLIN=0
+5 FOR
SET RMPRX=$ORDER(RMPRA(RMPRX))
if RMPRX=""
QUIT
Begin DoDot:1
+6 SET RMPRLIN=RMPRLIN+1
+7 KILL RMPR7
+8 SET RMPR7("IEN")=RMPRA(RMPRX)
+9 SET RMPRERR=$$GET^RMPRPIX7(.RMPR7)
+10 WRITE !,?2,$JUSTIFY(RMPRLIN,2)
+11 WRITE ?7,$PIECE(RMPR7("DATE&TIME"),"@",1)
+12 WRITE ?21,$JUSTIFY(RMPR7("QUANTITY"),8,0)
+13 WRITE ?30,$JUSTIFY(RMPR7("VALUE"),10,2)
+14 KILL RMPR7I
+15 SET RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
+16 KILL RMPR6
+17 SET RMPR6("DATE&TIME")=RMPR7I("DATE&TIME")
+18 SET RMPR6("HCPCS")=RMPRHCPC
+19 SET RMPRERR=$$GET^RMPRPIX6(.RMPR6)
+20 WRITE ?42,RMPR6("VENDOR")
+21 QUIT
End DoDot:1
+22 KILL RMPR7,RMPR6
+23 SET DIR(0)="NAO^1:"_RMPRLIN_": "
+24 SET DIR("A")="CHOOSE 1-"_RMPRLIN_": "
+25 DO ^DIR
+26 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO PVENX
+27 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO PVENX
+28 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO PVENX
PVEN3 SET RMPR7("IEN")=RMPRA(X)
+1 SET RMPRERR=$$GET^RMPRPIX7(.RMPR7)
+2 KILL RMPR7I
+3 SET RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
+4 SET RMPR6("DATE&TIME")=RMPR7I("DATE&TIME")
+5 SET RMPR6("HCPCS")=RMPRHCPC
+6 SET RMPRERR=$$GET^RMPRPIX6(.RMPR6)
PVENX QUIT
