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

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1RMPR29LD ;HIN/RVD-CANCEL LAB ISSUE FROM STOCK;5/27/1998
2 ;;3.0;PROSTHETICS;**33**;Feb 09, 1996
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4ASK ;get patient to cancel
5 D DIV4^RMPRSIT G:$D(X) EXIT
6 K ^TMP($J),DR,DIC,RMPRDA S REDIT=1
7 S DIC="^RMPR(664.1,",DIC(0)="AEQM",DR=".01"
8 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"
9 D ^DIC K DIC G:+Y'>0 EXIT S RMPRDA=+Y I $G(RMPRDA)'>0 Q
10 L +^RMPR(664.1,RMPRDA,0):1
11 I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
12 S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2)
13 D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT
14 D HOME^%ZIS D GET^RMPR29W(RMPRDA)
15 S (PAGE,MC,LC,TMC,TLC,TSH)=0 D HDR^RMPR29W(RMPRDA) S RI=$O(RCK(0)),(RJ,RTHD)=0
16ITD D ITM^RMPR293 S RMPRWO=$P(RCK(RI),U,3)
17TCH G:'$D(TECH(RMPRWO))!($O(TECH(RMPRWO,0))'>0) MU S RTCD=$O(TECH(RMPRWO,0))
18 S RTC=$O(TECH(RMPRWO,RTCD,664.33,0)) I RTC D TDSP^RMPR293 G TCH
19MU I $D(TMP(RMPRWO,664.22)) S RJ=$O(TMP(RMPRWO,664.22,0)) I RJ D MDSP^RMPR293 G MU
20 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)
21 S RR=1
22EXT S RW=$O(^UTILITY($J,"TEXT",RMPRWO,0)) I RW D WDSP^RMPR293 G EXT
23 W !,RMPR("L")
24 K DIR S DIR(0)="Y",DIR("A")="Would you like to CANCEL this Entry",DIR("B")="NO"
25 D ^DIR G:$D(DTOUT)!($D(DUOUT)) EXIT G:Y=0!(Y<0) EXIT
26 F RL=0:0 S RL=$O(^RMPR(664.1,RMPRDA,2,RL)) Q:RL'>0 Q:$G(RMEXIT) D DEL
27 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..."
28 H 2 G EXIT
29 ;
30GIP ;
31 S PRCP("QTY")=RMQTY,PRCP("ITEM")=$P($G(^RMPR(661,RMITEM,0)),U,1),PRCP("I")=RMGIP D ^PRCPUSA
32 I $D(PRCP("ITEM")) W !,"Error encountered while posting to GIP.",!,"CANCEL ABORTED!!!" S RMEXIT=1 Q
33 S RMITEMS=$P(^PRC(441,$P($G(^RMPR(661,RMITEM,0)),U,1),0),U,2)
34 W !,"Item: ",RMITEMS
35 W !,"Quantity: ",RMQTY," Returned to GIP!!!"
36 Q
37LOC ;
38 I $D(RMIT),RMIT="" W !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!" Q
39 S RMITEMS=$P($G(^RMPR(661.1,RMHS,3,$P(RMIT,"-",2),0)),U,1)
40 W !!,"Item: ",RMITEMS
41 W !,"Quantity: ",RMQTY," Returned to Prosthetics Inventory!!!"
42 D STAT ;updates the Prosthetics Inventory statistics
43 Q
44 ;
45DEL ;delete status 2529-3
46 ;delete entry in the 2319 record and mark entry in 664.1 as deleted
47 S RM2=$G(^RMPR(664.1,RMPRDA,2,RL,0)),RMTYPS=$P(RM2,U,7)
48 S RMQTY=$P(RM2,U,2),RM660=$P(RM2,U,5)
49 S RMUNCO=$P(RM2,U,4),RMITEM=$P(RM2,U,1),RMGIP=$P(RM2,U,13)
50 S RM23=$G(^RMPR(664.1,RMPRDA,2,RL,3))
51 S (RMDAHC,RMHS)=$P($G(^RMPR(664.1,RMPRDA,2,RL,2)),U,1)
52 S RMSO=$P(RM23,U,1),RMLOC=$P(RM23,U,4),RMIT=$P(RM23,U,3)
53 D:$G(RMLOC) LOC D:$G(RMGIP) GIP
54 Q:$G(RMEXIT)
55 S DA=$P(^RMPR(664.1,RMPRDA,2,RL,0),U,5) Q:DA=""
56 S DIK="^RMPR(660," D ^DIK
57 W !,"Patient 2319 has been deleted" K DA,DIK
58 Q
59 ;
60STAT ;
61 S:$D(^RMPR(661.3,RMLOC)) RMHCDA=$O(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))
62 I '$G(RMHCDA) W !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!" Q
63 S:$D(^RMPR(661.3,RMLOC,1,RMHCDA)) RMITDA=$O(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))
64 I '$G(RMITDA) W !,"UNABLE TO LOCATE INVENTORY LOCATION",!,"Adjust Item balance manually!!" Q
65 S RBAL=0 D
66 .S RMBA=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2),RBAL=RMBA+RMQTY
67 .S RAV=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,10),RAVA=$G(RAV)*(-1)
68 .S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RBAL
69 .S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,12)=RMQTY
70 D BAL^RMPR5NU1
71 S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
72 D FILE^DICN K DLAYGO S RMCOM="Returned from LAB STOCK ISSUE"
73 S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMHS_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^"_RMQTY_"^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_RAVA
74 S DA=+Y,DIK=DIC D IX1^DIK
75 W !,"****Current Balance @ Location ",$P(^RMPR(661.3,RMLOC,0),U,1)," is now: ",RMTOBA
76 Q
77 ;
78EXIT ;COMMON EXIT POINT
79 N RMPRSITE,RMPR D KILL^XUSCLEAN
80 K ^UTILITY($J)
81 Q
Note: See TracBrowser for help on using the repository browser.