source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYV.m@ 1651

Last change on this file since 1651 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.7 KB
Line 
1RMPRPIYV ;HINCIO/ODJ - PIP Data Entry - HCPCS;3/8/01
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;
5 ;***** HCPCS - Prompt for HCPCS code to TRANSFER
6 ; called by Transfer option RMPRPIYT
7 ;
8 ; Inputs:
9 ; RMPR5 - Location array (from 661.5) must contain...
10 ; RMPR5("IEN") - ien of Location
11 ; RMPR5("STATION") - ien of location's Station
12 ;
13 ; RMPR1("HCPCS") - (optional) Default HCPCS code
14 ;
15 ; Outputs:
16 ; RMPREXC - Exit condition
17 ; RMPR1 - array of HCPCS data fields from 661.1
18 ; RMPR1("IEN") - ien of HCPCS in 661.1
19 ; RMPR1("HCPCS") - HCPCS code
20 ; RMPR1("SHORT DESC") - HCPCS short description
21 ;
22HCPCS(RMPR5,RMPR1,RMPREXC) ;
23 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA,RMPRSTN,RMPRLCN,RMPR1N
24 S DIR("A")="Enter HCPCS to Transfer: "
25 S RMPRERR=0
26 S RMPREXC=""
27 S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))
28 S RMPRSTN=RMPR5("STATION")
29 S RMPRLCN=RMPR5("IEN")
30 S DIR(0)="FOA"
31 S DIR("?")="^D QM^RMPRPIYC"
32 S DIR("??")="^D QM2^RMPRPIYC"
33HCPCS1 K RMPR1N D ^DIR
34 I $D(DTOUT) S RMPREXC="T" G HCPCSX
35 I $D(DIROUT) S RMPREXC="P" G HCPCSX
36 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
37 D LIKE^RMPRPIYC(RMPRSTN,RMPRLCN,X,.RMPREXC,.RMPR1N)
38 I RMPREXC'="" G HCPCS1
39 I $G(RMPR1N("IEN"))'="" G HCPCSU
40 G HCPCS1
41HCPCSU K RMPR1 M RMPR1=RMPR1N
42HCPCSX Q RMPRERR
43 ;
44 ; Help System (NOT IN USE)
45HLP N RMPRMAXL,RMPRH,RMPRL,RMPRERR,RMPR
46 S RMPRMAXL=9
47 W ?4,"Answer with HCPCS"
48 W !?3,"Choose from:"
49 S RMPRL=0
50 S RMPRH=""
51 F S RMPRH=$O(^RMPR(661.7,"XSLHIDS",RMPR5("STATION IEN"),RMPR5("IEN"),RMPRH)) Q:RMPRH="" D Q:RMPRL'<RMPRMAXL
52 . S RMPRL=RMPRL+1
53 . W !?3,RMPRH
54 . S RMPR("HCPCS")=RMPRH,RMPRERR=$$HPACT^RMPRPIX1(.RMPR)
55 . W ?26,RMPR("SHORT DESC")
56 . Q
57 Q
Note: See TracBrowser for help on using the repository browser.