- 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 Apr 23, 2025@18:51:43 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
