Routine: RMPRPIYD

RMPRPIYD ;HINES OIFO/ODJ - PIP RECONCILE - Pick HCPCS Item;3/8/01

 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996

 ; 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

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."

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  Mar 13, 2025@21:41:55                                                                                                                                                                                                    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

RMPRPIYD.m