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
Q
;
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 Dec 13, 2024@02:37:52 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
