RMPRPIY8 ;HINCIO/ODJ - Pick HCPCS Item ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
; ? Help
QM W ?4,"Answer with ITEM, or NUMBER, or DESCRIPTION"
W !?3,"Choose from:"
D QM2
Q
;
; ?? Help
QQM W !?3,"Choose from:"
D QM2
Q
QM2 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRI,RMPRLIN,RMPR,RMPRERR
S RMPRMAX=5,RMPRLIN=0
S RMPREXC=""
S DIR(0)="EA"
S DIR("A")="'^' TO STOP: "
S RMPRI=""
QM2A S RMPRI=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI))
I RMPRI="" G QM2X
K RMPR
S RMPR("STATION")=RMPRSTN
S RMPR("HCPCS")=RMPRHCPC
S RMPR("ITEM")=RMPRI
S RMPRERR=$$GET^RMPRPIX1(.RMPR)
S RMPRLIN=RMPRLIN+1
W !?3,RMPRLIN,?16,RMPR("HCPCS-ITEM"),?28,RMPR("DESCRIPTION")
I RMPRLIN'<RMPRMAX G QM2B
G QM2A
QM2B D ^DIR
I $D(DTOUT) S RMPREXC="T" G QM2X
I $D(DIROUT) S RMPREXC="P" G QM2X
I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G QM2X
QM2X Q
;
;
LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11,RMPR4) ;
N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
N RMPRERR,RMPRN,RMPRGBL,RMPR,RMPREXMA,RMPRI,RMPRIEN,RMPRH
S RMPREXC=""
S RMPRMAX=5
S RMPR4("IEN")=""
;
; NUMBER entered
; loop on index until count=entered number
I RMPRTXT?1.N D G LIKEX
. S RMPRLIN=0
. S RMPRI=""
. F S RMPRI=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI)) Q:RMPRI="" D Q:RMPR4("IEN")'=""
.. S RMPRLIN=RMPRLIN+1
.. I RMPRLIN=RMPRTXT D
... S RMPRIEN=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI,""))
... S RMPR4("IEN")=RMPRIEN
... K RMPR11
... S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
... S RMPR11("STATION")=RMPRSTN
... S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
... Q
.. Q
. Q
;
; ITEM entered (HCPCS-ITEM form eg. L5000-3)
S RMPRH=$P(RMPRTXT,"-",1)
I $E(RMPRHCPC,1,$L(RMPRH))=RMPRH G LIKEH1 ;use 661.4 index
;
; DESCRIPTION entered - use 661.11 index
S RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
LIKEA1 K RMPRA S RMPRLIN=0
LIKEA S RMPRGBL=$Q(@RMPRGBL)
I RMPRGBL="" G LIKEB
I $QS(RMPRGBL,1)'=661.11 G LIKEB
I $QS(RMPRGBL,2)'="ASHD" G LIKEB
I $QS(RMPRGBL,3)'=RMPRSTN G LIKEB
I $QS(RMPRGBL,4)'=RMPRHCPC G LIKEB
I $E($QS(RMPRGBL,5),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
K RMPR
S RMPR("IEN")=$QS(RMPRGBL,6)
S RMPRERR=$$GET^RMPRPIX1(.RMPR) ;read 661.11 file
I '$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"))) G LIKEA ;item not in selected location
S RMPRLIN=RMPRLIN+1
W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5),?40,RMPR("HCPCS-ITEM")
S RMPRIEN=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"),""))
S RMPRA(RMPRLIN)=RMPRIEN
I RMPRLIN'<RMPRMAX G LIKEB
G LIKEA
LIKEB I RMPRLIN=0 G LIKEX
S DIR(0)="NAO^1:"_RMPRLIN_": "
S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
D ^DIR
W !
I $D(DTOUT) S RMPREXC="T" G LIKEX
I $D(DIROUT) S RMPREXC="P" G LIKEX
I X="" S RMPREXC="" G LIKEA
I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
K RMPR11
S RMPR4("IEN")=RMPRA(X)
S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
S RMPR11("STATION")=RMPRSTN
S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
G LIKEX
;
;
LIKEH1 S RMPRI=$P(RMPRTXT,"-",2)
I RMPRI'="",$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI)) D G LIKEH9A
. S RMPR4("IEN")=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI,""))
. Q
S RMPRGBL="^RMPR(661.4,"_"""ASLHI"","_RMPRSTN_","_RMPRLCN_","""_RMPRH_""")"
K RMPRA S RMPRLIN=0
LIKEH S RMPRGBL=$Q(@RMPRGBL)
I RMPRGBL="" G LIKEH9
I $QS(RMPRGBL,1)'=661.4 G LIKEH9
I $QS(RMPRGBL,2)'="ASLHI" G LIKEH9
I $QS(RMPRGBL,3)'=RMPRSTN G LIKEH9
I $QS(RMPRGBL,4)'=RMPRLCN G LIKEH9
I $QS(RMPRGBL,5)'=RMPRHCPC G LIKEH
S RMPR("IEN")=$QS(RMPRGBL,7)
K RMPR11
S RMPRERR=$$GET^RMPRPIX4(.RMPR,.RMPR11,)
S RMPR11("STATION")=RMPRSTN
S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
S RMPRLIN=RMPRLIN+1
W !?4,$J(RMPRLIN,2),?9,RMPR11("HCPCS-ITEM"),?23,RMPR11("DESCRIPTION")
S RMPRA(RMPRLIN)=$QS(RMPRGBL,7)
I RMPRLIN'<RMPRMAX G LIKEH9
G LIKEH
LIKEH9 I RMPRLIN=0 G LIKEX
S DIR(0)="NAO^1:"_RMPRLIN_": "
S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
D ^DIR
W !
I $D(DTOUT) S RMPREXC="T" G LIKEX
I $D(DIROUT) S RMPREXC="P" G LIKEX
I X="" S RMPREXC="" G LIKEH
I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
S RMPR4("IEN")=RMPRA(X)
LIKEH9A K RMPR11
S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
S RMPR11("STATION")=RMPRSTN
S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
G LIKEX
;exit
LIKEX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIY8 4384 printed Sep 23, 2025@20:13:06 Page 2
RMPRPIY8 ;HINCIO/ODJ - Pick HCPCS Item ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ; ? Help
QM WRITE ?4,"Answer with ITEM, or NUMBER, or DESCRIPTION"
+1 WRITE !?3,"Choose from:"
+2 DO QM2
+3 QUIT
+4 ;
+5 ; ?? Help
QQM WRITE !?3,"Choose from:"
+1 DO QM2
+2 QUIT
QM2 NEW DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRI,RMPRLIN,RMPR,RMPRERR
+1 SET RMPRMAX=5
SET RMPRLIN=0
+2 SET RMPREXC=""
+3 SET DIR(0)="EA"
+4 SET DIR("A")="'^' TO STOP: "
+5 SET RMPRI=""
QM2A SET RMPRI=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI))
+1 IF RMPRI=""
GOTO QM2X
+2 KILL RMPR
+3 SET RMPR("STATION")=RMPRSTN
+4 SET RMPR("HCPCS")=RMPRHCPC
+5 SET RMPR("ITEM")=RMPRI
+6 SET RMPRERR=$$GET^RMPRPIX1(.RMPR)
+7 SET RMPRLIN=RMPRLIN+1
+8 WRITE !?3,RMPRLIN,?16,RMPR("HCPCS-ITEM"),?28,RMPR("DESCRIPTION")
+9 IF RMPRLIN'<RMPRMAX
GOTO QM2B
+10 GOTO QM2A
QM2B DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO QM2X
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO QM2X
+3 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO QM2X
QM2X QUIT
+1 ;
+2 ;
LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11,RMPR4) ;
+1 NEW RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
+2 NEW RMPRERR,RMPRN,RMPRGBL,RMPR,RMPREXMA,RMPRI,RMPRIEN,RMPRH
+3 SET RMPREXC=""
+4 SET RMPRMAX=5
+5 SET RMPR4("IEN")=""
+6 ;
+7 ; NUMBER entered
+8 ; loop on index until count=entered number
+9 IF RMPRTXT?1.N
Begin DoDot:1
+10 SET RMPRLIN=0
+11 SET RMPRI=""
+12 FOR
SET RMPRI=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI))
if RMPRI=""
QUIT
Begin DoDot:2
+13 SET RMPRLIN=RMPRLIN+1
+14 IF RMPRLIN=RMPRTXT
Begin DoDot:3
+15 SET RMPRIEN=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI,""))
+16 SET RMPR4("IEN")=RMPRIEN
+17 KILL RMPR11
+18 SET RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
+19 SET RMPR11("STATION")=RMPRSTN
+20 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+21 QUIT
End DoDot:3
+22 QUIT
End DoDot:2
if RMPR4("IEN")'=""
QUIT
+23 QUIT
End DoDot:1
GOTO LIKEX
+24 ;
+25 ; ITEM entered (HCPCS-ITEM form eg. L5000-3)
+26 SET RMPRH=$PIECE(RMPRTXT,"-",1)
+27 ;use 661.4 index
IF $EXTRACT(RMPRHCPC,1,$LENGTH(RMPRH))=RMPRH
GOTO LIKEH1
+28 ;
+29 ; DESCRIPTION entered - use 661.11 index
+30 SET RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
LIKEA1 KILL RMPRA
SET RMPRLIN=0
LIKEA SET RMPRGBL=$QUERY(@RMPRGBL)
+1 IF RMPRGBL=""
GOTO LIKEB
+2 IF $QSUBSCRIPT(RMPRGBL,1)'=661.11
GOTO LIKEB
+3 IF $QSUBSCRIPT(RMPRGBL,2)'="ASHD"
GOTO LIKEB
+4 IF $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
GOTO LIKEB
+5 IF $QSUBSCRIPT(RMPRGBL,4)'=RMPRHCPC
GOTO LIKEB
+6 IF $EXTRACT($QSUBSCRIPT(RMPRGBL,5),1,$LENGTH(RMPRTXT))'=RMPRTXT
GOTO LIKEB
+7 KILL RMPR
+8 SET RMPR("IEN")=$QSUBSCRIPT(RMPRGBL,6)
+9 ;read 661.11 file
SET RMPRERR=$$GET^RMPRPIX1(.RMPR)
+10 ;item not in selected location
IF '$DATA(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM")))
GOTO LIKEA
+11 SET RMPRLIN=RMPRLIN+1
+12 WRITE !?4,$JUSTIFY(RMPRLIN,2),?9,$QSUBSCRIPT(RMPRGBL,5),?40,RMPR("HCPCS-ITEM")
+13 SET RMPRIEN=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"),""))
+14 SET RMPRA(RMPRLIN)=RMPRIEN
+15 IF RMPRLIN'<RMPRMAX
GOTO LIKEB
+16 GOTO LIKEA
LIKEB IF RMPRLIN=0
GOTO LIKEX
+1 SET DIR(0)="NAO^1:"_RMPRLIN_": "
+2 SET DIR("A")="CHOOSE 1-"_RMPRLIN_": "
+3 DO ^DIR
+4 WRITE !
+5 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LIKEX
+6 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LIKEX
+7 IF X=""
SET RMPREXC=""
GOTO LIKEA
+8 IF X["^"!$DATA(DUOUT)
SET RMPREXC="^"
GOTO LIKEX
+9 KILL RMPR11
+10 SET RMPR4("IEN")=RMPRA(X)
+11 SET RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
+12 SET RMPR11("STATION")=RMPRSTN
+13 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+14 GOTO LIKEX
+15 ;
+16 ;
LIKEH1 SET RMPRI=$PIECE(RMPRTXT,"-",2)
+1 IF RMPRI'=""
IF $DATA(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI))
Begin DoDot:1
+2 SET RMPR4("IEN")=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI,""))
+3 QUIT
End DoDot:1
GOTO LIKEH9A
+4 SET RMPRGBL="^RMPR(661.4,"_"""ASLHI"","_RMPRSTN_","_RMPRLCN_","""_RMPRH_""")"
+5 KILL RMPRA
SET RMPRLIN=0
LIKEH SET RMPRGBL=$QUERY(@RMPRGBL)
+1 IF RMPRGBL=""
GOTO LIKEH9
+2 IF $QSUBSCRIPT(RMPRGBL,1)'=661.4
GOTO LIKEH9
+3 IF $QSUBSCRIPT(RMPRGBL,2)'="ASLHI"
GOTO LIKEH9
+4 IF $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
GOTO LIKEH9
+5 IF $QSUBSCRIPT(RMPRGBL,4)'=RMPRLCN
GOTO LIKEH9
+6 IF $QSUBSCRIPT(RMPRGBL,5)'=RMPRHCPC
GOTO LIKEH
+7 SET RMPR("IEN")=$QSUBSCRIPT(RMPRGBL,7)
+8 KILL RMPR11
+9 SET RMPRERR=$$GET^RMPRPIX4(.RMPR,.RMPR11,)
+10 SET RMPR11("STATION")=RMPRSTN
+11 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+12 SET RMPRLIN=RMPRLIN+1
+13 WRITE !?4,$JUSTIFY(RMPRLIN,2),?9,RMPR11("HCPCS-ITEM"),?23,RMPR11("DESCRIPTION")
+14 SET RMPRA(RMPRLIN)=$QSUBSCRIPT(RMPRGBL,7)
+15 IF RMPRLIN'<RMPRMAX
GOTO LIKEH9
+16 GOTO LIKEH
LIKEH9 IF RMPRLIN=0
GOTO LIKEX
+1 SET DIR(0)="NAO^1:"_RMPRLIN_": "
+2 SET DIR("A")="CHOOSE 1-"_RMPRLIN_": "
+3 DO ^DIR
+4 WRITE !
+5 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LIKEX
+6 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LIKEX
+7 IF X=""
SET RMPREXC=""
GOTO LIKEH
+8 IF X["^"!$DATA(DUOUT)
SET RMPREXC="^"
GOTO LIKEX
+9 SET RMPR4("IEN")=RMPRA(X)
LIKEH9A KILL RMPR11
+1 SET RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
+2 SET RMPR11("STATION")=RMPRSTN
+3 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+4 GOTO LIKEX
+5 ;exit
LIKEX QUIT
