RMPRPIYQ ;HINCIO/ODJ - PIP EDIT - PROMPTS ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
; The following subroutines are for selecting HCPCS
; and Inventory Item
;
;***** 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
;
;***** LOCN - Prompt for Inventory Location based on 661.4 file
; and a given HCPCS and PIP Item
LOCN(RMPRSTN,RMPR11,RMPR5,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,DIRUT,RMPRA,RMPRGBLR,RMPR4
N RMPRMAX,RMPRLIN,RMPRGBL,RMPRHCPC,RMPRITEM
S RMPRERR=0
S RMPREXC=""
S RMPRHCPC=RMPR11("HCPCS")
S RMPRITEM=RMPR11("ITEM")
K RMPR5
S RMPRMAX=15
S RMPRLIN=0
;
; See if just 1 location - no need to list if there is
S RMPRGBLR="^RMPR(661.4,""XSHIL"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRITEM_""")"
S RMPRGBL=$Q(@RMPRGBLR)
I $$LOCNE() G LOCNX
S RMPR5("IEN")=$QS(RMPRGBL,6)
S RMPRGBL=$Q(@RMPRGBL)
I $$LOCNE() S RMPRERR=$$GET^RMPRPIX5(.RMPR5) G LOCNX
;
; Selection list of items if more than 1
S RMPRGBL=RMPRGBLR
LOCNL1 S RMPRGBL=$Q(@RMPRGBL)
I $$LOCNE G:'RMPRLIN LOCNX G LOCNP
I RMPRLIN,'(RMPRLIN#RMPRMAX) D G LOCNP
. S DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
. Q
LOCNL2 S RMPRLIN=RMPRLIN+1
I RMPRLIN=1 D LOCNH
S RMPR5("IEN")=$QS(RMPRGBL,6)
S RMPRERR=$$GET^RMPRPIX5(.RMPR5)
K RMPR4
S RMPR4("IEN")=$QS(RMPRGBL,7)
I RMPR4("IEN")'="" S RMPRERR=$$GET^RMPRPIX4(.RMPR4)
W !,$J(RMPRLIN,2)," ",$E(RMPR5("NAME"),1,20)
W ?24,$J($G(RMPR4("RE-ORDER QTY")),5)
S RMPRA(RMPRLIN)=RMPR5("IEN")
K RMPR5
G LOCNL1
;
; Prompt for selection
LOCNP S DIR(0)="FAO"
S DIR("A")="Choose 1 - "_RMPRLIN_" : "
D ^DIR
I $D(DTOUT) S RMPREXC="T" G LOCNX
I $D(DIROUT) S RMPREXC="P" G LOCNX
I X="",$D(DIR("A",1)) K DIR("A",1) D LOCNH G LOCNL2
I X="" S RMPREXC="^" G LOCNX
I X["^"!($D(DUOUT)) S RMPREXC="^" G LOCNX
I '$D(RMPRA(X)) D G LOCNP
. W !,"Please select a Location by entering a line number in range 1 - "
. W RMPRLIN
. Q
S RMPR5("IEN")=RMPRA(X)
S RMPRERR=$$GET^RMPRPIX5(.RMPR5)
LOCNX Q
LOCNE() ;
Q:$QS(RMPRGBL,1)'=661.4 1
Q:$QS(RMPRGBL,2)'="XSHIL" 1
Q:$QS(RMPRGBL,3)'=RMPRSTN 1
Q:$QS(RMPRGBL,4)'=RMPRHCPC 1
Q:$QS(RMPRGBL,5)'=RMPRITEM 1
Q 0
LOCNH W !
W !,"Select a Location...",!
W ?3,"Location",?24,"Re-Order Qty."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYQ 2573 printed Dec 13, 2024@02:37:13 Page 2
RMPRPIYQ ;HINCIO/ODJ - PIP EDIT - PROMPTS ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ; The following subroutines are for selecting HCPCS
+4 ; and Inventory Item
+5 ;
+6 ;***** 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 ;***** LOCN - Prompt for Inventory Location based on 661.4 file
+3 ; and a given HCPCS and PIP Item
LOCN(RMPRSTN,RMPR11,RMPR5,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,DIRUT,RMPRA,RMPRGBLR,RMPR4
+2 NEW RMPRMAX,RMPRLIN,RMPRGBL,RMPRHCPC,RMPRITEM
+3 SET RMPRERR=0
+4 SET RMPREXC=""
+5 SET RMPRHCPC=RMPR11("HCPCS")
+6 SET RMPRITEM=RMPR11("ITEM")
+7 KILL RMPR5
+8 SET RMPRMAX=15
+9 SET RMPRLIN=0
+10 ;
+11 ; See if just 1 location - no need to list if there is
+12 SET RMPRGBLR="^RMPR(661.4,""XSHIL"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRITEM_""")"
+13 SET RMPRGBL=$QUERY(@RMPRGBLR)
+14 IF $$LOCNE()
GOTO LOCNX
+15 SET RMPR5("IEN")=$QSUBSCRIPT(RMPRGBL,6)
+16 SET RMPRGBL=$QUERY(@RMPRGBL)
+17 IF $$LOCNE()
SET RMPRERR=$$GET^RMPRPIX5(.RMPR5)
GOTO LOCNX
+18 ;
+19 ; Selection list of items if more than 1
+20 SET RMPRGBL=RMPRGBLR
LOCNL1 SET RMPRGBL=$QUERY(@RMPRGBL)
+1 IF $$LOCNE
if 'RMPRLIN
GOTO LOCNX
GOTO LOCNP
+2 IF RMPRLIN
IF '(RMPRLIN#RMPRMAX)
Begin DoDot:1
+3 SET DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
+4 QUIT
End DoDot:1
GOTO LOCNP
LOCNL2 SET RMPRLIN=RMPRLIN+1
+1 IF RMPRLIN=1
DO LOCNH
+2 SET RMPR5("IEN")=$QSUBSCRIPT(RMPRGBL,6)
+3 SET RMPRERR=$$GET^RMPRPIX5(.RMPR5)
+4 KILL RMPR4
+5 SET RMPR4("IEN")=$QSUBSCRIPT(RMPRGBL,7)
+6 IF RMPR4("IEN")'=""
SET RMPRERR=$$GET^RMPRPIX4(.RMPR4)
+7 WRITE !,$JUSTIFY(RMPRLIN,2)," ",$EXTRACT(RMPR5("NAME"),1,20)
+8 WRITE ?24,$JUSTIFY($GET(RMPR4("RE-ORDER QTY")),5)
+9 SET RMPRA(RMPRLIN)=RMPR5("IEN")
+10 KILL RMPR5
+11 GOTO LOCNL1
+12 ;
+13 ; Prompt for selection
LOCNP SET DIR(0)="FAO"
+1 SET DIR("A")="Choose 1 - "_RMPRLIN_" : "
+2 DO ^DIR
+3 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LOCNX
+4 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LOCNX
+5 IF X=""
IF $DATA(DIR("A",1))
KILL DIR("A",1)
DO LOCNH
GOTO LOCNL2
+6 IF X=""
SET RMPREXC="^"
GOTO LOCNX
+7 IF X["^"!($DATA(DUOUT))
SET RMPREXC="^"
GOTO LOCNX
+8 IF '$DATA(RMPRA(X))
Begin DoDot:1
+9 WRITE !,"Please select a Location by entering a line number in range 1 - "
+10 WRITE RMPRLIN
+11 QUIT
End DoDot:1
GOTO LOCNP
+12 SET RMPR5("IEN")=RMPRA(X)
+13 SET RMPRERR=$$GET^RMPRPIX5(.RMPR5)
LOCNX QUIT
LOCNE() ;
+1 if $QSUBSCRIPT(RMPRGBL,1)'=661.4
QUIT 1
+2 if $QSUBSCRIPT(RMPRGBL,2)'="XSHIL"
QUIT 1
+3 if $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
QUIT 1
+4 if $QSUBSCRIPT(RMPRGBL,4)'=RMPRHCPC
QUIT 1
+5 if $QSUBSCRIPT(RMPRGBL,5)'=RMPRITEM
QUIT 1
+6 QUIT 0
LOCNH WRITE !
+1 WRITE !,"Select a Location...",!
+2 WRITE ?3,"Location",?24,"Re-Order Qty."
+3 QUIT
