RMPRPIYP ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/30/02 13:35
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
; The following subroutines are for selecting
; 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
;
;***** ITEM - Prompt for Inventory Item
ITEM(RMPRSTN,RMPRHCPC,RMPR11,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,DIRUT,RMPRA,RMPRIMA,RMPRGBLR
N RMPRMAX,RMPRLIN,RMPRGBL,RMPR1,RMPRIMAD
REDO S RMPRERR=0
S RMPREXC=""
I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX
I $G(RMPRHCPC)="" S RMPRERR=3 G ITEMX
S RMPR1("HCPCS")=RMPRHCPC
S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
K RMPR11
S RMPRMAX=14
S (RMLINE,RMPRLIN)=0
S RMPRIMA=""
;
; See if just 1 item - no need to list if there is
S RMPRGBLR="^RMPR(661.11,""ASHI"","_RMPRSTN_","""_RMPRHCPC_""")"
S RMPRGBL=$Q(@RMPRGBLR)
S RMPR11("IEN")=$QS(RMPRGBL,6)
I $$ITEME() G ITEMX
S RMPRGBL=$Q(@RMPRGBL)
I $$ITEME() S RMPRERR=$$GET^RMPRPIX1(.RMPR11) G ITEMX
;
; Selection list of items if more than 1
S RMPRGBL=RMPRGBLR
ITEML1 S RMPRGBL=$Q(@RMPRGBL)
I $$ITEME G:'RMPRLIN ITEMX G ITEMP
I RMPRLIN,(RMLINE>RMPRMAX) D G ITEMP
. S DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
. Q
ITEML2 ;
S RMPR11("IEN")=$QS(RMPRGBL,6)
S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
I RMPR11("STATUS")="INACTIVE" G ITEML1
S RMPRLIN=RMPRLIN+1
I RMPRIMA'=$QS(RMPRGBL,5) D
. S RMPRIMAD=RMPR11("ITEM MASTER")
. S RMPRIMA=$QS(RMPRGBL,5)
. I RMPRLIN=1 Q
. W !!,"IFCAP Item: ",RMPRIMAD
.; S RMPRLIN=RMPRLIN+2,RMLINE=RMLINE+3
. S RMLINE=RMLINE+3
. Q
I RMPRLIN=1 D ITEMH
W !,$J(RMPRLIN,2)," ",RMPR11("HCPCS-ITEM")
W ?16,$E(RMPR11("SOURCE"))_" "_RMPR11("DESCRIPTION")
S RMPRA(RMPRLIN)=RMPR11("IEN")
K RMPR11
G ITEML1
;
; Prompt for selection
ITEMP S DIR(0)="NAO"
S DIR("A")="Choose 1 - "_RMPRLIN_" : "
S (RMPRFLG,RMLINE)=0
D ^DIR
I $D(DTOUT) S RMPREXC="T" G ITEMX
I $D(DIROUT) S RMPREXC="P" G ITEMX
I X="",$D(DIR("A",1)) K DIR("A",1) D ITEMH G ITEML2
;I X="" S RMPREXC="^" G ITEMX
I X["^"!($D(DUOUT)) S RMPREXC="^" G ITEMX
I X'="",'$D(RMPRA(X)) S RMPRFLG=1
I X="?"!X="??"!X="???" K RMPRA G REDO
I (X="")!(RMPRFLG) D G ITEMP
. W !,"Please select an item by entering a line number in range 1 - "
. W RMPRLIN_" or '^' to EXIT"
. S RMPRFLG=0
. Q
S RMPR11("IEN")=RMPRA(X)
S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
ITEMX Q
ITEME() ;
Q:$QS(RMPRGBL,1)'=661.11 1
Q:$QS(RMPRGBL,2)'="ASHI" 1
Q:$QS(RMPRGBL,3)'=RMPRSTN 1
Q:$QS(RMPRGBL,4)'=RMPRHCPC 1
Q 0
ITEMH W !!,"HCPCS: "_RMPRHCPC_" "_RMPR1("SHORT DESC")
W !," is associated with more than 1 item, please select one..."
W !!,"IFCAP Item: ",RMPRIMAD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYP 2963 printed Apr 09, 2024@21:38:09 Page 2
RMPRPIYP ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/30/02 13:35
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ; The following subroutines are for selecting
+4 ; 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 ;***** ITEM - Prompt for Inventory Item
ITEM(RMPRSTN,RMPRHCPC,RMPR11,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,DIRUT,RMPRA,RMPRIMA,RMPRGBLR
+2 NEW RMPRMAX,RMPRLIN,RMPRGBL,RMPR1,RMPRIMAD
REDO SET RMPRERR=0
+1 SET RMPREXC=""
+2 IF $GET(RMPRSTN)=""
SET RMPRERR=1
GOTO ITEMX
+3 IF $GET(RMPRHCPC)=""
SET RMPRERR=3
GOTO ITEMX
+4 SET RMPR1("HCPCS")=RMPRHCPC
+5 SET RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
+6 KILL RMPR11
+7 SET RMPRMAX=14
+8 SET (RMLINE,RMPRLIN)=0
+9 SET RMPRIMA=""
+10 ;
+11 ; See if just 1 item - no need to list if there is
+12 SET RMPRGBLR="^RMPR(661.11,""ASHI"","_RMPRSTN_","""_RMPRHCPC_""")"
+13 SET RMPRGBL=$QUERY(@RMPRGBLR)
+14 SET RMPR11("IEN")=$QSUBSCRIPT(RMPRGBL,6)
+15 IF $$ITEME()
GOTO ITEMX
+16 SET RMPRGBL=$QUERY(@RMPRGBL)
+17 IF $$ITEME()
SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
GOTO ITEMX
+18 ;
+19 ; Selection list of items if more than 1
+20 SET RMPRGBL=RMPRGBLR
ITEML1 SET RMPRGBL=$QUERY(@RMPRGBL)
+1 IF $$ITEME
if 'RMPRLIN
GOTO ITEMX
GOTO ITEMP
+2 IF RMPRLIN
IF (RMLINE>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 ITEMP
ITEML2 ;
+1 SET RMPR11("IEN")=$QSUBSCRIPT(RMPRGBL,6)
+2 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+3 IF RMPR11("STATUS")="INACTIVE"
GOTO ITEML1
+4 SET RMPRLIN=RMPRLIN+1
+5 IF RMPRIMA'=$QSUBSCRIPT(RMPRGBL,5)
Begin DoDot:1
+6 SET RMPRIMAD=RMPR11("ITEM MASTER")
+7 SET RMPRIMA=$QSUBSCRIPT(RMPRGBL,5)
+8 IF RMPRLIN=1
QUIT
+9 WRITE !!,"IFCAP Item: ",RMPRIMAD
+10 ; S RMPRLIN=RMPRLIN+2,RMLINE=RMLINE+3
+11 SET RMLINE=RMLINE+3
+12 QUIT
End DoDot:1
+13 IF RMPRLIN=1
DO ITEMH
+14 WRITE !,$JUSTIFY(RMPRLIN,2)," ",RMPR11("HCPCS-ITEM")
+15 WRITE ?16,$EXTRACT(RMPR11("SOURCE"))_" "_RMPR11("DESCRIPTION")
+16 SET RMPRA(RMPRLIN)=RMPR11("IEN")
+17 KILL RMPR11
+18 GOTO ITEML1
+19 ;
+20 ; Prompt for selection
ITEMP SET DIR(0)="NAO"
+1 SET DIR("A")="Choose 1 - "_RMPRLIN_" : "
+2 SET (RMPRFLG,RMLINE)=0
+3 DO ^DIR
+4 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO ITEMX
+5 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO ITEMX
+6 IF X=""
IF $DATA(DIR("A",1))
KILL DIR("A",1)
DO ITEMH
GOTO ITEML2
+7 ;I X="" S RMPREXC="^" G ITEMX
+8 IF X["^"!($DATA(DUOUT))
SET RMPREXC="^"
GOTO ITEMX
+9 IF X'=""
IF '$DATA(RMPRA(X))
SET RMPRFLG=1
+10 IF X="?"!X="??"!X="???"
KILL RMPRA
GOTO REDO
+11 IF (X="")!(RMPRFLG)
Begin DoDot:1
+12 WRITE !,"Please select an item by entering a line number in range 1 - "
+13 WRITE RMPRLIN_" or '^' to EXIT"
+14 SET RMPRFLG=0
+15 QUIT
End DoDot:1
GOTO ITEMP
+16 SET RMPR11("IEN")=RMPRA(X)
+17 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
ITEMX QUIT
ITEME() ;
+1 if $QSUBSCRIPT(RMPRGBL,1)'=661.11
QUIT 1
+2 if $QSUBSCRIPT(RMPRGBL,2)'="ASHI"
QUIT 1
+3 if $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
QUIT 1
+4 if $QSUBSCRIPT(RMPRGBL,4)'=RMPRHCPC
QUIT 1
+5 QUIT 0
ITEMH WRITE !!,"HCPCS: "_RMPRHCPC_" "_RMPR1("SHORT DESC")
+1 WRITE !," is associated with more than 1 item, please select one..."
+2 WRITE !!,"IFCAP Item: ",RMPRIMAD
+3 QUIT
