RMPRPIY3 ;HINCIO/ODJ - PIP Data Entry - HCPCS prompt;3/8/01 ; 12/15/05 10:23am
;;3.0;PROSTHETICS;**61,93**;Feb 09, 1996;Build 6
Q
;
;***** HCPCS - Prompt for a HCPCS code from either
; an existing stock location or
; the main HCPCS file (661.1)
; called by RMPRPIY9
;
; Inputs:
; RMPR5 - array of Location data fields...
; RMPR5("STATION IEN") - Station number of selected Location
; (ptr ^DIC(4,)
; RMPR5("IEN") - ien of selected Location (ptr ^RMPR(661.5,)
;
; Outputs:
; RMPR1 - HCPCS data field array (661.1)
; RMPREXC - exit condition
; "" - value entered, continue
; T - Time out
; P - Prvious field
; ^ - up arrow out
;
; AAC 12/13/05
; Modification to the DIC Lookup to perform any Lookup on a HCPC
; code that contains ONLY alph/numeric code for the HCPC code.
;
;
HCPCS(RMPR5,RMPR1,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN
N DIC
S RMPRERR=0
S (RMPREXC,RMPRY)=""
S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))
HCPCS1 S RMPRSTN=RMPR5("STATION IEN")
; Change to DIC call is commented above 12/13/05
N DIC
S DIC="^RMPR(661.1,"
S DIC(0)="AEQM"
;
; New code for Patch 93 in Set DIC line below.
;
S DIC("S")="I $P(^(0),U,5)=1&($P(^(0),U,1)?.AN)"
D ^DIC
;
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
;
; Change to DIC call included taking this second DIC Lookup out and
; including it in the above first DIC loopup.
;
;S DIC(0)="EMNZ",RMPRY=Y
;S DIC("S")="I $P(^(0),U,5)=1!($P(^(0),U,1)'[""="""
;S DIC=661.1
;D ^DIC
;
I $D(DTOUT) S RMPREXC="T" G HCPCSX
I ($G(X)["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
I +Y'>0 D G HCPCS1
. W !
. W "** No HCPCS Selected or Unable to Select Inactive HCPCS..."
. Q
S RMPR1("HCPCS")=$P(^RMPR(661.1,+Y,0),"^",1)
HCPCSX Q RMPRERR
;
;***** QM1 - HCPCS prompt Help - List HCPCS at a Location
; requires RMRPSTN - Station number
; RMPR5("IEN") - Location ien
;
QM1 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRLIN,RMPRH,RMPR1
N RMPRERR,DIC
S RMPRMAX=5,RMPRLIN=0
S DIR(0)="EA"
S DIR("A")="Enter <RETURN> for more or ^ to STOP listing"
I '$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPR5("IEN"))) G QM1C
W !,"List of HCPCS at location: ",RMPR5("NAME")
S RMPRH=""
QM1A S RMPRH=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPR5("IEN"),RMPRH))
I RMPRH="" G QM1C
S RMPR1("HCPCS")=RMPRH
S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
W !,RMPRH,?12,RMPR1("SHORT DESC")
S RMPRLIN=RMPRLIN+1
I RMPRLIN'<RMPRMAX G QM1B
G QM1A
QM1B D ^DIR
I $D(DTOUT) S RMPREXC="T" G QM1X
I $D(DIROUT) S RMPREXC="P" G QM1X
I X="" S RMPRLIN=0 G QM1A
I X["^"!($D(DUOUT)) S RMPREXC="^" G QM1C
G QM1A
;
; after listing HCPCS at location make general DIC call on
; HCPCS file 661.1
QM1C S X="?",DIC=661.1,DIC(0)="EQM"
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**"""
D ^DIC
QM1X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIY3 3157 printed Oct 16, 2024@18:37:30 Page 2
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
+2 QUIT
+3 ;
+4 ;***** HCPCS - Prompt for a HCPCS code from either
+5 ; an existing stock location or
+6 ; the main HCPCS file (661.1)
+7 ; called by RMPRPIY9
+8 ;
+9 ; Inputs:
+10 ; RMPR5 - array of Location data fields...
+11 ; RMPR5("STATION IEN") - Station number of selected Location
+12 ; (ptr ^DIC(4,)
+13 ; RMPR5("IEN") - ien of selected Location (ptr ^RMPR(661.5,)
+14 ;
+15 ; Outputs:
+16 ; RMPR1 - HCPCS data field array (661.1)
+17 ; RMPREXC - exit condition
+18 ; "" - value entered, continue
+19 ; T - Time out
+20 ; P - Prvious field
+21 ; ^ - up arrow out
+22 ;
+23 ; AAC 12/13/05
+24 ; Modification to the DIC Lookup to perform any Lookup on a HCPC
+25 ; code that contains ONLY alph/numeric code for the HCPC code.
+26 ;
+27 ;
HCPCS(RMPR5,RMPR1,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN
+2 NEW DIC
+3 SET RMPRERR=0
+4 SET (RMPREXC,RMPRY)=""
+5 SET RMPR1("HCPCS")=$GET(RMPR1("HCPCS"))
HCPCS1 SET RMPRSTN=RMPR5("STATION IEN")
+1 ; Change to DIC call is commented above 12/13/05
+2 NEW DIC
+3 SET DIC="^RMPR(661.1,"
+4 SET DIC(0)="AEQM"
+5 ;
+6 ; New code for Patch 93 in Set DIC line below.
+7 ;
+8 SET DIC("S")="I $P(^(0),U,5)=1&($P(^(0),U,1)?.AN)"
+9 DO ^DIC
+10 ;
+11 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO HCPCSX
+12 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO HCPCSX
+13 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO HCPCSX
+14 ;
+15 ; Change to DIC call included taking this second DIC Lookup out and
+16 ; including it in the above first DIC loopup.
+17 ;
+18 ;S DIC(0)="EMNZ",RMPRY=Y
+19 ;S DIC("S")="I $P(^(0),U,5)=1!($P(^(0),U,1)'[""="""
+20 ;S DIC=661.1
+21 ;D ^DIC
+22 ;
+23 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO HCPCSX
+24 IF ($GET(X)["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO HCPCSX
+25 IF +Y'>0
Begin DoDot:1
+26 WRITE !
+27 WRITE "** No HCPCS Selected or Unable to Select Inactive HCPCS..."
+28 QUIT
End DoDot:1
GOTO HCPCS1
+29 SET RMPR1("HCPCS")=$PIECE(^RMPR(661.1,+Y,0),"^",1)
HCPCSX QUIT RMPRERR
+1 ;
+2 ;***** QM1 - HCPCS prompt Help - List HCPCS at a Location
+3 ; requires RMRPSTN - Station number
+4 ; RMPR5("IEN") - Location ien
+5 ;
QM1 NEW DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRLIN,RMPRH,RMPR1
+1 NEW RMPRERR,DIC
+2 SET RMPRMAX=5
SET RMPRLIN=0
+3 SET DIR(0)="EA"
+4 SET DIR("A")="Enter <RETURN> for more or ^ to STOP listing"
+5 IF '$DATA(^RMPR(661.4,"ASLHI",RMPRSTN,RMPR5("IEN")))
GOTO QM1C
+6 WRITE !,"List of HCPCS at location: ",RMPR5("NAME")
+7 SET RMPRH=""
QM1A SET RMPRH=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPR5("IEN"),RMPRH))
+1 IF RMPRH=""
GOTO QM1C
+2 SET RMPR1("HCPCS")=RMPRH
+3 SET RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
+4 WRITE !,RMPRH,?12,RMPR1("SHORT DESC")
+5 SET RMPRLIN=RMPRLIN+1
+6 IF RMPRLIN'<RMPRMAX
GOTO QM1B
+7 GOTO QM1A
QM1B DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO QM1X
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO QM1X
+3 IF X=""
SET RMPRLIN=0
GOTO QM1A
+4 IF X["^"!($DATA(DUOUT))
SET RMPREXC="^"
GOTO QM1C
+5 GOTO QM1A
+6 ;
+7 ; after listing HCPCS at location make general DIC call on
+8 ; HCPCS file 661.1
QM1C SET X="?"
SET DIC=661.1
SET DIC(0)="EQM"
+1 SET DIC("W")="W "" "",$P(^RMPR(661.1,+Y,0),U,2) I $P(^RMPR(661.1,+Y,0),U,5)=0 W "" **Inactive HCPCS**"""
+2 DO ^DIC
QM1X QUIT
