PRCPWIU ;WISC/RFJ/DGL-update duein (difference between PO and 2237; ; 6/18/01 3:09pm
;;5.1;IFCAP;**34**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
UPDATE ; update dueins (called from PRCH routines);
; da=internal purchase order number
N %,ACTDUEIN,CANCFLAG,CONV,D,DATA,DUEIN,ITEMDA,INVPT,LI,OUTST,TRAN,TRANDA,VENDOR
N NEWPO
I $D(^PRC(442,DA,23)) S NEWPO=$P($G(^PRC(442,DA,23)),"^",4)
I $P($G(^PRC(442,DA,7)),"^")=45,NEWPO="" S CANCFLAG=1
; get original duein qty from transactions
; remove due-in if po cancelled (cancflag=1)
K ^TMP($J,"PRCP")
S TRANDA=0 F S TRANDA=$O(^PRC(442,DA,13,TRANDA)) Q:'TRANDA S INVPT=+$P($G(^(TRANDA,0)),"^",11) I INVPT D
. I $D(^TMP($J,"PRCP"))'=10 W !,"...checking on due-ins at inventory point(s)..."
. S ^TMP($J,"PRCP","I",TRANDA)=INVPT
. S LI=0 F S LI=$O(^PRCS(410,TRANDA,"IT",LI)) Q:'LI S D=$G(^(LI,0)) D
. . S ITEMDA=+$P(D,"^",5),OUTST=$G(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0)) I OUTST="" Q
. . ; if order is cancelled, remove due-in
. . I $G(CANCFLAG) D KILLTRAN^PRCPUTRA(INVPT,ITEMDA,TRANDA) Q
. . S CONV=+$P(OUTST,"^",5) S:'CONV CONV=1
. . S ^("ORIG")=$G(^TMP($J,"PRCP","D",INVPT,ITEMDA,TRANDA,"ORIG"))+($P(D,"^",2)*CONV)
I $G(CANCFLAG) K ^TMP($J,"PRCP") Q
;
; get actual duein quantity from purchase order
S VENDOR=+$P($G(^PRC(442,DA,1)),"^"),TRANDA=+$P($G(^PRC(442,DA,0)),"^",12),LI=0
F S LI=$O(^PRC(442,DA,2,LI)) Q:'LI S D=$G(^(LI,0)) D
. S ITEMDA=+$P(D,"^",5) I 'ITEMDA,$P(D,"^",13)'="" S ITEMDA=+$O(^PRC(441,"BB",$P(D,"^",13),0))
. S TRAN=+$P(D,"^",10) S:'TRAN TRAN=TRANDA S INVPT=+$G(^TMP($J,"PRCP","I",TRANDA))
. I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
. S OUTST=$G(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0))
. S DATA=$$GETVEN^PRCPUVEN(INVPT,ITEMDA,VENDOR_";PRC(440,",0),CONV=$P(DATA,"^",4) S:'CONV CONV=+$P(OUTST,"^",5) S:'CONV CONV=1
. ; get correct units for outstanding transaction of they exist
. 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)
. ; if units still do not exist, get them from the po
. S:'$P(DATA,"^",2) $P(DATA,"^",2)=$P(D,"^",3) S:'$P(DATA,"^",3) $P(DATA,"^",3)=$P(D,"^",12)
. ; find qty previously received
. S $P(D,"^",2)=($P(D,"^",2)-$$RECD^PRCPRDI1(DA,LI))\1 S:$P(D,"^",2)<0 $P(D,"^",2)=0
. S ^("ACT")=$G(^TMP($J,"PRCP","D",INVPT,ITEMDA,TRANDA,"ACT"))+($P(D,"^",2)*CONV),^("UNITS")=$P(DATA,"^",2,4)
; update current duein qty at inv pt
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
. 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)
. I DUEIN'=0,ACTDUEIN=DUEIN D CHECK Q ;actual and current duein are the same
. I ACTDUEIN=0 D KILLTRAN^PRCPUTRA(INVPT,ITEMDA,TRANDA) Q ;actual duein=0, remove transaction,decrement dueins
. 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
. D OUTST^PRCPUTRA(INVPT,ITEMDA,TRANDA,ACTDUEIN-DUEIN),CHECK
K ^TMP($J,"PRCP")
Q
;
;
CHECK ; make sure units and data on outstanding transaction is correct
S %=$G(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0)),DATA=$G(^TMP($J,"PRCP","D",INVPT,ITEMDA,TRANDA,"UNITS")) I %=""!(DATA="") Q
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)=%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWIU 3803 printed Sep 23, 2025@19:52:42 Page 2
PRCPWIU ;WISC/RFJ/DGL-update duein (difference between PO and 2237; ; 6/18/01 3:09pm
+1 ;;5.1;IFCAP;**34**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
UPDATE ; update dueins (called from PRCH routines);
+1 ; da=internal purchase order number
+2 NEW %,ACTDUEIN,CANCFLAG,CONV,D,DATA,DUEIN,ITEMDA,INVPT,LI,OUTST,TRAN,TRANDA,VENDOR
+3 NEW NEWPO
+4 IF $DATA(^PRC(442,DA,23))
SET NEWPO=$PIECE($GET(^PRC(442,DA,23)),"^",4)
+5 IF $PIECE($GET(^PRC(442,DA,7)),"^")=45
IF NEWPO=""
SET CANCFLAG=1
+6 ; get original duein qty from transactions
+7 ; remove due-in if po cancelled (cancflag=1)
+8 KILL ^TMP($JOB,"PRCP")
+9 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^PRC(442,DA,13,TRANDA))
if 'TRANDA
QUIT
SET INVPT=+$PIECE($GET(^(TRANDA,0)),"^",11)
IF INVPT
Begin DoDot:1
+10 IF $DATA(^TMP($JOB,"PRCP"))'=10
WRITE !,"...checking on due-ins at inventory point(s)..."
+11 SET ^TMP($JOB,"PRCP","I",TRANDA)=INVPT
+12 SET LI=0
FOR
SET LI=$ORDER(^PRCS(410,TRANDA,"IT",LI))
if 'LI
QUIT
SET D=$GET(^(LI,0))
Begin DoDot:2
+13 SET ITEMDA=+$PIECE(D,"^",5)
SET OUTST=$GET(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0))
IF OUTST=""
QUIT
+14 ; if order is cancelled, remove due-in
+15 IF $GET(CANCFLAG)
DO KILLTRAN^PRCPUTRA(INVPT,ITEMDA,TRANDA)
QUIT
+16 SET CONV=+$PIECE(OUTST,"^",5)
if 'CONV
SET CONV=1
+17 SET ^("ORIG")=$GET(^TMP($JOB,"PRCP","D",INVPT,ITEMDA,TRANDA,"ORIG"))+($PIECE(D,"^",2)*CONV)
End DoDot:2
End DoDot:1
+18 IF $GET(CANCFLAG)
KILL ^TMP($JOB,"PRCP")
QUIT
+19 ;
+20 ; get actual duein quantity from purchase order
+21 SET VENDOR=+$PIECE($GET(^PRC(442,DA,1)),"^")
SET TRANDA=+$PIECE($GET(^PRC(442,DA,0)),"^",12)
SET LI=0
+22 FOR
SET LI=$ORDER(^PRC(442,DA,2,LI))
if 'LI
QUIT
SET D=$GET(^(LI,0))
Begin DoDot:1
+23 SET ITEMDA=+$PIECE(D,"^",5)
IF 'ITEMDA
IF $PIECE(D,"^",13)'=""
SET ITEMDA=+$ORDER(^PRC(441,"BB",$PIECE(D,"^",13),0))
+24 SET TRAN=+$PIECE(D,"^",10)
if 'TRAN
SET TRAN=TRANDA
SET INVPT=+$GET(^TMP($JOB,"PRCP","I",TRANDA))
+25 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,0))
QUIT
+26 SET OUTST=$GET(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0))
+27 SET DATA=$$GETVEN^PRCPUVEN(INVPT,ITEMDA,VENDOR_";PRC(440,",0)
SET CONV=$PIECE(DATA,"^",4)
if 'CONV
SET CONV=+$PIECE(OUTST,"^",5)
if 'CONV
SET CONV=1
+28 ; get correct units for outstanding transaction of they exist
+29 SET $PIECE(DATA,"^",4)=CONV
if '$PIECE(DATA,"^",3)
SET $PIECE(DATA,"^",3)=$PIECE(OUTST,"^",4)
if '$PIECE(DATA,"^",2)
SET $PIECE(DATA,"^",2)=$PIECE(OUTST,"^",3)
+30 ; if units still do not exist, get them from the po
+31 if '$PIECE(DATA,"^",2)
SET $PIECE(DATA,"^",2)=$PIECE(D,"^",3)
if '$PIECE(DATA,"^",3)
SET $PIECE(DATA,"^",3)=$PIECE(D,"^",12)
+32 ; find qty previously received
+33 SET $PIECE(D,"^",2)=($PIECE(D,"^",2)-$$RECD^PRCPRDI1(DA,LI))\1
if $PIECE(D,"^",2)<0
SET $PIECE(D,"^",2)=0
+34 SET ^("ACT")=$GET(^TMP($JOB,"PRCP","D",INVPT,ITEMDA,TRANDA,"ACT"))+($PIECE(D,"^",2)*CONV)
SET ^("UNITS")=$PIECE(DATA,"^",2,4)
End DoDot:1
+35 ; update current duein qty at inv pt
+36 SET INVPT=0
FOR
SET INVPT=$ORDER(^TMP($JOB,"PRCP","D",INVPT))
if 'INVPT
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCP","D",INVPT,ITEMDA))
if 'ITEMDA
QUIT
SET TRANDA=0
FOR
SET TRANDA=$ORDER(^TMP($JOB,"PRCP","D",INVPT,ITEMDA,TRANDA))
if 'TRANDA
QUIT
Begin DoDot:1
+37 SET ACTDUEIN=+$GET(^TMP($JOB,"PRCP","D",INVPT,ITEMDA,TRANDA,"ACT"))
SET OUTST=$GET(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0))
SET DUEIN=+$PIECE(OUTST,"^",2)
+38 ;actual and current duein are the same
IF DUEIN'=0
IF ACTDUEIN=DUEIN
DO CHECK
QUIT
+39 ;actual duein=0, remove transaction,decrement dueins
IF ACTDUEIN=0
DO KILLTRAN^PRCPUTRA(INVPT,ITEMDA,TRANDA)
QUIT
+40 ;actual duein and no outstanding transaction
IF ACTDUEIN'=0
IF OUTST=""
DO ADDTRAN^PRCPUTRA(INVPT,ITEMDA,TRANDA,ACTDUEIN_"^"_$GET(^TMP($JOB,"PRCP","D",INVPT,ITEMDA,TRANDA,"UNITS")))
DO CHECK
QUIT
+41 DO OUTST^PRCPUTRA(INVPT,ITEMDA,TRANDA,ACTDUEIN-DUEIN)
DO CHECK
End DoDot:1
+42 KILL ^TMP($JOB,"PRCP")
+43 QUIT
+44 ;
+45 ;
CHECK ; make sure units and data on outstanding transaction is correct
+1 SET %=$GET(^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0))
SET DATA=$GET(^TMP($JOB,"PRCP","D",INVPT,ITEMDA,TRANDA,"UNITS"))
IF %=""!(DATA="")
QUIT
+2 if $PIECE(DATA,"^",1,3)=$PIECE(%,"^",3,5)
QUIT
if +$PIECE(DATA,"^")
SET $PIECE(%,"^",3)=$PIECE(DATA,"^")
if +$PIECE(DATA,"^",2)
SET $PIECE(%,"^",4)=$PIECE(DATA,"^",2)
if +$PIECE(DATA,"^",3)
SET $PIECE(%,"^",5)=$PIECE(DATA,"^",3)
SET ^PRCP(445,INVPT,1,ITEMDA,7,TRANDA,0)=%
+3 QUIT
