RMPRPIYV ;HINCIO/ODJ - PIP Data Entry - HCPCS;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;***** HCPCS - Prompt for HCPCS code to TRANSFER
; called by Transfer option RMPRPIYT
;
; Inputs:
; RMPR5 - Location array (from 661.5) must contain...
; RMPR5("IEN") - ien of Location
; RMPR5("STATION") - ien of location's Station
;
; RMPR1("HCPCS") - (optional) Default HCPCS code
;
; Outputs:
; RMPREXC - Exit condition
; RMPR1 - array of HCPCS data fields from 661.1
; RMPR1("IEN") - ien of HCPCS in 661.1
; RMPR1("HCPCS") - HCPCS code
; RMPR1("SHORT DESC") - HCPCS short description
;
HCPCS(RMPR5,RMPR1,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA,RMPRSTN,RMPRLCN,RMPR1N
S DIR("A")="Enter HCPCS to Transfer: "
S RMPRERR=0
S RMPREXC=""
S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))
S RMPRSTN=RMPR5("STATION")
S RMPRLCN=RMPR5("IEN")
S DIR(0)="FOA"
S DIR("?")="^D QM^RMPRPIYC"
S DIR("??")="^D QM2^RMPRPIYC"
HCPCS1 K RMPR1N D ^DIR
I $D(DTOUT) S RMPREXC="T" G HCPCSX
I $D(DIROUT) S RMPREXC="P" G HCPCSX
I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
D LIKE^RMPRPIYC(RMPRSTN,RMPRLCN,X,.RMPREXC,.RMPR1N)
I RMPREXC'="" G HCPCS1
I $G(RMPR1N("IEN"))'="" G HCPCSU
G HCPCS1
HCPCSU K RMPR1 M RMPR1=RMPR1N
HCPCSX Q RMPRERR
;
; Help System (NOT IN USE)
HLP N RMPRMAXL,RMPRH,RMPRL,RMPRERR,RMPR
S RMPRMAXL=9
W ?4,"Answer with HCPCS"
W !?3,"Choose from:"
S RMPRL=0
S RMPRH=""
F S RMPRH=$O(^RMPR(661.7,"XSLHIDS",RMPR5("STATION IEN"),RMPR5("IEN"),RMPRH)) Q:RMPRH="" D Q:RMPRL'<RMPRMAXL
. S RMPRL=RMPRL+1
. W !?3,RMPRH
. S RMPR("HCPCS")=RMPRH,RMPRERR=$$HPACT^RMPRPIX1(.RMPR)
. W ?26,RMPR("SHORT DESC")
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYV 1762 printed Dec 13, 2024@02:37:18 Page 2
RMPRPIYV ;HINCIO/ODJ - PIP Data Entry - HCPCS;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** HCPCS - Prompt for HCPCS code to TRANSFER
+5 ; called by Transfer option RMPRPIYT
+6 ;
+7 ; Inputs:
+8 ; RMPR5 - Location array (from 661.5) must contain...
+9 ; RMPR5("IEN") - ien of Location
+10 ; RMPR5("STATION") - ien of location's Station
+11 ;
+12 ; RMPR1("HCPCS") - (optional) Default HCPCS code
+13 ;
+14 ; Outputs:
+15 ; RMPREXC - Exit condition
+16 ; RMPR1 - array of HCPCS data fields from 661.1
+17 ; RMPR1("IEN") - ien of HCPCS in 661.1
+18 ; RMPR1("HCPCS") - HCPCS code
+19 ; RMPR1("SHORT DESC") - HCPCS short description
+20 ;
HCPCS(RMPR5,RMPR1,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA,RMPRSTN,RMPRLCN,RMPR1N
+2 SET DIR("A")="Enter HCPCS to Transfer: "
+3 SET RMPRERR=0
+4 SET RMPREXC=""
+5 SET RMPR1("HCPCS")=$GET(RMPR1("HCPCS"))
+6 SET RMPRSTN=RMPR5("STATION")
+7 SET RMPRLCN=RMPR5("IEN")
+8 SET DIR(0)="FOA"
+9 SET DIR("?")="^D QM^RMPRPIYC"
+10 SET DIR("??")="^D QM2^RMPRPIYC"
HCPCS1 KILL RMPR1N
DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO HCPCSX
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO HCPCSX
+3 IF X=""!(X["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO HCPCSX
+4 DO LIKE^RMPRPIYC(RMPRSTN,RMPRLCN,X,.RMPREXC,.RMPR1N)
+5 IF RMPREXC'=""
GOTO HCPCS1
+6 IF $GET(RMPR1N("IEN"))'=""
GOTO HCPCSU
+7 GOTO HCPCS1
HCPCSU KILL RMPR1
MERGE RMPR1=RMPR1N
HCPCSX QUIT RMPRERR
+1 ;
+2 ; Help System (NOT IN USE)
HLP NEW RMPRMAXL,RMPRH,RMPRL,RMPRERR,RMPR
+1 SET RMPRMAXL=9
+2 WRITE ?4,"Answer with HCPCS"
+3 WRITE !?3,"Choose from:"
+4 SET RMPRL=0
+5 SET RMPRH=""
+6 FOR
SET RMPRH=$ORDER(^RMPR(661.7,"XSLHIDS",RMPR5("STATION IEN"),RMPR5("IEN"),RMPRH))
if RMPRH=""
QUIT
Begin DoDot:1
+7 SET RMPRL=RMPRL+1
+8 WRITE !?3,RMPRH
+9 SET RMPR("HCPCS")=RMPRH
SET RMPRERR=$$HPACT^RMPRPIX1(.RMPR)
+10 WRITE ?26,RMPR("SHORT DESC")
+11 QUIT
End DoDot:1
if RMPRL'<RMPRMAXL
QUIT
+12 QUIT
