- 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 Feb 18, 2025@23:43:01 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