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

RMPRPIY3.m

Go to the documentation of this file. 
  1. RMPRPIY3 ;HINCIO/ODJ - PIP Data Entry - HCPCS prompt;3/8/01 ; 12/15/05 10:23am
  1.  ;;3.0;PROSTHETICS;**61,93**;Feb 09, 1996;Build 6
  1.  Q
  1.  ;
  1.  ;***** HCPCS - Prompt for a HCPCS code from either
  1.  ;              an existing stock location or
  1.  ;              the main HCPCS file (661.1)
  1.  ;              called by RMPRPIY9
  1.  ;
  1.  ; Inputs:
  1.  ;    RMPR5 - array of Location data fields...
  1.  ;    RMPR5("STATION IEN") - Station number of selected Location
  1.  ;                           (ptr ^DIC(4,)
  1.  ;    RMPR5("IEN")         - ien of selected Location (ptr ^RMPR(661.5,)
  1.  ;
  1.  ; Outputs:
  1.  ;    RMPR1   - HCPCS data field array (661.1)
  1.  ;    RMPREXC - exit condition
  1.  ;              "" - value entered, continue 
  1.  ;               T - Time out
  1.  ;               P - Prvious field
  1.  ;               ^ - up arrow out
  1.  ;
  1.  ; AAC 12/13/05
  1.  ; Modification to the DIC Lookup to perform any Lookup on a HCPC
  1.  ; code that contains ONLY alph/numeric code for the HCPC code.
  1.  ;
  1.  ;
  1. HCPCS(RMPR5,RMPR1,RMPREXC) ;
  1.  N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN
  1.  N DIC
  1.  S RMPRERR=0
  1.  S (RMPREXC,RMPRY)=""
  1.  S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))
  1. HCPCS1 S RMPRSTN=RMPR5("STATION IEN")
  1.  ; Change to DIC call is commented  above 12/13/05
  1.  N DIC
  1.  S DIC="^RMPR(661.1,"
  1.  S DIC(0)="AEQM"
  1.  ;
  1.  ; New code for Patch 93 in Set DIC line below.
  1.  ;
  1.  S DIC("S")="I $P(^(0),U,5)=1&($P(^(0),U,1)?.AN)"
  1.  D ^DIC
  1.  ;
  1.  I $D(DTOUT) S RMPREXC="T" G HCPCSX
  1.  I $D(DIROUT) S RMPREXC="P" G HCPCSX
  1.  I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G HCPCSX
  1.  ;
  1.  ; Change to DIC call included taking this second DIC Lookup out and 
  1.  ; including it in the above first DIC loopup.
  1.  ;
  1.  ;S DIC(0)="EMNZ",RMPRY=Y
  1.  ;S DIC("S")="I $P(^(0),U,5)=1!($P(^(0),U,1)'[""="""
  1.  ;S DIC=661.1
  1.  ;D ^DIC
  1.  ;
  1.  I $D(DTOUT) S RMPREXC="T" G HCPCSX
  1.  I ($G(X)["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
  1.  I +Y'>0 D  G HCPCS1
  1.  . W !
  1.  . W "** No HCPCS Selected or Unable to Select Inactive HCPCS..."
  1.  . Q
  1.  S RMPR1("HCPCS")=$P(^RMPR(661.1,+Y,0),"^",1)
  1. HCPCSX Q RMPRERR
  1.  ;
  1.  ;***** QM1 - HCPCS prompt Help - List HCPCS at a Location
  1.  ;            requires RMRPSTN - Station number
  1.  ;                     RMPR5("IEN") - Location ien
  1.  ;
  1. QM1 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRLIN,RMPRH,RMPR1
  1.  N RMPRERR,DIC
  1.  S RMPRMAX=5,RMPRLIN=0
  1.  S DIR(0)="EA"
  1.  S DIR("A")="Enter <RETURN> for more or ^ to STOP listing"
  1.  I '$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPR5("IEN"))) G QM1C
  1.  W !,"List of HCPCS at location: ",RMPR5("NAME")
  1.  S RMPRH=""
  1. QM1A S RMPRH=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPR5("IEN"),RMPRH))
  1.  I RMPRH="" G QM1C
  1.  S RMPR1("HCPCS")=RMPRH
  1.  S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
  1.  W !,RMPRH,?12,RMPR1("SHORT DESC")
  1.  S RMPRLIN=RMPRLIN+1
  1.  I RMPRLIN'<RMPRMAX G QM1B
  1.  G QM1A
  1. QM1B D ^DIR
  1.  I $D(DTOUT) S RMPREXC="T" G QM1X
  1.  I $D(DIROUT) S RMPREXC="P" G QM1X
  1.  I X="" S RMPRLIN=0 G QM1A
  1.  I X["^"!($D(DUOUT)) S RMPREXC="^" G QM1C
  1.  G QM1A
  1.  ;
  1.  ; after listing HCPCS at location make general DIC call on
  1.  ; HCPCS file 661.1
  1. QM1C S X="?",DIC=661.1,DIC(0)="EQM"
  1.  S DIC("W")="W "" "",$P(^RMPR(661.1,+Y,0),U,2) I $P(^RMPR(661.1,+Y,0),U,5)=0 W ""  **Inactive HCPCS**"""
  1.  D ^DIC
  1. QM1X Q