source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYP.m@ 1389

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