RMPRPIYD ;HINES OIFO/ODJ - PIP RECONCILE - Pick HCPCS Item;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
; Get an Item - restrict choice to Location and HCPC
ITEM(RMPRSTN,RMPRLCN,RMPR11,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRHCPC
S RMPRERR=0
S RMPREXC=""
I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX
I $G(RMPR11("HCPCS"))="" S RMPRERR=2 G ITEMX
S RMPR11("STATION")=RMPRSTN
S RMPR11("STATION IEN")=RMPRSTN
S RMPRHCPC=RMPR11("HCPCS")
S DIR(0)="FOA^1:50"
S DIR("A")="Enter Item to RECONCILE: "
S DIR("?")="^D QM^RMPRPIYD"
S DIR("??")="^D QQM^RMPRPIYD"
ITEMA1 D ^DIR
I $D(DTOUT) S RMPREXC="T" G ITEMX
I $D(DIROUT) S RMPREXC="P" G ITEMX
I X=""!(X["^") S RMPREXC="^" G ITEMX
S RMPR11("IEN")=""
D LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11)
I RMPREXC="T" G ITEMX
I RMPREXC="P" G ITEMX
I RMPREXC="^" G ITEMA1
I RMPR11("IEN")="",$L(X)<3 G ITEMA1
I RMPR11("IEN")="" S RMPR11("DESCRIPTION")=X G ITEMX
G ITEMX
ITEMX Q RMPRERR
;
; CHKN - Check an Item Number
;
; Inputs:
; RMPR11 - array consisting of the following subscripts...
; RMPR11("STATION") - Station ien (eg 499)
; RMPR11("HCPCS") - HCPCS code (eg E0111)
; RMPR11("ITEM") - HCPCS Item number (eg 1)
;
; Outputs:
; RMPR11 - additional elements from 661.11 record if Item exists...
; RMPR11("DESCRIPTION") - Item Description
; RMPR11("HCPCS-ITEM") - Combined HCPCS Item code (eg E0111-1)
; RMPR11("IEN") - ien of record
; RMPR11("SOURCE") - Source (external format)
; RMPR11("STATION") - Station Name (external format)
; RMPR11("UNIT") - Unit of Measure (external format)
; RMPR11("STATION IEN") - ien of input Station
;
; RMPRERR - exit condition (returned by function)
; 0 - no erros
; 1 - null station ien
; 2 - null HCPCS code
; 3 - HCPCS Item not valid number
; 4 - Item does not exist
; 99 - Problem with 661.11 file
;
CHKN(RMPR11) ;
N RMPRERR
S RMPRERR=0
I $G(RMPR11("STATION"))="" S RMPRERR=1 G CHKNX
S RMPR11("STATION IEN")=RMPR11("STATION")
I $G(RMPR11("HCPCS"))="" S RMPRERR=2 G CHKNX
I $G(RMPR11("ITEM"))'?1.N S RMPRERR=3 G CHKNX
I '$D(^RMPR(661.11,"ASHI",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"))) S RMPRERR=4 G CHKNX
S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
I RMPRERR S RMPRERR=99
CHKNX Q RMPRERR
;
; CHKD - Check an Item Description
;
; Inputs:
; RMPR11 - array consisting of the following subscripts...
; RMPR11("STATION") - Station ien (eg 499)
; RMPR11("HCPCS") - HCPCS code (eg E0111)
; RMPR11("DESCRIPTION") - HCPCS Item Description
;
; Outputs:
; RMPR11 - additional elements from 661.11 record if Item exists...
; RMPR11("ITEM") - HCPCS Item number
; RMPR11("HCPCS-ITEM") - Combined HCPCS Item code (eg E0111-1)
; RMPR11("IEN") - ien of record
; RMPR11("SOURCE") - Source (external format)
; RMPR11("STATION") - Station Name (external format)
; RMPR11("UNIT") - Unit of Measure (external format)
; RMPR11("STATION IEN") - ien of input Station
;
; RMPRERR - exit condition (returned by function)
; 0 - no erros
; 1 - null station ien
; 2 - null HCPCS code
; 3 - null HCPCS Item Desc.
; 4 - Item does not exist
; 5 - Item does not exist, but there are items matching
; the entered description text
; 99 - Problem with 661.11 file
;
CHKD(RMPR11) ;
N RMPRERR,RMPRD
S RMPRERR=0
I $G(RMPR11("STATION"))="" S RMPRERR=1 G CHKDX
S RMPR11("STATION IEN")=RMPR11("STATION")
I $G(RMPR11("HCPCS"))="" S RMPRERR=2 G CHKDX
I $G(RMPR11("DESCRIPTION"))="" S RMPRERR=3 G CHKDX
I '$D(^RMPR(661.11,"XSD",RMPR11("STATION"),RMPR11("DESCRIPTION"),RMPR11("HCPCS"))) D G CHKDX
. S RMPRERR=4
. S RMPRD=RMPR11("DESCRIPTION")
. S RMPRD=$O(^RMPR(661.11,"XSD",RMPR11("STATION"),RMPRD))
. I $E(RMPRD,1,$L(RMPR11("DESCRIPTION")))=RMPR11("DESCRIPTION") S RMPRERR=5
. Q
S RMPR11("IEN")=$O(^RMPR(661.11,"XSD",RMPR11("STATION"),RMPR11("DESCRIPTION"),RMPR11("HCPCS"),""))
S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
I RMPRERR S RMPRERR=99
CHKDX Q RMPRERR
;
; Prompt if adding a new HCPCS Item
OKADD(RMPR11,RMPRYN,RMPREXC) ;
N DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT
S RMPREXC=""
S DIR(0)="Y"
S DIR("A")="Are you adding '"_RMPR11("DESCRIPTION")_"' as a new ITEM for this HCPCS"
D ^DIR
I $D(DTOUT) S RMPREXC="T" G ADDNMX
I $D(DIROUT) S RMPREXC="P" G ADDNMX
I X=""!(X["^") S RMPREXC="^" G ADDNMX
S RMPRYN="N" S:Y RMPRYN="Y"
S RMPREXC=""
ADDNMX Q
;
; Single ? Help
QM W ?4,"Answer with ITEM NUMBER or DESCRIPTION:"
D QM2
Q
QQM D QM2
W !!?8,"You may enter a new ITEM, if you wish"
W !?8,"This is an Item or Appliance under PSAS HCPCS kept by local site in"
W !?8,"Prosthetics Inventory module."
Q
QM2 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRI,RMPRLIN,RMPR,RMPRERR
S RMPRMAX=19,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)
W !?3,RMPRI,?16,RMPR("HCPCS-ITEM"),?28,RMPR("DESCRIPTION")
S RMPRLIN=RMPRLIN+1
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) ;
N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
N RMPRERR,RMPRN,RMPRGBL,RMPR,RMPREXMA
S RMPREXC=""
S RMPRMAX=19
S RMPREXMA=""
I $D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT)) D
. S RMPREXMA=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,""))
. Q
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)
I '$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"))) G LIKEA
I RMPREXMA'="" D
. S RMPREXMA("IEN")=RMPREXMA
. S RMPRERR=$$GET^RMPRPIX1(.RMPREXMA)
. S RMPRLIN=RMPRLIN+1
. W !?4,$J(RMPRLIN,2),?9,RMPREXMA("DESCRIPTION")
. S RMPRA(RMPRLIN)=RMPREXMA("IEN")
. K RMPREXMA
. S RMPREXMA=""
. Q
S RMPRLIN=RMPRLIN+1
W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5)
S RMPRA(RMPRLIN)=$QS(RMPRGBL,6)
I RMPRLIN'<RMPRMAX G LIKEB
G LIKEA
LIKEB I RMPRLIN=0 D G LIKEX
. Q:RMPREXMA=""
. S RMPR11("IEN")=RMPREXMA
. S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
. Q
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 LIKEX
I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
K RMPR11
S RMPR11("IEN")=RMPRA(X)
S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
LIKEX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYD 7362 printed Sep 23, 2025@20:13:11 Page 2
RMPRPIYD ;HINES OIFO/ODJ - PIP RECONCILE - Pick HCPCS Item;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ; Get an Item - restrict choice to Location and HCPC
ITEM(RMPRSTN,RMPRLCN,RMPR11,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRHCPC
+2 SET RMPRERR=0
+3 SET RMPREXC=""
+4 IF $GET(RMPRSTN)=""
SET RMPRERR=1
GOTO ITEMX
+5 IF $GET(RMPR11("HCPCS"))=""
SET RMPRERR=2
GOTO ITEMX
+6 SET RMPR11("STATION")=RMPRSTN
+7 SET RMPR11("STATION IEN")=RMPRSTN
+8 SET RMPRHCPC=RMPR11("HCPCS")
+9 SET DIR(0)="FOA^1:50"
+10 SET DIR("A")="Enter Item to RECONCILE: "
+11 SET DIR("?")="^D QM^RMPRPIYD"
+12 SET DIR("??")="^D QQM^RMPRPIYD"
ITEMA1 DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO ITEMX
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO ITEMX
+3 IF X=""!(X["^")
SET RMPREXC="^"
GOTO ITEMX
+4 SET RMPR11("IEN")=""
+5 DO LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11)
+6 IF RMPREXC="T"
GOTO ITEMX
+7 IF RMPREXC="P"
GOTO ITEMX
+8 IF RMPREXC="^"
GOTO ITEMA1
+9 IF RMPR11("IEN")=""
IF $LENGTH(X)<3
GOTO ITEMA1
+10 IF RMPR11("IEN")=""
SET RMPR11("DESCRIPTION")=X
GOTO ITEMX
+11 GOTO ITEMX
ITEMX QUIT RMPRERR
+1 ;
+2 ; CHKN - Check an Item Number
+3 ;
+4 ; Inputs:
+5 ; RMPR11 - array consisting of the following subscripts...
+6 ; RMPR11("STATION") - Station ien (eg 499)
+7 ; RMPR11("HCPCS") - HCPCS code (eg E0111)
+8 ; RMPR11("ITEM") - HCPCS Item number (eg 1)
+9 ;
+10 ; Outputs:
+11 ; RMPR11 - additional elements from 661.11 record if Item exists...
+12 ; RMPR11("DESCRIPTION") - Item Description
+13 ; RMPR11("HCPCS-ITEM") - Combined HCPCS Item code (eg E0111-1)
+14 ; RMPR11("IEN") - ien of record
+15 ; RMPR11("SOURCE") - Source (external format)
+16 ; RMPR11("STATION") - Station Name (external format)
+17 ; RMPR11("UNIT") - Unit of Measure (external format)
+18 ; RMPR11("STATION IEN") - ien of input Station
+19 ;
+20 ; RMPRERR - exit condition (returned by function)
+21 ; 0 - no erros
+22 ; 1 - null station ien
+23 ; 2 - null HCPCS code
+24 ; 3 - HCPCS Item not valid number
+25 ; 4 - Item does not exist
+26 ; 99 - Problem with 661.11 file
+27 ;
CHKN(RMPR11) ;
+1 NEW RMPRERR
+2 SET RMPRERR=0
+3 IF $GET(RMPR11("STATION"))=""
SET RMPRERR=1
GOTO CHKNX
+4 SET RMPR11("STATION IEN")=RMPR11("STATION")
+5 IF $GET(RMPR11("HCPCS"))=""
SET RMPRERR=2
GOTO CHKNX
+6 IF $GET(RMPR11("ITEM"))'?1.N
SET RMPRERR=3
GOTO CHKNX
+7 IF '$DATA(^RMPR(661.11,"ASHI",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM")))
SET RMPRERR=4
GOTO CHKNX
+8 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+9 IF RMPRERR
SET RMPRERR=99
CHKNX QUIT RMPRERR
+1 ;
+2 ; CHKD - Check an Item Description
+3 ;
+4 ; Inputs:
+5 ; RMPR11 - array consisting of the following subscripts...
+6 ; RMPR11("STATION") - Station ien (eg 499)
+7 ; RMPR11("HCPCS") - HCPCS code (eg E0111)
+8 ; RMPR11("DESCRIPTION") - HCPCS Item Description
+9 ;
+10 ; Outputs:
+11 ; RMPR11 - additional elements from 661.11 record if Item exists...
+12 ; RMPR11("ITEM") - HCPCS Item number
+13 ; RMPR11("HCPCS-ITEM") - Combined HCPCS Item code (eg E0111-1)
+14 ; RMPR11("IEN") - ien of record
+15 ; RMPR11("SOURCE") - Source (external format)
+16 ; RMPR11("STATION") - Station Name (external format)
+17 ; RMPR11("UNIT") - Unit of Measure (external format)
+18 ; RMPR11("STATION IEN") - ien of input Station
+19 ;
+20 ; RMPRERR - exit condition (returned by function)
+21 ; 0 - no erros
+22 ; 1 - null station ien
+23 ; 2 - null HCPCS code
+24 ; 3 - null HCPCS Item Desc.
+25 ; 4 - Item does not exist
+26 ; 5 - Item does not exist, but there are items matching
+27 ; the entered description text
+28 ; 99 - Problem with 661.11 file
+29 ;
CHKD(RMPR11) ;
+1 NEW RMPRERR,RMPRD
+2 SET RMPRERR=0
+3 IF $GET(RMPR11("STATION"))=""
SET RMPRERR=1
GOTO CHKDX
+4 SET RMPR11("STATION IEN")=RMPR11("STATION")
+5 IF $GET(RMPR11("HCPCS"))=""
SET RMPRERR=2
GOTO CHKDX
+6 IF $GET(RMPR11("DESCRIPTION"))=""
SET RMPRERR=3
GOTO CHKDX
+7 IF '$DATA(^RMPR(661.11,"XSD",RMPR11("STATION"),RMPR11("DESCRIPTION"),RMPR11("HCPCS")))
Begin DoDot:1
+8 SET RMPRERR=4
+9 SET RMPRD=RMPR11("DESCRIPTION")
+10 SET RMPRD=$ORDER(^RMPR(661.11,"XSD",RMPR11("STATION"),RMPRD))
+11 IF $EXTRACT(RMPRD,1,$LENGTH(RMPR11("DESCRIPTION")))=RMPR11("DESCRIPTION")
SET RMPRERR=5
+12 QUIT
End DoDot:1
GOTO CHKDX
+13 SET RMPR11("IEN")=$ORDER(^RMPR(661.11,"XSD",RMPR11("STATION"),RMPR11("DESCRIPTION"),RMPR11("HCPCS"),""))
+14 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+15 IF RMPRERR
SET RMPRERR=99
CHKDX QUIT RMPRERR
+1 ;
+2 ; Prompt if adding a new HCPCS Item
OKADD(RMPR11,RMPRYN,RMPREXC) ;
+1 NEW DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT
+2 SET RMPREXC=""
+3 SET DIR(0)="Y"
+4 SET DIR("A")="Are you adding '"_RMPR11("DESCRIPTION")_"' as a new ITEM for this HCPCS"
+5 DO ^DIR
+6 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO ADDNMX
+7 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO ADDNMX
+8 IF X=""!(X["^")
SET RMPREXC="^"
GOTO ADDNMX
+9 SET RMPRYN="N"
if Y
SET RMPRYN="Y"
+10 SET RMPREXC=""
ADDNMX QUIT
+1 ;
+2 ; Single ? Help
QM WRITE ?4,"Answer with ITEM NUMBER or DESCRIPTION:"
+1 DO QM2
+2 QUIT
QQM DO QM2
+1 WRITE !!?8,"You may enter a new ITEM, if you wish"
+2 WRITE !?8,"This is an Item or Appliance under PSAS HCPCS kept by local site in"
+3 WRITE !?8,"Prosthetics Inventory module."
+4 QUIT
QM2 NEW DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRI,RMPRLIN,RMPR,RMPRERR
+1 SET RMPRMAX=19
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 WRITE !?3,RMPRI,?16,RMPR("HCPCS-ITEM"),?28,RMPR("DESCRIPTION")
+8 SET RMPRLIN=RMPRLIN+1
+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
LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11) ;
+1 NEW RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
+2 NEW RMPRERR,RMPRN,RMPRGBL,RMPR,RMPREXMA
+3 SET RMPREXC=""
+4 SET RMPRMAX=19
+5 SET RMPREXMA=""
+6 IF $DATA(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT))
Begin DoDot:1
+7 SET RMPREXMA=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,""))
+8 QUIT
End DoDot:1
+9 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 SET RMPRERR=$$GET^RMPRPIX1(.RMPR)
+10 IF '$DATA(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM")))
GOTO LIKEA
+11 IF RMPREXMA'=""
Begin DoDot:1
+12 SET RMPREXMA("IEN")=RMPREXMA
+13 SET RMPRERR=$$GET^RMPRPIX1(.RMPREXMA)
+14 SET RMPRLIN=RMPRLIN+1
+15 WRITE !?4,$JUSTIFY(RMPRLIN,2),?9,RMPREXMA("DESCRIPTION")
+16 SET RMPRA(RMPRLIN)=RMPREXMA("IEN")
+17 KILL RMPREXMA
+18 SET RMPREXMA=""
+19 QUIT
End DoDot:1
+20 SET RMPRLIN=RMPRLIN+1
+21 WRITE !?4,$JUSTIFY(RMPRLIN,2),?9,$QSUBSCRIPT(RMPRGBL,5)
+22 SET RMPRA(RMPRLIN)=$QSUBSCRIPT(RMPRGBL,6)
+23 IF RMPRLIN'<RMPRMAX
GOTO LIKEB
+24 GOTO LIKEA
LIKEB IF RMPRLIN=0
Begin DoDot:1
+1 if RMPREXMA=""
QUIT
+2 SET RMPR11("IEN")=RMPREXMA
+3 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+4 QUIT
End DoDot:1
GOTO LIKEX
+5 SET DIR(0)="NAO^1:"_RMPRLIN_": "
+6 SET DIR("A")="CHOOSE 1-"_RMPRLIN_": "
+7 DO ^DIR
+8 WRITE !
+9 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LIKEX
+10 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LIKEX
+11 IF X=""
SET RMPREXC=""
GOTO LIKEX
+12 IF X["^"!$DATA(DUOUT)
SET RMPREXC="^"
GOTO LIKEX
+13 KILL RMPR11
+14 SET RMPR11("IEN")=RMPRA(X)
+15 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
LIKEX QUIT
