source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29LD.m@ 1093

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