| [613] | 1 | RMPRPIY3 ;HINCIO/ODJ - PIP Data Entry - HCPCS prompt;3/8/01 ; 12/15/05 10:23am
|
|---|
| 2 | ;;3.0;PROSTHETICS;**61,93**;Feb 09, 1996;Build 6
|
|---|
| 3 | Q
|
|---|
| 4 | ;
|
|---|
| 5 | ;***** HCPCS - Prompt for a HCPCS code from either
|
|---|
| 6 | ; an existing stock location or
|
|---|
| 7 | ; the main HCPCS file (661.1)
|
|---|
| 8 | ; called by RMPRPIY9
|
|---|
| 9 | ;
|
|---|
| 10 | ; Inputs:
|
|---|
| 11 | ; RMPR5 - array of Location data fields...
|
|---|
| 12 | ; RMPR5("STATION IEN") - Station number of selected Location
|
|---|
| 13 | ; (ptr ^DIC(4,)
|
|---|
| 14 | ; RMPR5("IEN") - ien of selected Location (ptr ^RMPR(661.5,)
|
|---|
| 15 | ;
|
|---|
| 16 | ; Outputs:
|
|---|
| 17 | ; RMPR1 - HCPCS data field array (661.1)
|
|---|
| 18 | ; RMPREXC - exit condition
|
|---|
| 19 | ; "" - value entered, continue
|
|---|
| 20 | ; T - Time out
|
|---|
| 21 | ; P - Prvious field
|
|---|
| 22 | ; ^ - up arrow out
|
|---|
| 23 | ;
|
|---|
| 24 | ; AAC 12/13/05
|
|---|
| 25 | ; Modification to the DIC Lookup to perform any Lookup on a HCPC
|
|---|
| 26 | ; code that contains ONLY alph/numeric code for the HCPC code.
|
|---|
| 27 | ;
|
|---|
| 28 | ;
|
|---|
| 29 | HCPCS(RMPR5,RMPR1,RMPREXC) ;
|
|---|
| 30 | N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN
|
|---|
| 31 | N DIC
|
|---|
| 32 | S RMPRERR=0
|
|---|
| 33 | S (RMPREXC,RMPRY)=""
|
|---|
| 34 | S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))
|
|---|
| 35 | HCPCS1 S RMPRSTN=RMPR5("STATION IEN")
|
|---|
| 36 | ; Change to DIC call is commented above 12/13/05
|
|---|
| 37 | N DIC
|
|---|
| 38 | S DIC="^RMPR(661.1,"
|
|---|
| 39 | S DIC(0)="AEQM"
|
|---|
| 40 | ;
|
|---|
| 41 | ; New code for Patch 93 in Set DIC line below.
|
|---|
| 42 | ;
|
|---|
| 43 | S DIC("S")="I $P(^(0),U,5)=1&($P(^(0),U,1)?.AN)"
|
|---|
| 44 | D ^DIC
|
|---|
| 45 | ;
|
|---|
| 46 | I $D(DTOUT) S RMPREXC="T" G HCPCSX
|
|---|
| 47 | I $D(DIROUT) S RMPREXC="P" G HCPCSX
|
|---|
| 48 | I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G HCPCSX
|
|---|
| 49 | ;
|
|---|
| 50 | ; Change to DIC call included taking this second DIC Lookup out and
|
|---|
| 51 | ; including it in the above first DIC loopup.
|
|---|
| 52 | ;
|
|---|
| 53 | ;S DIC(0)="EMNZ",RMPRY=Y
|
|---|
| 54 | ;S DIC("S")="I $P(^(0),U,5)=1!($P(^(0),U,1)'[""="""
|
|---|
| 55 | ;S DIC=661.1
|
|---|
| 56 | ;D ^DIC
|
|---|
| 57 | ;
|
|---|
| 58 | I $D(DTOUT) S RMPREXC="T" G HCPCSX
|
|---|
| 59 | I ($G(X)["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
|
|---|
| 60 | I +Y'>0 D G HCPCS1
|
|---|
| 61 | . W !
|
|---|
| 62 | . W "** No HCPCS Selected or Unable to Select Inactive HCPCS..."
|
|---|
| 63 | . Q
|
|---|
| 64 | S RMPR1("HCPCS")=$P(^RMPR(661.1,+Y,0),"^",1)
|
|---|
| 65 | HCPCSX Q RMPRERR
|
|---|
| 66 | ;
|
|---|
| 67 | ;***** QM1 - HCPCS prompt Help - List HCPCS at a Location
|
|---|
| 68 | ; requires RMRPSTN - Station number
|
|---|
| 69 | ; RMPR5("IEN") - Location ien
|
|---|
| 70 | ;
|
|---|
| 71 | QM1 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRLIN,RMPRH,RMPR1
|
|---|
| 72 | N RMPRERR,DIC
|
|---|
| 73 | S RMPRMAX=5,RMPRLIN=0
|
|---|
| 74 | S DIR(0)="EA"
|
|---|
| 75 | S DIR("A")="Enter <RETURN> for more or ^ to STOP listing"
|
|---|
| 76 | I '$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPR5("IEN"))) G QM1C
|
|---|
| 77 | W !,"List of HCPCS at location: ",RMPR5("NAME")
|
|---|
| 78 | S RMPRH=""
|
|---|
| 79 | QM1A S RMPRH=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPR5("IEN"),RMPRH))
|
|---|
| 80 | I RMPRH="" G QM1C
|
|---|
| 81 | S RMPR1("HCPCS")=RMPRH
|
|---|
| 82 | S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
|
|---|
| 83 | W !,RMPRH,?12,RMPR1("SHORT DESC")
|
|---|
| 84 | S RMPRLIN=RMPRLIN+1
|
|---|
| 85 | I RMPRLIN'<RMPRMAX G QM1B
|
|---|
| 86 | G QM1A
|
|---|
| 87 | QM1B D ^DIR
|
|---|
| 88 | I $D(DTOUT) S RMPREXC="T" G QM1X
|
|---|
| 89 | I $D(DIROUT) S RMPREXC="P" G QM1X
|
|---|
| 90 | I X="" S RMPRLIN=0 G QM1A
|
|---|
| 91 | I X["^"!($D(DUOUT)) S RMPREXC="^" G QM1C
|
|---|
| 92 | G QM1A
|
|---|
| 93 | ;
|
|---|
| 94 | ; after listing HCPCS at location make general DIC call on
|
|---|
| 95 | ; HCPCS file 661.1
|
|---|
| 96 | QM1C S X="?",DIC=661.1,DIC(0)="EQM"
|
|---|
| 97 | 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**"""
|
|---|
| 98 | D ^DIC
|
|---|
| 99 | QM1X Q
|
|---|
