RMPR29LD ;HIN/RVD-CANCEL LAB ISSUE FROM STOCK;5/27/1998
;;3.0;PROSTHETICS;**33**;Feb 09, 1996
;Per VHA Directive 10-93-142, this routine should not be modified.
ASK ;get patient to cancel
D DIV4^RMPRSIT G:$D(X) EXIT
K ^TMP($J),DR,DIC,RMPRDA S REDIT=1
S DIC="^RMPR(664.1,",DIC(0)="AEQM",DR=".01"
S DIC("S")="S RCHECK=$O(^RMPR(664.1,+Y,2,0)) I $P(^RMPR(664.1,+Y,0),U,17)=""C"",$D(^RMPR(664.1,+Y,2,RCHECK,3))",DIC("W")="D EN3^RMPRD1"
D ^DIC K DIC G:+Y'>0 EXIT S RMPRDA=+Y I $G(RMPRDA)'>0 Q
L +^RMPR(664.1,RMPRDA,0):1
I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2)
D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT
D HOME^%ZIS D GET^RMPR29W(RMPRDA)
S (PAGE,MC,LC,TMC,TLC,TSH)=0 D HDR^RMPR29W(RMPRDA) S RI=$O(RCK(0)),(RJ,RTHD)=0
ITD D ITM^RMPR293 S RMPRWO=$P(RCK(RI),U,3)
TCH G:'$D(TECH(RMPRWO))!($O(TECH(RMPRWO,0))'>0) MU S RTCD=$O(TECH(RMPRWO,0))
S RTC=$O(TECH(RMPRWO,RTCD,664.33,0)) I RTC D TDSP^RMPR293 G TCH
MU I $D(TMP(RMPRWO,664.22)) S RJ=$O(TMP(RMPRWO,664.22,0)) I RJ D MDSP^RMPR293 G MU
S SCH=^UTILITY("DIQ1",$J,664.2,RMPRWO,4,"E") I +SCH S:^UTILITY("DIQ1",$J,664.2,RMPRWO,5,"E") SCH=^("E") S TSH=TSH+SCH W !,?37,"SHIPPING CHARGE: ",?70,$J(SCH,10,2)
S RR=1
EXT S RW=$O(^UTILITY($J,"TEXT",RMPRWO,0)) I RW D WDSP^RMPR293 G EXT
W !,RMPR("L")
K DIR S DIR(0)="Y",DIR("A")="Would you like to CANCEL this Entry",DIR("B")="NO"
D ^DIR G:$D(DTOUT)!($D(DUOUT)) EXIT G:Y=0!(Y<0) EXIT
F RL=0:0 S RL=$O(^RMPR(664.1,RMPRDA,2,RL)) Q:RL'>0 Q:$G(RMEXIT) D DEL
I $P(^RMPR(664.1,RMPRDA,0),U,13)'="",'$D(RMEXIT) S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""D""" D ^DIE W !,$C(7),"Marked 2529-3 As Deleted..."
H 2 G EXIT
;
GIP ;
S PRCP("QTY")=RMQTY,PRCP("ITEM")=$P($G(^RMPR(661,RMITEM,0)),U,1),PRCP("I")=RMGIP D ^PRCPUSA
I $D(PRCP("ITEM")) W !,"Error encountered while posting to GIP.",!,"CANCEL ABORTED!!!" S RMEXIT=1 Q
S RMITEMS=$P(^PRC(441,$P($G(^RMPR(661,RMITEM,0)),U,1),0),U,2)
W !,"Item: ",RMITEMS
W !,"Quantity: ",RMQTY," Returned to GIP!!!"
Q
LOC ;
I $D(RMIT),RMIT="" W !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!" Q
S RMITEMS=$P($G(^RMPR(661.1,RMHS,3,$P(RMIT,"-",2),0)),U,1)
W !!,"Item: ",RMITEMS
W !,"Quantity: ",RMQTY," Returned to Prosthetics Inventory!!!"
D STAT ;updates the Prosthetics Inventory statistics
Q
;
DEL ;delete status 2529-3
;delete entry in the 2319 record and mark entry in 664.1 as deleted
S RM2=$G(^RMPR(664.1,RMPRDA,2,RL,0)),RMTYPS=$P(RM2,U,7)
S RMQTY=$P(RM2,U,2),RM660=$P(RM2,U,5)
S RMUNCO=$P(RM2,U,4),RMITEM=$P(RM2,U,1),RMGIP=$P(RM2,U,13)
S RM23=$G(^RMPR(664.1,RMPRDA,2,RL,3))
S (RMDAHC,RMHS)=$P($G(^RMPR(664.1,RMPRDA,2,RL,2)),U,1)
S RMSO=$P(RM23,U,1),RMLOC=$P(RM23,U,4),RMIT=$P(RM23,U,3)
D:$G(RMLOC) LOC D:$G(RMGIP) GIP
Q:$G(RMEXIT)
S DA=$P(^RMPR(664.1,RMPRDA,2,RL,0),U,5) Q:DA=""
S DIK="^RMPR(660," D ^DIK
W !,"Patient 2319 has been deleted" K DA,DIK
Q
;
STAT ;
S:$D(^RMPR(661.3,RMLOC)) RMHCDA=$O(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))
I '$G(RMHCDA) W !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!" Q
S:$D(^RMPR(661.3,RMLOC,1,RMHCDA)) RMITDA=$O(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))
I '$G(RMITDA) W !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!" Q
S RBAL=0 D
.S RMBA=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2),RBAL=RMBA+RMQTY
.S RAV=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,10),RAVA=$G(RAV)*(-1)
.S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RBAL
.S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,12)=RMQTY
D BAL^RMPR5NU1
S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
D FILE^DICN K DLAYGO S RMCOM="Returned from LAB STOCK ISSUE"
S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMHS_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^"_RMQTY_"^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_RAVA
S DA=+Y,DIK=DIC D IX1^DIK
W !,"****Current Balance @ Location ",$P(^RMPR(661.3,RMLOC,0),U,1)," is now: ",RMTOBA
Q
;
EXIT ;COMMON EXIT POINT
N RMPRSITE,RMPR D KILL^XUSCLEAN
K ^UTILITY($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29LD 4110 printed Dec 13, 2024@02:32:17 Page 2
RMPR29LD ;HIN/RVD-CANCEL LAB ISSUE FROM STOCK;5/27/1998
+1 ;;3.0;PROSTHETICS;**33**;Feb 09, 1996
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
ASK ;get patient to cancel
+1 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+2 KILL ^TMP($JOB),DR,DIC,RMPRDA
SET REDIT=1
+3 SET DIC="^RMPR(664.1,"
SET DIC(0)="AEQM"
SET DR=".01"
+4 SET DIC("S")="S RCHECK=$O(^RMPR(664.1,+Y,2,0)) I $P(^RMPR(664.1,+Y,0),U,17)=""C"",$D(^RMPR(664.1,+Y,2,RCHECK,3))"
SET DIC("W")="D EN3^RMPRD1"
+5 DO ^DIC
KILL DIC
if +Y'>0
GOTO EXIT
SET RMPRDA=+Y
IF $GET(RMPRDA)'>0
QUIT
+6 LOCK +^RMPR(664.1,RMPRDA,0):1
+7 IF '$TEST
WRITE $CHAR(7),!!,?5,"Someone is already editing this entry"
GOTO EXIT
+8 SET RMPRDFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
+9 DO IN5^VADPT
SET VAINDT=$PIECE($GET(VAIP(3)),U)
DO INP^VADPT
+10 DO HOME^%ZIS
DO GET^RMPR29W(RMPRDA)
+11 SET (PAGE,MC,LC,TMC,TLC,TSH)=0
DO HDR^RMPR29W(RMPRDA)
SET RI=$ORDER(RCK(0))
SET (RJ,RTHD)=0
ITD DO ITM^RMPR293
SET RMPRWO=$PIECE(RCK(RI),U,3)
TCH if '$DATA(TECH(RMPRWO))!($ORDER(TECH(RMPRWO,0))'>0)
GOTO MU
SET RTCD=$ORDER(TECH(RMPRWO,0))
+1 SET RTC=$ORDER(TECH(RMPRWO,RTCD,664.33,0))
IF RTC
DO TDSP^RMPR293
GOTO TCH
MU IF $DATA(TMP(RMPRWO,664.22))
SET RJ=$ORDER(TMP(RMPRWO,664.22,0))
IF RJ
DO MDSP^RMPR293
GOTO MU
+1 SET SCH=^UTILITY("DIQ1",$JOB,664.2,RMPRWO,4,"E")
IF +SCH
if ^UTILITY("DIQ1",$JOB,664.2,RMPRWO,5,"E")
SET SCH=^("E")
SET TSH=TSH+SCH
WRITE !,?37,"SHIPPING CHARGE: ",?70,$JUSTIFY(SCH,10,2)
+2 SET RR=1
EXT SET RW=$ORDER(^UTILITY($JOB,"TEXT",RMPRWO,0))
IF RW
DO WDSP^RMPR293
GOTO EXT
+1 WRITE !,RMPR("L")
+2 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Would you like to CANCEL this Entry"
SET DIR("B")="NO"
+3 DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXIT
if Y=0!(Y<0)
GOTO EXIT
+4 FOR RL=0:0
SET RL=$ORDER(^RMPR(664.1,RMPRDA,2,RL))
if RL'>0
QUIT
if $GET(RMEXIT)
QUIT
DO DEL
+5 IF $PIECE(^RMPR(664.1,RMPRDA,0),U,13)'=""
IF '$DATA(RMEXIT)
SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="16///^S X=""D"""
DO ^DIE
WRITE !,$CHAR(7),"Marked 2529-3 As Deleted..."
+6 HANG 2
GOTO EXIT
+7 ;
GIP ;
+1 SET PRCP("QTY")=RMQTY
SET PRCP("ITEM")=$PIECE($GET(^RMPR(661,RMITEM,0)),U,1)
SET PRCP("I")=RMGIP
DO ^PRCPUSA
+2 IF $DATA(PRCP("ITEM"))
WRITE !,"Error encountered while posting to GIP.",!,"CANCEL ABORTED!!!"
SET RMEXIT=1
QUIT
+3 SET RMITEMS=$PIECE(^PRC(441,$PIECE($GET(^RMPR(661,RMITEM,0)),U,1),0),U,2)
+4 WRITE !,"Item: ",RMITEMS
+5 WRITE !,"Quantity: ",RMQTY," Returned to GIP!!!"
+6 QUIT
LOC ;
+1 IF $DATA(RMIT)
IF RMIT=""
WRITE !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!"
QUIT
+2 SET RMITEMS=$PIECE($GET(^RMPR(661.1,RMHS,3,$PIECE(RMIT,"-",2),0)),U,1)
+3 WRITE !!,"Item: ",RMITEMS
+4 WRITE !,"Quantity: ",RMQTY," Returned to Prosthetics Inventory!!!"
+5 ;updates the Prosthetics Inventory statistics
DO STAT
+6 QUIT
+7 ;
DEL ;delete status 2529-3
+1 ;delete entry in the 2319 record and mark entry in 664.1 as deleted
+2 SET RM2=$GET(^RMPR(664.1,RMPRDA,2,RL,0))
SET RMTYPS=$PIECE(RM2,U,7)
+3 SET RMQTY=$PIECE(RM2,U,2)
SET RM660=$PIECE(RM2,U,5)
+4 SET RMUNCO=$PIECE(RM2,U,4)
SET RMITEM=$PIECE(RM2,U,1)
SET RMGIP=$PIECE(RM2,U,13)
+5 SET RM23=$GET(^RMPR(664.1,RMPRDA,2,RL,3))
+6 SET (RMDAHC,RMHS)=$PIECE($GET(^RMPR(664.1,RMPRDA,2,RL,2)),U,1)
+7 SET RMSO=$PIECE(RM23,U,1)
SET RMLOC=$PIECE(RM23,U,4)
SET RMIT=$PIECE(RM23,U,3)
+8 if $GET(RMLOC)
DO LOC
if $GET(RMGIP)
DO GIP
+9 if $GET(RMEXIT)
QUIT
+10 SET DA=$PIECE(^RMPR(664.1,RMPRDA,2,RL,0),U,5)
if DA=""
QUIT
+11 SET DIK="^RMPR(660,"
DO ^DIK
+12 WRITE !,"Patient 2319 has been deleted"
KILL DA,DIK
+13 QUIT
+14 ;
STAT ;
+1 if $DATA(^RMPR(661.3,RMLOC))
SET RMHCDA=$ORDER(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))
+2 IF '$GET(RMHCDA)
WRITE !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!"
QUIT
+3 if $DATA(^RMPR(661.3,RMLOC,1,RMHCDA))
SET RMITDA=$ORDER(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))
+4 IF '$GET(RMITDA)
WRITE !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!"
QUIT
+5 SET RBAL=0
Begin DoDot:1
+6 SET RMBA=$PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)
SET RBAL=RMBA+RMQTY
+7 SET RAV=$PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,10)
SET RAVA=$GET(RAV)*(-1)
+8 SET $PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RBAL
+9 SET $PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,12)=RMQTY
End DoDot:1
+10 DO BAL^RMPR5NU1
+11 SET X=DT
SET DIC(0)="AEQL"
SET DLAYGO=661.2
SET DIC="^RMPR(661.2,"
KILL DD,DO
+12 DO FILE^DICN
KILL DLAYGO
SET RMCOM="Returned from LAB STOCK ISSUE"
+13 SET ^RMPR(661.2,+Y,0)=DT_"^^^"_RMHS_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^"_RMQTY_"^"_RMTOBA_"^"_RMCOM_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_RAVA
+14 SET DA=+Y
SET DIK=DIC
DO IX1^DIK
+15 WRITE !,"****Current Balance @ Location ",$PIECE(^RMPR(661.3,RMLOC,0),U,1)," is now: ",RMTOBA
+16 QUIT
+17 ;
EXIT ;COMMON EXIT POINT
+1 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+2 KILL ^UTILITY($JOB)
+3 QUIT
