RMPRPIYH.m

RMPRPIYH ;HINCIO/ODJ - PIP Stock Receipt Prompts ;3/8/01

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

 Q

 ;

 ;***** LOCNM - Prompt for receiving location

 ;              must be in 661.5 and active

LOCNM(RMPRSTN,RMPR5,RMPREXC) ;

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

 D NOW^%DTC S RMPRTDT=X ;today's date

 S RMPREXC=""

 S RMPRERR=0

 S DIR(0)="FOA"

 S DIR("A")="Enter Receiving Location: "

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

 S DIR("??")="^D QM2^RMPRPIYB"

LOCNM1 D ^DIR

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

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

 I X=""!(X["^") S RMPREXC="^" G LOCNMX

 K RMPR5

 S RMPR5("STATION")=RMPRSTN

 S RMPR5("STATION IEN")=RMPRSTN

 D LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5)

 I RMPREXC'="" G LOCNM1

 I $G(RMPR5("IEN"))="" D  G LOCNM1

 . W !,"Please enter a valid Location"

 . Q

 ;

 ; exit

LOCNMX Q RMPRERR

 ;

 ; Get OK

OK(RMPRYN,RMPREXC) ;

 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT

 S RMPREXC=""

 S DIR("A")="         ...OK"

 S DIR("B")="Yes"

 S DIR(0)="Y"

 D ^DIR

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

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

 I X=""!(X["^") S RMPREXC="^" G OKX

 S RMPRYN="N" S:Y RMPRYN="Y"

OKX Q

 ;

 ;***** HCPCS - Get a HCPCS code from 661.4

HCPCS(RMPR5,RMPR1,RMPREXC) ;

 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN,RMPRLCN,RMPR1N

 S DIR("A")="Select HCPCS to RECEIVE: "

 S RMPRERR=0

 S RMPREXC=""

 S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))

 S RMPRSTN=RMPR5("STATION")

 S RMPRLCN=RMPR5("IEN")

 S DIR(0)="FOA"

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

 S DIR("??")="^D QM2^RMPRPIYC"

HCPCS1 K RMPR1N D ^DIR

 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

 D LIKE^RMPRPIYC(RMPRSTN,RMPRLCN,X,.RMPREXC,.RMPR1N)

 I RMPREXC'="" G HCPCS1

 I $G(RMPR1N("IEN"))'="" G HCPCSU

 G HCPCS1

HCPCSU K RMPR1 M RMPR1=RMPR1N

HCPCSX Q RMPRERR

 ;

 ;***** ITEM - Get an Item - 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 RECEIVE: "

 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(.RMPRYN,.RMPREXC)

 I RMPRYN'="Y" G ITEMA1

 G ITEMX

ITEMX Q RMPRERR

 ;

 ; Get Quantity

QTY(RMPRQTY,RMPREXC) ;

 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA

 S RMPRQTY=$G(RMPRQTY)

 S RMPRERR=0

 S DIR(0)="NA^1:99999:0"

 S DIR("A")="Quantity to Receive: "

 S:RMPRQTY'="" DIR("B")=RMPRQTY

 D ^DIR

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

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

 I X=""!(X["^") S RMPREXC="^" G QTYX

 S RMPRQTY=Y

QTYX Q RMPRERR

 ;

 ; Get total $ value

TVAL(RMPRTVAL,RMPREXC) ;

 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA

 S RMPRTVAL=$G(RMPRTVAL)

 S RMPRERR=0

 S DIR(0)="NOA^0:999999:2"

 S DIR("A")="Total Cost of Item: "

 D ^DIR

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

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

 I X["^" S RMPREXC="^" G TVALX

 I X="" G TVALX

 S RMPRTVAL=Y

TVALX Q RMPRERR

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPRPIYH   3608     printed  Mar 13, 2025@21:41:59                                                                                                                                                                                                    Page 2

RMPRPIYH  ;HINCIO/ODJ - PIP Stock Receipt Prompts ;3/8/01

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

 +2        QUIT 

 +3       ;

 +4       ;***** LOCNM - Prompt for receiving location

 +5       ;              must be in 661.5 and active

LOCNM(RMPRSTN,RMPR5,RMPREXC) ;

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

 +2       ;today's date

           DO NOW^%DTC

           SET RMPRTDT=X

 +3        SET RMPREXC=""

 +4        SET RMPRERR=0

 +5        SET DIR(0)="FOA"

 +6        SET DIR("A")="Enter Receiving Location: "

 +7        SET DIR("?")="^D QM^RMPRPIYB"

 +8        SET DIR("??")="^D QM2^RMPRPIYB"

LOCNM1     DO ^DIR

 +1        IF $DATA(DTOUT)

               SET RMPREXC="T"

               GOTO LOCNMX

 +2        IF $DATA(DIROUT)

               SET RMPREXC="P"

               GOTO LOCNMX

 +3        IF X=""!(X["^")

               SET RMPREXC="^"

               GOTO LOCNMX

 +4        KILL RMPR5

 +5        SET RMPR5("STATION")=RMPRSTN

 +6        SET RMPR5("STATION IEN")=RMPRSTN

 +7        DO LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5)

 +8        IF RMPREXC'=""

               GOTO LOCNM1

 +9        IF $GET(RMPR5("IEN"))=""

               Begin DoDot:1

 +10               WRITE !,"Please enter a valid Location"

 +11               QUIT 

               End DoDot:1

               GOTO LOCNM1

 +12      ;

 +13      ; exit

LOCNMX     QUIT RMPRERR

 +1       ;

 +2       ; Get OK

OK(RMPRYN,RMPREXC) ;

 +1        NEW DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT

 +2        SET RMPREXC=""

 +3        SET DIR("A")="         ...OK"

 +4        SET DIR("B")="Yes"

 +5        SET DIR(0)="Y"

 +6        DO ^DIR

 +7        IF $DATA(DTOUT)

               SET RMPREXC="T"

               GOTO OKX

 +8        IF $DATA(DIROUT)

               SET RMPREXC="P"

               GOTO OKX

 +9        IF X=""!(X["^")

               SET RMPREXC="^"

               GOTO OKX

 +10       SET RMPRYN="N"

           if Y

               SET RMPRYN="Y"

OKX        QUIT 

 +1       ;

 +2       ;***** HCPCS - Get a HCPCS code from 661.4

HCPCS(RMPR5,RMPR1,RMPREXC) ;

 +1        NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN,RMPRLCN,RMPR1N

 +2        SET DIR("A")="Select HCPCS to RECEIVE: "

 +3        SET RMPRERR=0

 +4        SET RMPREXC=""

 +5        SET RMPR1("HCPCS")=$GET(RMPR1("HCPCS"))

 +6        SET RMPRSTN=RMPR5("STATION")

 +7        SET RMPRLCN=RMPR5("IEN")

 +8        SET DIR(0)="FOA"

 +9        SET DIR("?")="^D QM^RMPRPIYC"

 +10       SET DIR("??")="^D QM2^RMPRPIYC"

HCPCS1     KILL RMPR1N

           DO ^DIR

 +1        IF $DATA(DTOUT)

               SET RMPREXC="T"

               GOTO HCPCSX

 +2        IF $DATA(DIROUT)

               SET RMPREXC="P"

               GOTO HCPCSX

 +3        IF X=""!(X["^")!($DATA(DUOUT))

               SET RMPREXC="^"

               GOTO HCPCSX

 +4        DO LIKE^RMPRPIYC(RMPRSTN,RMPRLCN,X,.RMPREXC,.RMPR1N)

 +5        IF RMPREXC'=""

               GOTO HCPCS1

 +6        IF $GET(RMPR1N("IEN"))'=""

               GOTO HCPCSU

 +7        GOTO HCPCS1

HCPCSU     KILL RMPR1

           MERGE RMPR1=RMPR1N

HCPCSX     QUIT RMPRERR

 +1       ;

 +2       ;***** ITEM - Get an Item - 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 RECEIVE: "

 +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(.RMPRYN,.RMPREXC)

 +13       IF RMPRYN'="Y"

               GOTO ITEMA1

 +14       GOTO ITEMX

ITEMX      QUIT RMPRERR

 +1       ;

 +2       ; Get Quantity

QTY(RMPRQTY,RMPREXC) ;

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

 +2        SET RMPRQTY=$GET(RMPRQTY)

 +3        SET RMPRERR=0

 +4        SET DIR(0)="NA^1:99999:0"

 +5        SET DIR("A")="Quantity to Receive: "

 +6        if RMPRQTY'=""

               SET DIR("B")=RMPRQTY

 +7        DO ^DIR

 +8        IF $DATA(DTOUT)

               SET RMPREXC="T"

               GOTO QTYX

 +9        IF $DATA(DIROUT)

               SET RMPREXC="P"

               GOTO QTYX

 +10       IF X=""!(X["^")

               SET RMPREXC="^"

               GOTO QTYX

 +11       SET RMPRQTY=Y

QTYX       QUIT RMPRERR

 +1       ;

 +2       ; Get total $ value

TVAL(RMPRTVAL,RMPREXC) ;

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

 +2        SET RMPRTVAL=$GET(RMPRTVAL)

 +3        SET RMPRERR=0

 +4        SET DIR(0)="NOA^0:999999:2"

 +5        SET DIR("A")="Total Cost of Item: "

 +6        DO ^DIR

 +7        IF $DATA(DTOUT)

               SET RMPREXC="T"

               GOTO TVALX

 +8        IF $DATA(DIROUT)

               SET RMPREXC="P"

               GOTO TVALX

 +9        IF X["^"

               SET RMPREXC="^"

               GOTO TVALX

 +10       IF X=""

               GOTO TVALX

 +11       SET RMPRTVAL=Y

TVALX      QUIT RMPRERR