PRCHDP3 ;WISC/RSD/RHD-DISPLAY PARTIALS RECEIVING OF P.O. ;OCT 9, 2001
V ;;5.1;IFCAP;**38**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S PRCHD0=$G(^PRC(442,PRCHPO,0)) Q:PRCHD0']""
ST ;S IOP="HOME",%ZIS="" D ^%ZIS W:$Y>0 @IOF W !,$S($D(PRCHNRQ):"REQUISITION: ",1:"PURCHASE ORDER: "),$P(PRCHD0,U,1),?37,"STATUS: " I $D(^PRC(442,PRCHPO,7)),+^(7)>0 W $S($D(^PRCD(442.3,+^(7),0)):$P(^(0),U,1),1:"")
S IOP="HOME",%ZIS="" D ^%ZIS W:$Y>0 @IOF W !,$S($D(PRCHNRQ):"REQUISITION: ",1:"PURCHASE ORDER: "),$P(PRCHD0,U,1),?37,"STATUS: " I $D(^PRC(442,PRCHPO,7)),+^(7)>0 W $P($G(^PRCD(442.3,+^(7),0)),U,1)
;W !,"PROCESSING: ",$S($D(^PRCD(442.5,+$P(PRCHD0,U,2),0)):$P(^(0),U,1),1:""),?37,"PARTIAL: ",PRCHDPT," " S Y=$P(^PRC(442,PRCHPO,11,PRCHDPT,0),U,1) D DT W:'PRCHDTP&($P(^(0),U,9)) " FINAL"
W !,"PROCESSING: ",$P($G(^PRCD(442.5,+$P(PRCHD0,U,2),0)),U,1),?37,"PARTIAL: ",PRCHDPT," " S Y=$P(^PRC(442,PRCHPO,11,PRCHDPT,0),U,1) D DT W:'PRCHDTP&($P(^(0),U,9)) " FINAL"
W ! F I=1:1:80 W "-"
D HDR S (PRCHDQ,PRCHDA,PRCHDTA)=0,PRCHDI=0
F S PRCHDI=$O(^PRC(442,PRCHPO,2,"AB",PRCHDRD,PRCHDI)) Q:'PRCHDI D Q:PRCHDQ
. S PRCHDN=$O(^PRC(442,PRCHPO,2,PRCHDI,3,"AC",PRCHDPT,"")) Q:PRCHDN=""
. I $D(^PRC(442,PRCHPO,2,PRCHDI,3,PRCHDN)) D:$Y+5>IOSL ASK Q:PRCHDQ D ITEM
G:PRCHDQ&PRCHDTP Q
I 'PRCHDTP,PRCHDQ F S PRCHDI=$O(^PRC(442,PRCHPO,2,"AB",PRCHDRD,PRCHDI)) Q:'PRCHDI D
. S PRCHDN=$O(^PRC(442,PRCHPO,2,PRCHDI,3,"AC",PRCHDPT,"")) Q:PRCHDN=""
. I $D(^PRC(442,PRCHPO,2,PRCHDI)) D AMT
I PRCHDPT=1,$P(^PRC(442,PRCHPO,0),U,13) S PRCHDTA=PRCHDTA+$P(^(0),U,13) W:'PRCHDQ!(PRCHDQ&(PRCHDTP)) !?2,"Estimated Shipping and/or Handling",?68,$J($P(^(0),U,13),8,2)
S PRCHDTA=PRCHDTA-PRCHDA W:+PRCHDA'=0 !!?PRCHDA'<0+40,$S(PRCHDA<0:"Discount Reduction: ",1:"Discounted Amount: "),?68,$J($S(PRCHDA<0:-PRCHDA,1:PRCHDA),8,2) W !?46,"Total Amount: ",?66,$J(PRCHDTA,10,2) G:'PRCHDTP Q
I $D(^PRC(442,PRCHPO,11,PRCHDPT,0)),$P(^(0),U,8)]"" S X=$P(^(0),U,3)+$P(^(0),U,5) I $P($G(^PRC(442,PRCHPO,3,0)),U,4)]"" W:PRCHDTA-X !?38,"Term Discount Amount: ",?68,$J(PRCHDTA-X,8,2),!?48,"Net Amount: ",?66,$J(X,10,2)
W !!?5,"Receiving Report Processed By: /ES/"_$$DECODE^PRCHES1(PRCHPO,PRCHDPT),! ;I $E(IOST)["C" R !!,"ENTER <CR> TO CONTINUE",X:DTIME
;
ADJESIG ;Check for any Adjustment on PO. If any show the adjuster. PRC*5.1*38
G:'$D(^PRC(442,PRCHPO,6,0)) SKIPIT
S CHKADJ="",ISADJ=0,ADJUSTER=""
S CHKADJ=$P($G(^PRC(442,PRCHPO,11,PRCHDPT,0)),U,21)
G:CHKADJ="" SKIPIT G:CHKADJ<1 SKIPIT
S ADJDATA=$G(^PRC(442,PRCHPO,6,CHKADJ,0))
S ADJNUM=$P(ADJDATA,U,1)
S ISADJ=$P(ADJDATA,U,8) G:ISADJ'="Y" SKIPIT
S ADJUSTER=$G(^PRC(442,PRCHPO,6,ADJNUM,1))
G:ADJUSTER="" SKIPIT
S ADJDUZ=$P(ADJUSTER,U,1),ADJESIG=$P(ADJUSTER,U,2)
S ADJNAME=$P($G(^VA(200,ADJDUZ,20)),U,2)
W !?5,"Adjustment Voucher Processed By: ",ADJNAME,!
K CHKADJ,ISADJ,ADJUSTER,ADJDATA,ADJNUM,ADJNAME,ADJESIG,ADJDUZ
SKIPIT ;
I $E(IOST)["C" R !!,"ENTER <CR> TO CONTINUE",X:DTIME
;
Q K DIWF,DIWL,DIWR,IOP,PRCHD0,PRCHDA,PRCHDCNT,PRCHDI,PRCHDI0,PRCHDI2,PRCHDIW,PRCHDN,PRCHDPT,PRCHDQ,PRCHDRD,PRCHDTA,PRCHDTP,PRCHJ,^TMP($J,"W"),^UTILITY($J,"W") Q
Q
ITEM S PRCHDI0=^PRC(442,PRCHPO,2,PRCHDI,0),PRCHDI2=^(2),DIWL=1,DIWR=33,DIWF="",PRCHDIW=0 K ^UTILITY($J,"W")
F PRCHJ=1:1 S PRCHDIW=$O(^PRC(442,PRCHPO,2,PRCHDI,1,PRCHDIW)) Q:PRCHDIW="" S X=$G(^(PRCHDIW,0)) D DIWP^PRCUTL($G(DA))
K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
S PRCHDCNT=$G(^TMP($J,"W",1)) W !?2,$J(+$P(PRCHDI0,U,1),3),?7,$G(^(1,1,0))
;W ?40,$J($P(PRCHDI0,U,2),5),?47,$S($D(^PRCD(420.5,+$P(PRCHDI0,U,3),0)):$P(^(0),U,1),1:"")
W ?40,$J($P(PRCHDI0,U,2),5),?47,$P($G(^PRCD(420.5,+$P(PRCHDI0,U,3),0)),U,1)
S X=$P($P(PRCHDI0,U,9),".",2) W ?52,$S($L(X)>3:$J($P(PRCHDI0,U,9),5,4),$L(X)>2:$J($P(PRCHDI0,U,9),6,3),$P(PRCHDI0,U,9)="N/C":" N/C",1:$J($P(PRCHDI0,U,9),7,2)) D AMT
I PRCHDCNT>1 S K=1 F S K=$O(^TMP($J,"W",1,K)) Q:K=""!(K'>0) D:$Y+5>IOSL ASK Q:PRCHDQ W !?8,^(K,0)
I $P(PRCHDI0,U,5)]"" W !?8,"IMF #: ",$P(PRCHDI0,U,5)_" " W:$P(PRCHDI2,U,2)]"" "CONTRACT: ",$P(PRCHDI2,U,2)
W !
Q
AMT Q:'$D(^PRC(442,PRCHPO,2,PRCHDI,3,PRCHDN,0)) S Y=^(0),PRCHDA=PRCHDA+$P(Y,U,5),PRCHDTA=PRCHDTA+$P(Y,U,3)
I 'PRCHDQ W ?61,$J($P(Y,U,2),5),?68,$J($P(Y,U,3),8,2)
Q
ASK I $Y+4>IOSL W !?8,"Press RETURN to CONTINUE or '^' to EXIT: " R X:DTIME S:X["^" PRCHDQ=1 I 'PRCHDQ W @IOF,!! D HDR
Q
HDR W !?55,"UNIT",?63,"QTY",?71,"TOTAL",!,"ITEM",?15,"DESCRIPTION",?42,"QTY",?46,"UNIT",?55,"COST",?63,"REC",?71,"COST",! F I=1:1:80 W "-"
Q
DT I Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDP3 4584 printed Apr 09, 2024@21:13:23 Page 2
PRCHDP3 ;WISC/RSD/RHD-DISPLAY PARTIALS RECEIVING OF P.O. ;OCT 9, 2001
V ;;5.1;IFCAP;**38**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 SET PRCHD0=$GET(^PRC(442,PRCHPO,0))
if PRCHD0']""
QUIT
ST ;S IOP="HOME",%ZIS="" D ^%ZIS W:$Y>0 @IOF W !,$S($D(PRCHNRQ):"REQUISITION: ",1:"PURCHASE ORDER: "),$P(PRCHD0,U,1),?37,"STATUS: " I $D(^PRC(442,PRCHPO,7)),+^(7)>0 W $S($D(^PRCD(442.3,+^(7),0)):$P(^(0),U,1),1:"")
+1 SET IOP="HOME"
SET %ZIS=""
DO ^%ZIS
if $Y>0
WRITE @IOF
WRITE !,$SELECT($DATA(PRCHNRQ):"REQUISITION: ",1:"PURCHASE ORDER: "),$PIECE(PRCHD0,U,1),?37,"STATUS: "
IF $DATA(^PRC(442,PRCHPO,7))
IF +^(7)>0
WRITE $PIECE($GET(^PRCD(442.3,+^(7),0)),U,1)
+2 ;W !,"PROCESSING: ",$S($D(^PRCD(442.5,+$P(PRCHD0,U,2),0)):$P(^(0),U,1),1:""),?37,"PARTIAL: ",PRCHDPT," " S Y=$P(^PRC(442,PRCHPO,11,PRCHDPT,0),U,1) D DT W:'PRCHDTP&($P(^(0),U,9)) " FINAL"
+3 WRITE !,"PROCESSING: ",$PIECE($GET(^PRCD(442.5,+$PIECE(PRCHD0,U,2),0)),U,1),?37,"PARTIAL: ",PRCHDPT," "
SET Y=$PIECE(^PRC(442,PRCHPO,11,PRCHDPT,0),U,1)
DO DT
if 'PRCHDTP&($PIECE(^(0),U,9))
WRITE " FINAL"
+4 WRITE !
FOR I=1:1:80
WRITE "-"
+5 DO HDR
SET (PRCHDQ,PRCHDA,PRCHDTA)=0
SET PRCHDI=0
+6 FOR
SET PRCHDI=$ORDER(^PRC(442,PRCHPO,2,"AB",PRCHDRD,PRCHDI))
if 'PRCHDI
QUIT
Begin DoDot:1
+7 SET PRCHDN=$ORDER(^PRC(442,PRCHPO,2,PRCHDI,3,"AC",PRCHDPT,""))
if PRCHDN=""
QUIT
+8 IF $DATA(^PRC(442,PRCHPO,2,PRCHDI,3,PRCHDN))
if $Y+5>IOSL
DO ASK
if PRCHDQ
QUIT
DO ITEM
End DoDot:1
if PRCHDQ
QUIT
+9 if PRCHDQ&PRCHDTP
GOTO Q
+10 IF 'PRCHDTP
IF PRCHDQ
FOR
SET PRCHDI=$ORDER(^PRC(442,PRCHPO,2,"AB",PRCHDRD,PRCHDI))
if 'PRCHDI
QUIT
Begin DoDot:1
+11 SET PRCHDN=$ORDER(^PRC(442,PRCHPO,2,PRCHDI,3,"AC",PRCHDPT,""))
if PRCHDN=""
QUIT
+12 IF $DATA(^PRC(442,PRCHPO,2,PRCHDI))
DO AMT
End DoDot:1
+13 IF PRCHDPT=1
IF $PIECE(^PRC(442,PRCHPO,0),U,13)
SET PRCHDTA=PRCHDTA+$PIECE(^(0),U,13)
if 'PRCHDQ!(PRCHDQ&(PRCHDTP))
WRITE !?2,"Estimated Shipping and/or Handling",?68,$JUSTIFY($PIECE(^(0),U,13),8,2)
+14 SET PRCHDTA=PRCHDTA-PRCHDA
if +PRCHDA'=0
WRITE !!?PRCHDA'<0+40,$SELECT(PRCHDA<0:"Discount Reduction: ",1:"Discounted Amount: "),?68,$JUSTIFY($SELECT(PRCHDA<0:-PRCHDA,1:PRCHDA),8,2)
WRITE !?46,"Total Amount: ",?66,$JUSTIFY(PRCHDTA,10,2)
if 'PRCHDTP
GOTO Q
+15 IF $DATA(^PRC(442,PRCHPO,11,PRCHDPT,0))
IF $PIECE(^(0),U,8)]""
SET X=$PIECE(^(0),U,3)+$PIECE(^(0),U,5)
IF $PIECE($GET(^PRC(442,PRCHPO,3,0)),U,4)]""
if PRCHDTA-X
WRITE !?38,"Term Discount Amount: ",?68,$JUSTIFY(PRCHDTA-X,8,2),!?48,"Net Amount: ",?66,$JUSTIFY(X,10,2)
+16 ;I $E(IOST)["C" R !!,"ENTER <CR> TO CONTINUE",X:DTIME
WRITE !!?5,"Receiving Report Processed By: /ES/"_$$DECODE^PRCHES1(PRCHPO,PRCHDPT),!
+17 ;
ADJESIG ;Check for any Adjustment on PO. If any show the adjuster. PRC*5.1*38
+1 if '$DATA(^PRC(442,PRCHPO,6,0))
GOTO SKIPIT
+2 SET CHKADJ=""
SET ISADJ=0
SET ADJUSTER=""
+3 SET CHKADJ=$PIECE($GET(^PRC(442,PRCHPO,11,PRCHDPT,0)),U,21)
+4 if CHKADJ=""
GOTO SKIPIT
if CHKADJ<1
GOTO SKIPIT
+5 SET ADJDATA=$GET(^PRC(442,PRCHPO,6,CHKADJ,0))
+6 SET ADJNUM=$PIECE(ADJDATA,U,1)
+7 SET ISADJ=$PIECE(ADJDATA,U,8)
if ISADJ'="Y"
GOTO SKIPIT
+8 SET ADJUSTER=$GET(^PRC(442,PRCHPO,6,ADJNUM,1))
+9 if ADJUSTER=""
GOTO SKIPIT
+10 SET ADJDUZ=$PIECE(ADJUSTER,U,1)
SET ADJESIG=$PIECE(ADJUSTER,U,2)
+11 SET ADJNAME=$PIECE($GET(^VA(200,ADJDUZ,20)),U,2)
+12 WRITE !?5,"Adjustment Voucher Processed By: ",ADJNAME,!
+13 KILL CHKADJ,ISADJ,ADJUSTER,ADJDATA,ADJNUM,ADJNAME,ADJESIG,ADJDUZ
SKIPIT ;
+1 IF $EXTRACT(IOST)["C"
READ !!,"ENTER <CR> TO CONTINUE",X:DTIME
+2 ;
Q KILL DIWF,DIWL,DIWR,IOP,PRCHD0,PRCHDA,PRCHDCNT,PRCHDI,PRCHDI0,PRCHDI2,PRCHDIW,PRCHDN,PRCHDPT,PRCHDQ,PRCHDRD,PRCHDTA,PRCHDTP,PRCHJ,^TMP($JOB,"W"),^UTILITY($JOB,"W")
QUIT
+1 QUIT
ITEM SET PRCHDI0=^PRC(442,PRCHPO,2,PRCHDI,0)
SET PRCHDI2=^(2)
SET DIWL=1
SET DIWR=33
SET DIWF=""
SET PRCHDIW=0
KILL ^UTILITY($JOB,"W")
+1 FOR PRCHJ=1:1
SET PRCHDIW=$ORDER(^PRC(442,PRCHPO,2,PRCHDI,1,PRCHDIW))
if PRCHDIW=""
QUIT
SET X=$GET(^(PRCHDIW,0))
DO DIWP^PRCUTL($GET(DA))
+2 KILL ^TMP($JOB,"W")
SET %X="^UTILITY($J,""W"","
SET %Y="^TMP($J,""W"","
DO %XY^%RCR
+3 SET PRCHDCNT=$GET(^TMP($JOB,"W",1))
WRITE !?2,$JUSTIFY(+$PIECE(PRCHDI0,U,1),3),?7,$GET(^(1,1,0))
+4 ;W ?40,$J($P(PRCHDI0,U,2),5),?47,$S($D(^PRCD(420.5,+$P(PRCHDI0,U,3),0)):$P(^(0),U,1),1:"")
+5 WRITE ?40,$JUSTIFY($PIECE(PRCHDI0,U,2),5),?47,$PIECE($GET(^PRCD(420.5,+$PIECE(PRCHDI0,U,3),0)),U,1)
+6 SET X=$PIECE($PIECE(PRCHDI0,U,9),".",2)
WRITE ?52,$SELECT($LENGTH(X)>3:$JUSTIFY($PIECE(PRCHDI0,U,9),5,4),$LENGTH(X)>2:$JUSTIFY($PIECE(PRCHDI0,U,9),6,3),$PIECE(PRCHDI0,U,9)="N/C":" N/C",1:$JUSTIFY($PIECE(PRCHDI0,U,9),7,2))
DO AMT
+7 IF PRCHDCNT>1
SET K=1
FOR
SET K=$ORDER(^TMP($JOB,"W",1,K))
if K=""!(K'>0)
QUIT
if $Y+5>IOSL
DO ASK
if PRCHDQ
QUIT
WRITE !?8,^(K,0)
+8 IF $PIECE(PRCHDI0,U,5)]""
WRITE !?8,"IMF #: ",$PIECE(PRCHDI0,U,5)_" "
if $PIECE(PRCHDI2,U,2)]""
WRITE "CONTRACT: ",$PIECE(PRCHDI2,U,2)
+9 WRITE !
+10 QUIT
AMT if '$DATA(^PRC(442,PRCHPO,2,PRCHDI,3,PRCHDN,0))
QUIT
SET Y=^(0)
SET PRCHDA=PRCHDA+$PIECE(Y,U,5)
SET PRCHDTA=PRCHDTA+$PIECE(Y,U,3)
+1 IF 'PRCHDQ
WRITE ?61,$JUSTIFY($PIECE(Y,U,2),5),?68,$JUSTIFY($PIECE(Y,U,3),8,2)
+2 QUIT
ASK IF $Y+4>IOSL
WRITE !?8,"Press RETURN to CONTINUE or '^' to EXIT: "
READ X:DTIME
if X["^"
SET PRCHDQ=1
IF 'PRCHDQ
WRITE @IOF,!!
DO HDR
+1 QUIT
HDR WRITE !?55,"UNIT",?63,"QTY",?71,"TOTAL",!,"ITEM",?15,"DESCRIPTION",?42,"QTY",?46,"UNIT",?55,"COST",?63,"REC",?71,"COST",!
FOR I=1:1:80
WRITE "-"
+1 QUIT
DT IF Y
WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
+1 QUIT
