RMPRPIYX.m

RMPRPIYX ;HINCIO/ODJ - PIP Data Entry - HCPCS Item;3/8/01

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

 Q

 ;

 ;***** Prompt for HCPCS Item - called by Transfer option

 ;      restrict choice to Location and HCPC

ITEM(RMPRSTN,RMPRLCN,RMPRHCPC,RMPR11,RMPR4,RMPREXC) ;

 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRYN

 S RMPRERR=0

 S RMPREXC=""

 I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX

 I $G(RMPRLCN)="" S RMPRERR=2 G ITEMX

 I $G(RMPRHCPC)="" S RMPRERR=3 G ITEMX

 K RMPR11,RMPR4

 S DIR(0)="FOA^1:50"

 S DIR("A")="Enter Item to transfer: "

 S DIR("?")="^D QM^RMPRPIY8"

 S DIR("??")="^D QQM^RMPRPIY8"

ITEMA1 D ^DIR

 I $D(DTOUT) S RMPREXC="T" G ITEMX

 I $D(DIROUT) S RMPREXC="P" G ITEMX

 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G ITEMX

 D LIKE^RMPRPIY8(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11,.RMPR4)

 I RMPREXC="T" G ITEMX

 I RMPREXC="P" G ITEMX

 I RMPREXC="^" G ITEMA1

 I RMPR4("IEN")="" D  G ITEMA1

 . W !,"Cannot locate ITEM with this sequence NUMBER"

 . Q

 W "  ",RMPR11("HCPCS-ITEM"),"  ",RMPR11("DESCRIPTION")

 D OK^RMPRPIY7(.RMPRYN,.RMPREXC)

 I RMPRYN'="Y" G ITEMA1

 G ITEMX

ITEMX Q RMPRERR

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPRPIYX   1128     printed  Apr 09, 2024@21:33:48                                                                                                                                                                                                    Page 2

RMPRPIYX  ;HINCIO/ODJ - PIP Data Entry - HCPCS Item;3/8/01

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

 +2        QUIT 

 +3       ;

 +4       ;***** Prompt for HCPCS Item - called by Transfer option

 +5       ;      restrict choice to Location and HCPC

ITEM(RMPRSTN,RMPRLCN,RMPRHCPC,RMPR11,RMPR4,RMPREXC) ;

 +1        NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRYN

 +2        SET RMPRERR=0

 +3        SET RMPREXC=""

 +4        IF $GET(RMPRSTN)=""

               SET RMPRERR=1

               GOTO ITEMX

 +5        IF $GET(RMPRLCN)=""

               SET RMPRERR=2

               GOTO ITEMX

 +6        IF $GET(RMPRHCPC)=""

               SET RMPRERR=3

               GOTO ITEMX

 +7        KILL RMPR11,RMPR4

 +8        SET DIR(0)="FOA^1:50"

 +9        SET DIR("A")="Enter Item to transfer: "

 +10       SET DIR("?")="^D QM^RMPRPIY8"

 +11       SET DIR("??")="^D QQM^RMPRPIY8"

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["^")!$DATA(DUOUT)

               SET RMPREXC="^"

               GOTO ITEMX

 +4        DO LIKE^RMPRPIY8(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11,.RMPR4)

 +5        IF RMPREXC="T"

               GOTO ITEMX

 +6        IF RMPREXC="P"

               GOTO ITEMX

 +7        IF RMPREXC="^"

               GOTO ITEMA1

 +8        IF RMPR4("IEN")=""

               Begin DoDot:1

 +9                WRITE !,"Cannot locate ITEM with this sequence NUMBER"

 +10               QUIT 

               End DoDot:1

               GOTO ITEMA1

 +11       WRITE "  ",RMPR11("HCPCS-ITEM"),"  ",RMPR11("DESCRIPTION")

 +12       DO OK^RMPRPIY7(.RMPRYN,.RMPREXC)

 +13       IF RMPRYN'="Y"

               GOTO ITEMA1

 +14       GOTO ITEMX

ITEMX      QUIT RMPRERR