source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWIU.m@ 1150

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

initial load of WorldVistAEHR
File size: 3.7 KB
RevLine 
[613]1PRCPWIU ;WISC/RFJ/DGL-update duein (difference between PO and 2237; ; 6/18/01 3:09pm
2 ;;5.1;IFCAP;**34**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7UPDATE ; update dueins (called from PRCH routines);
8 ; da=internal purchase order number
9 N %,ACTDUEIN,CANCFLAG,CONV,D,DATA,DUEIN,ITEMDA,INVPT,LI,OUTST,TRAN,TRANDA,VENDOR
10 N NEWPO
11 I $D(^PRC(442,DA,23)) S NEWPO=$P($G(^PRC(442,DA,23)),"^",4)
12 I $P($G(^PRC(442,DA,7)),"^")=45,NEWPO="" S CANCFLAG=1
13 ; get original duein qty from transactions
14 ; remove due-in if po cancelled (cancflag=1)
15 K ^TMP($J,"PRCP")
16 S TRANDA=0 F S TRANDA=$O(^PRC(442,DA,13,TRANDA)) Q:'TRANDA S INVPT=+$P($G(^(TRANDA,0)),"^",11) I INVPT D
17 . I $D(^TMP($J,"PRCP"))'=10 W !,"...checking on due-ins at inventory point(s)..."
18 . S ^TMP($J,"PRCP","I",TRANDA)=INVPT
19 . S LI=0 F S LI=$O(^PRCS(410,TRANDA,"IT",LI)) Q:'LI S D=$G(^(LI,0)) D
20 . . S ITEMDA=+$P(D,"^",5),OUTST=$G(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0)) I OUTST="" Q
21 . . ; if order is cancelled, remove due-in
22 . . I $G(CANCFLAG) D KILLTRAN^PRCPUTRA(INVPT,ITEMDA,TRANDA) Q
23 . . S CONV=+$P(OUTST,"^",5) S:'CONV CONV=1
24 . . S ^("ORIG")=$G(^TMP($J,"PRCP","D",INVPT,ITEMDA,TRANDA,"ORIG"))+($P(D,"^",2)*CONV)
25 I $G(CANCFLAG) K ^TMP($J,"PRCP") Q
26 ;
27 ; get actual duein quantity from purchase order
28 S VENDOR=+$P($G(^PRC(442,DA,1)),"^"),TRANDA=+$P($G(^PRC(442,DA,0)),"^",12),LI=0
29 F S LI=$O(^PRC(442,DA,2,LI)) Q:'LI S D=$G(^(LI,0)) D
30 . S ITEMDA=+$P(D,"^",5) I 'ITEMDA,$P(D,"^",13)'="" S ITEMDA=+$O(^PRC(441,"BB",$P(D,"^",13),0))
31 . S TRAN=+$P(D,"^",10) S:'TRAN TRAN=TRANDA S INVPT=+$G(^TMP($J,"PRCP","I",TRANDA))
32 . I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
33 . S OUTST=$G(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0))
34 . S DATA=$$GETVEN^PRCPUVEN(INVPT,ITEMDA,VENDOR_";PRC(440,",0),CONV=$P(DATA,"^",4) S:'CONV CONV=+$P(OUTST,"^",5) S:'CONV CONV=1
35 . ; get correct units for outstanding transaction of they exist
36 . S $P(DATA,"^",4)=CONV S:'$P(DATA,"^",3) $P(DATA,"^",3)=$P(OUTST,"^",4) S:'$P(DATA,"^",2) $P(DATA,"^",2)=$P(OUTST,"^",3)
37 . ; if units still do not exist, get them from the po
38 . S:'$P(DATA,"^",2) $P(DATA,"^",2)=$P(D,"^",3) S:'$P(DATA,"^",3) $P(DATA,"^",3)=$P(D,"^",12)
39 . ; find qty previously received
40 . S $P(D,"^",2)=($P(D,"^",2)-$$RECD^PRCPRDI1(DA,LI))\1 S:$P(D,"^",2)<0 $P(D,"^",2)=0
41 . S ^("ACT")=$G(^TMP($J,"PRCP","D",INVPT,ITEMDA,TRANDA,"ACT"))+($P(D,"^",2)*CONV),^("UNITS")=$P(DATA,"^",2,4)
42 ; update current duein qty at inv pt
43 S INVPT=0 F S INVPT=$O(^TMP($J,"PRCP","D",INVPT)) Q:'INVPT S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCP","D",INVPT,ITEMDA)) Q:'ITEMDA S TRANDA=0 F S TRANDA=$O(^TMP($J,"PRCP","D",INVPT,ITEMDA,TRANDA)) Q:'TRANDA D
44 . S ACTDUEIN=+$G(^TMP($J,"PRCP","D",INVPT,ITEMDA,TRANDA,"ACT")),OUTST=$G(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0)),DUEIN=+$P(OUTST,"^",2)
45 . I DUEIN'=0,ACTDUEIN=DUEIN D CHECK Q ;actual and current duein are the same
46 . I ACTDUEIN=0 D KILLTRAN^PRCPUTRA(INVPT,ITEMDA,TRANDA) Q ;actual duein=0, remove transaction,decrement dueins
47 . I ACTDUEIN'=0,OUTST="" D ADDTRAN^PRCPUTRA(INVPT,ITEMDA,TRANDA,ACTDUEIN_"^"_$G(^TMP($J,"PRCP","D",INVPT,ITEMDA,TRANDA,"UNITS"))),CHECK Q ;actual duein and no outstanding transaction
48 . D OUTST^PRCPUTRA(INVPT,ITEMDA,TRANDA,ACTDUEIN-DUEIN),CHECK
49 K ^TMP($J,"PRCP")
50 Q
51 ;
52 ;
53CHECK ; make sure units and data on outstanding transaction is correct
54 S %=$G(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0)),DATA=$G(^TMP($J,"PRCP","D",INVPT,ITEMDA,TRANDA,"UNITS")) I %=""!(DATA="") Q
55 Q:$P(DATA,"^",1,3)=$P(%,"^",3,5) S:+$P(DATA,"^") $P(%,"^",3)=$P(DATA,"^") S:+$P(DATA,"^",2) $P(%,"^",4)=$P(DATA,"^",2) S:+$P(DATA,"^",3) $P(%,"^",5)=$P(DATA,"^",3) S ^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0)=%
56 Q
Note: See TracBrowser for help on using the repository browser.