Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRPIYP

RMPRPIYP.m

Go to the documentation of this file.
  1. RMPRPIYP ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/30/02 13:35
  1. ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
  1. Q
  1. ; The following subroutines are for selecting
  1. ; Inventory Item
  1. ;
  1. ;***** OK - Prompt for an OK
  1. OK(RMPRYN,RMPREXC) ;
  1. N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
  1. S RMPREXC=""
  1. S RMPRYN="N"
  1. S DIR("A")=" ...OK"
  1. S DIR("B")="Yes"
  1. S DIR(0)="Y"
  1. D ^DIR
  1. I $D(DTOUT) S RMPREXC="T" G OKX
  1. I $D(DIROUT) S RMPREXC="P" G OKX
  1. I X=""!(X["^") S RMPREXC="^" G OKX
  1. S RMPRYN="N" S:Y RMPRYN="Y"
  1. OKX Q
  1. ;
  1. ;***** ITEM - Prompt for Inventory Item
  1. ITEM(RMPRSTN,RMPRHCPC,RMPR11,RMPREXC) ;
  1. N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,DIRUT,RMPRA,RMPRIMA,RMPRGBLR
  1. N RMPRMAX,RMPRLIN,RMPRGBL,RMPR1,RMPRIMAD
  1. REDO S RMPRERR=0
  1. S RMPREXC=""
  1. I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX
  1. I $G(RMPRHCPC)="" S RMPRERR=3 G ITEMX
  1. S RMPR1("HCPCS")=RMPRHCPC
  1. S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
  1. K RMPR11
  1. S RMPRMAX=14
  1. S (RMLINE,RMPRLIN)=0
  1. S RMPRIMA=""
  1. ;
  1. ; See if just 1 item - no need to list if there is
  1. S RMPRGBLR="^RMPR(661.11,""ASHI"","_RMPRSTN_","""_RMPRHCPC_""")"
  1. S RMPRGBL=$Q(@RMPRGBLR)
  1. S RMPR11("IEN")=$QS(RMPRGBL,6)
  1. I $$ITEME() G ITEMX
  1. S RMPRGBL=$Q(@RMPRGBL)
  1. I $$ITEME() S RMPRERR=$$GET^RMPRPIX1(.RMPR11) G ITEMX
  1. ;
  1. ; Selection list of items if more than 1
  1. S RMPRGBL=RMPRGBLR
  1. ITEML1 S RMPRGBL=$Q(@RMPRGBL)
  1. I $$ITEME G:'RMPRLIN ITEMX G ITEMP
  1. I RMPRLIN,(RMLINE>RMPRMAX) D G ITEMP
  1. . S DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
  1. . Q
  1. ITEML2 ;
  1. S RMPR11("IEN")=$QS(RMPRGBL,6)
  1. S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
  1. I RMPR11("STATUS")="INACTIVE" G ITEML1
  1. S RMPRLIN=RMPRLIN+1
  1. I RMPRIMA'=$QS(RMPRGBL,5) D
  1. . S RMPRIMAD=RMPR11("ITEM MASTER")
  1. . S RMPRIMA=$QS(RMPRGBL,5)
  1. . I RMPRLIN=1 Q
  1. . W !!,"IFCAP Item: ",RMPRIMAD
  1. .; S RMPRLIN=RMPRLIN+2,RMLINE=RMLINE+3
  1. . S RMLINE=RMLINE+3
  1. . Q
  1. I RMPRLIN=1 D ITEMH
  1. W !,$J(RMPRLIN,2)," ",RMPR11("HCPCS-ITEM")
  1. W ?16,$E(RMPR11("SOURCE"))_" "_RMPR11("DESCRIPTION")
  1. S RMPRA(RMPRLIN)=RMPR11("IEN")
  1. K RMPR11
  1. G ITEML1
  1. ;
  1. ; Prompt for selection
  1. ITEMP S DIR(0)="NAO"
  1. S DIR("A")="Choose 1 - "_RMPRLIN_" : "
  1. S (RMPRFLG,RMLINE)=0
  1. D ^DIR
  1. I $D(DTOUT) S RMPREXC="T" G ITEMX
  1. I $D(DIROUT) S RMPREXC="P" G ITEMX
  1. I X="",$D(DIR("A",1)) K DIR("A",1) D ITEMH G ITEML2
  1. ;I X="" S RMPREXC="^" G ITEMX
  1. I X["^"!($D(DUOUT)) S RMPREXC="^" G ITEMX
  1. I X'="",'$D(RMPRA(X)) S RMPRFLG=1
  1. I X="?"!X="??"!X="???" K RMPRA G REDO
  1. I (X="")!(RMPRFLG) D G ITEMP
  1. . W !,"Please select an item by entering a line number in range 1 - "
  1. . W RMPRLIN_" or '^' to EXIT"
  1. . S RMPRFLG=0
  1. . Q
  1. S RMPR11("IEN")=RMPRA(X)
  1. S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
  1. ITEMX Q
  1. ITEME() ;
  1. Q:$QS(RMPRGBL,1)'=661.11 1
  1. Q:$QS(RMPRGBL,2)'="ASHI" 1
  1. Q:$QS(RMPRGBL,3)'=RMPRSTN 1
  1. Q:$QS(RMPRGBL,4)'=RMPRHCPC 1
  1. Q 0
  1. ITEMH W !!,"HCPCS: "_RMPRHCPC_" "_RMPR1("SHORT DESC")
  1. W !," is associated with more than 1 item, please select one..."
  1. W !!,"IFCAP Item: ",RMPRIMAD
  1. Q