Routine: RMPRSTE

RMPRSTE ;HINCIO/RVD-ISSUE FROM STOCK / CONT. ;11/06/00

 ;;3.0;PROSTHETICS;**53,62,78**;Feb 09, 1996

 ;modified for cpt modifier

 ;RVD patch #62 - modified for PCE interface.

 ;TH  Patch #78 - Add Date of Service/Shipment Date

 ;Per VHA Directive 10-93-142, this routine should not be modified.

NEX K DIR,Y,X

 S $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7)

 S $P(R3("D"),U,16)=RMPRUCST*$P(R1(0),U,7)

QTY K DIR,Y S DIR(0)="660,5" S:$P(R1(0),U,7) DIR("B")=$P(R1(0),U,7)

 D ^DIR I $P(R1(0),U,7)'=""&$D(DUOUT) G LIST

 I $D(DTOUT) X CK2 G ^RMPRSTI

 I $D(DIRUT) G LOC^RMPRSTI

 I $G(RMUBA),((RMUBA-Y)<0) D LOWBA^RMPRSTI G LOC^RMPRSTI

 S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*RMPRUCST K DIR

 ;SET DELIVERY DATE to today

DATE ;delivery date and date of service/shipment date is set to today's date

 S $P(R1(0),U,12)=DT,$P(R1(1),U,8)=DT,Y=DT D DD^%DT S $P(R3("D"),U,12)=Y

LI S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11)

 D ^DIR I $D(DTOUT) X CK1 Q

 G:$D(DUOUT) LIST

 I X["^" W !,"Jumping not allowed" G LI

 I $P(R1(0),U,11)'=""&(X="@") S $P(R1(0),U,11)="" W $C(7),!?5,"Deleted..." H 1 G LOT

 S $P(R1(0),U,11)=X

LOT ;

 K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24)

 D ^DIR I $D(DTOUT) X CK1 Q

 G:$D(DUOUT) LIST

 I X["^" W !,"Jumping not allowed" G LOT

 I $P(R1(0),U,24)'=""&(X="@") S $P(R1(0),U,24)="" W $C(7),!?5,"Deleted..." H 1 G REMA

 S $P(R1(0),U,24)=X

REMA ;

 K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18)

 D ^DIR I $D(DTOUT) X CK1 Q

 G:$D(DUOUT) LIST

 I X["^" W !,"Jumping not allowed" G REMA

 I $P(R1(0),U,18)'=""&(X="@") S $P(R1(0),U,18)="" W $C(7),!?5,"Deleted..." H 1 G LIST

 S $P(R1(0),U,18)=X

LIST ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA

 S RMDAHC=$P(R1(1),U,4)

 D NODE2^RMPRSTI

 D:$D(RMCPT) CHK^RMPRED5

 D ^RMPRST2

 K DIR,RQUIT

 S DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"

 S DIR("A")="Would you like to POST/EDIT/DELETE this entry"

 S DIR("B")="P"

 S DIR("?")="Answer `P` to post the transaction, `E` to edit the transaction,'D' to delete the transaction"

 D ^DIR K DIR G:Y="P" POST G:Y="D" DEA

 I Y="E" S REDIT=1 G 1^RMPRSTI

 I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) G ^RMPRSTI

DEA ;

 K DIR

 S DIR("A")="Are you sure you want to DELETE this entry"

 S DIR("B")="N",DIR(0)="Y"

 D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) X CK Q

 I Y=1 W !!,$C(7),?50," Deleted..." H 2 K DIR G RES^RMPRSTI

 G LIST

POST ;

 I RMPRG'="" G GGC

 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC

 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1

 S $P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)

GGC S $P(RMPRI("AMS"),U,1)=RMPRG,RMSER=$P(R1(0),U,11)

 ;update inventory balance

 I $G(RMLOC) S RMQTY=$P(R1(0),U,7) D ADD^RMPR5NU1 I $D(RQUIT) X CK Q

 I '$D(RMLOC) X CK Q

 S:$D(RMLOC) $P(R1(1),U,2)=RDESC,$P(R1(0),U,13)=11,$P(R1(1),U,5)=RM6612

 ;create 2319

 K Y,DD,DO,DA S DIC="^RMPR(660,",DIC(0)="L",X=DT,DLAYGO=660

 D FILE^DICN K DLAYGO

 I Y'>0 W !,"** Error posting to 2319...entry deleted..." G RES^RMPRSTI

 S ^RMPR(660,+Y,0)=R1(0),^(1)=R1(1),^("AM")=R1("AM"),^(2)=R1(2)

 S $P(R1(1),U,8)=DT

 S ^("AMS")=RMPRI("AMS")

 I $D(RMLOC) MERGE ^RMPR(660,+Y,"DES")=^RMPR(661.1,RMDAHC,2) S $P(^RMPR(660,+Y,"DES",0),U,2)=""

 S DIK="^RMPR(660,",(RM60,DA)=+Y D IX1^DIK K DIC

 S ^TMP($J,"RMPRPCE",660,DA)=RMPRG_"^"_$G(RMPRDFN)

 W !,"Posted to 2319..." H 3

 G RES^RMPRSTI

EXIT ;EXIT FOR STOCK ISSUES

 K ^TMP($J)

 N RMPRSITE,RMPR D KILL^XUSCLEAN

ERR0 ;delete entry & print error message if posting fails.

 ;K DIK

 ;S DIK="^RMPR(660,",DA=RM60 D ^DIK

 ;W !,"** Error posting to 2319...entry deleted...",!! H 3

;Q

INV1 I $P(R1(0),U,14)="C" S $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7)

 G QTY

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSTE   3791     printed  Apr 23, 2025@18:52:22                                                                                                                                                                                                     Page 2

RMPRSTE   ;HINCIO/RVD-ISSUE FROM STOCK / CONT. ;11/06/00

 +1       ;;3.0;PROSTHETICS;**53,62,78**;Feb 09, 1996

 +2       ;modified for cpt modifier

 +3       ;RVD patch #62 - modified for PCE interface.

 +4       ;TH  Patch #78 - Add Date of Service/Shipment Date

 +5       ;Per VHA Directive 10-93-142, this routine should not be modified.

NEX        KILL DIR,Y,X

 +1        SET $PIECE(R1(0),U,16)=RMPRUCST*$PIECE(R1(0),U,7)

 +2        SET $PIECE(R3("D"),U,16)=RMPRUCST*$PIECE(R1(0),U,7)

QTY        KILL DIR,Y

           SET DIR(0)="660,5"

           if $PIECE(R1(0),U,7)

               SET DIR("B")=$PIECE(R1(0),U,7)

 +1        DO ^DIR

           IF $PIECE(R1(0),U,7)'=""&$DATA(DUOUT)

               GOTO LIST

 +2        IF $DATA(DTOUT)

               XECUTE CK2

               GOTO ^RMPRSTI

 +3        IF $DATA(DIRUT)

               GOTO LOC^RMPRSTI

 +4        IF $GET(RMUBA)

               IF ((RMUBA-Y)<0)

                   DO LOWBA^RMPRSTI

                   GOTO LOC^RMPRSTI

 +5        SET $PIECE(R1(0),U,7)=Y

           SET $PIECE(R1(0),U,16)=Y*RMPRUCST

           KILL DIR

 +6       ;SET DELIVERY DATE to today

 +7       ;

DATE      ;delivery date and date of service/shipment date is set to today's date

 +1        SET $PIECE(R1(0),U,12)=DT

           SET $PIECE(R1(1),U,8)=DT

           SET Y=DT

           DO DD^%DT

           SET $PIECE(R3("D"),U,12)=Y

LI         SET DIR(0)="660,9"

           if $PIECE(R1(0),U,11)'=""

               SET DIR("B")=$PIECE(R1(0),U,11)

 +1        DO ^DIR

           IF $DATA(DTOUT)

               XECUTE CK1

               QUIT

 +2        if $DATA(DUOUT)

               GOTO LIST

 +3        IF X["^"

               WRITE !,"Jumping not allowed"

               GOTO LI

 +4        IF $PIECE(R1(0),U,11)'=""&(X="@")

               SET $PIECE(R1(0),U,11)=""

               WRITE $CHAR(7),!?5,"Deleted..."

               HANG 1

               GOTO LOT

 +5        SET $PIECE(R1(0),U,11)=X

 +6       ;

LOT       ;

 +1       ;

 +2        KILL DIR

           SET DIR(0)="660,21"

           if $PIECE(R1(0),U,24)'=""

               SET DIR("B")=$PIECE(R1(0),U,24)

 +3        DO ^DIR

           IF $DATA(DTOUT)

               XECUTE CK1

               QUIT

 +4        if $DATA(DUOUT)

               GOTO LIST

 +5        IF X["^"

               WRITE !,"Jumping not allowed"

               GOTO LOT

 +6        IF $PIECE(R1(0),U,24)'=""&(X="@")

               SET $PIECE(R1(0),U,24)=""

               WRITE $CHAR(7),!?5,"Deleted..."

               HANG 1

               GOTO REMA

 +7        SET $PIECE(R1(0),U,24)=X

 +8       ;

REMA      ;

 +1       ;

 +2        KILL DIR

           SET DIR(0)="660,16"

           if $PIECE(R1(0),U,18)'=""

               SET DIR("B")=$PIECE(R1(0),U,18)

 +3        DO ^DIR

           IF $DATA(DTOUT)

               XECUTE CK1

               QUIT

 +4        if $DATA(DUOUT)

               GOTO LIST

 +5        IF X["^"

               WRITE !,"Jumping not allowed"

               GOTO REMA

 +6        IF $PIECE(R1(0),U,18)'=""&(X="@")

               SET $PIECE(R1(0),U,18)=""

               WRITE $CHAR(7),!?5,"Deleted..."

               HANG 1

               GOTO LIST

 +7        SET $PIECE(R1(0),U,18)=X

 +8       ;

LIST      ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA

 +1        SET RMDAHC=$PIECE(R1(1),U,4)

 +2        DO NODE2^RMPRSTI

 +3        if $DATA(RMCPT)

               DO CHK^RMPRED5

 +4        DO ^RMPRST2

 +5        KILL DIR,RQUIT

 +6        SET DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"

 +7        SET DIR("A")="Would you like to POST/EDIT/DELETE this entry"

 +8        SET DIR("B")="P"

 +9        SET DIR("?")="Answer `P` to post the transaction, `E` to edit the transaction,'D' to delete the transaction"

 +10       DO ^DIR

           KILL DIR

           if Y="P"

               GOTO POST

           if Y="D"

               GOTO DEA

 +11       IF Y="E"

               SET REDIT=1

               GOTO 1^RMPRSTI

 +12       IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)

               GOTO ^RMPRSTI

 +13      ;

DEA       ;

 +1        KILL DIR

 +2        SET DIR("A")="Are you sure you want to DELETE this entry"

 +3        SET DIR("B")="N"

           SET DIR(0)="Y"

 +4        DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)

               XECUTE CK

               QUIT

 +5        IF Y=1

               WRITE !!,$CHAR(7),?50," Deleted..."

               HANG 2

               KILL DIR

               GOTO RES^RMPRSTI

 +6        GOTO LIST

 +7       ;

POST      ;

 +1       ;

 +2        IF RMPRG'=""

               GOTO GGC

 +3        LOCK +^RMPR(669.9,RMPRSITE,0):999

           IF $TEST=0

               SET RMPRG=DT_99

               GOTO GGC

 +4        SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)

           SET RMPRG=RMPRG-1

 +5        SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG

           LOCK -^RMPR(669.9,RMPRSITE,0)

GGC        SET $PIECE(RMPRI("AMS"),U,1)=RMPRG

           SET RMSER=$PIECE(R1(0),U,11)

 +1       ;update inventory balance

 +2        IF $GET(RMLOC)

               SET RMQTY=$PIECE(R1(0),U,7)

               DO ADD^RMPR5NU1

               IF $DATA(RQUIT)

                   XECUTE CK

                   QUIT

 +3        IF '$DATA(RMLOC)

               XECUTE CK

               QUIT

 +4        if $DATA(RMLOC)

               SET $PIECE(R1(1),U,2)=RDESC

               SET $PIECE(R1(0),U,13)=11

               SET $PIECE(R1(1),U,5)=RM6612

 +5       ;

 +6       ;create 2319

 +7        KILL Y,DD,DO,DA

           SET DIC="^RMPR(660,"

           SET DIC(0)="L"

           SET X=DT

           SET DLAYGO=660

 +8        DO FILE^DICN

           KILL DLAYGO

 +9        IF Y'>0

               WRITE !,"** Error posting to 2319...entry deleted..."

               GOTO RES^RMPRSTI

 +10       SET ^RMPR(660,+Y,0)=R1(0)

           SET ^(1)=R1(1)

           SET ^("AM")=R1("AM")

           SET ^(2)=R1(2)

 +11       SET $PIECE(R1(1),U,8)=DT

 +12       SET ^("AMS")=RMPRI("AMS")

 +13       IF $DATA(RMLOC)

               MERGE ^RMPR(660,+Y,"DES")=^RMPR(661.1,RMDAHC,2)

               SET $PIECE(^RMPR(660,+Y,"DES",0),U,2)=""

 +14       SET DIK="^RMPR(660,"

           SET (RM60,DA)=+Y

           DO IX1^DIK

           KILL DIC

 +15       SET ^TMP($JOB,"RMPRPCE",660,DA)=RMPRG_"^"_$GET(RMPRDFN)

 +16      ;

 +17       WRITE !,"Posted to 2319..."

           HANG 3

 +18       GOTO RES^RMPRSTI

 +19      ;

EXIT      ;EXIT FOR STOCK ISSUES

 +1        KILL ^TMP($JOB)

 +2        NEW RMPRSITE,RMPR

           DO KILL^XUSCLEAN

 +3        QUIT

 +4       ;

ERR0      ;delete entry & print error message if posting fails.

 +1       ;K DIK

 +2       ;S DIK="^RMPR(660,",DA=RM60 D ^DIK

 +3       ;W !,"** Error posting to 2319...entry deleted...",!! H 3

 +4       ;Q

 +5       ;

 +6       ;

INV1       IF $PIECE(R1(0),U,14)="C"

               SET $PIECE(R1(0),U,16)=RMPRUCST*$PIECE(R1(0),U,7)

 +1        GOTO QTY

RMPRSTE.m