Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHDP3

PRCHDP3.m

Go to the documentation of this file.
  1. PRCHDP3 ;WISC/RSD/RHD-DISPLAY PARTIALS RECEIVING OF P.O. ;OCT 9, 2001
  1. V ;;5.1;IFCAP;**38**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. S PRCHD0=$G(^PRC(442,PRCHPO,0)) Q:PRCHD0']""
  1. 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. 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)
  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"
  1. 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"
  1. W ! F I=1:1:80 W "-"
  1. D HDR S (PRCHDQ,PRCHDA,PRCHDTA)=0,PRCHDI=0
  1. F S PRCHDI=$O(^PRC(442,PRCHPO,2,"AB",PRCHDRD,PRCHDI)) Q:'PRCHDI D Q:PRCHDQ
  1. . S PRCHDN=$O(^PRC(442,PRCHPO,2,PRCHDI,3,"AC",PRCHDPT,"")) Q:PRCHDN=""
  1. . I $D(^PRC(442,PRCHPO,2,PRCHDI,3,PRCHDN)) D:$Y+5>IOSL ASK Q:PRCHDQ D ITEM
  1. G:PRCHDQ&PRCHDTP Q
  1. I 'PRCHDTP,PRCHDQ F S PRCHDI=$O(^PRC(442,PRCHPO,2,"AB",PRCHDRD,PRCHDI)) Q:'PRCHDI D
  1. . S PRCHDN=$O(^PRC(442,PRCHPO,2,PRCHDI,3,"AC",PRCHDPT,"")) Q:PRCHDN=""
  1. . I $D(^PRC(442,PRCHPO,2,PRCHDI)) D AMT
  1. 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)
  1. 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
  1. 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)
  1. W !!?5,"Receiving Report Processed By: /ES/"_$$DECODE^PRCHES1(PRCHPO,PRCHDPT),! ;I $E(IOST)["C" R !!,"ENTER <CR> TO CONTINUE",X:DTIME
  1. ;
  1. ADJESIG ;Check for any Adjustment on PO. If any show the adjuster. PRC*5.1*38
  1. G:'$D(^PRC(442,PRCHPO,6,0)) SKIPIT
  1. S CHKADJ="",ISADJ=0,ADJUSTER=""
  1. S CHKADJ=$P($G(^PRC(442,PRCHPO,11,PRCHDPT,0)),U,21)
  1. G:CHKADJ="" SKIPIT G:CHKADJ<1 SKIPIT
  1. S ADJDATA=$G(^PRC(442,PRCHPO,6,CHKADJ,0))
  1. S ADJNUM=$P(ADJDATA,U,1)
  1. S ISADJ=$P(ADJDATA,U,8) G:ISADJ'="Y" SKIPIT
  1. S ADJUSTER=$G(^PRC(442,PRCHPO,6,ADJNUM,1))
  1. G:ADJUSTER="" SKIPIT
  1. S ADJDUZ=$P(ADJUSTER,U,1),ADJESIG=$P(ADJUSTER,U,2)
  1. S ADJNAME=$P($G(^VA(200,ADJDUZ,20)),U,2)
  1. W !?5,"Adjustment Voucher Processed By: ",ADJNAME,!
  1. K CHKADJ,ISADJ,ADJUSTER,ADJDATA,ADJNUM,ADJNAME,ADJESIG,ADJDUZ
  1. SKIPIT ;
  1. I $E(IOST)["C" R !!,"ENTER <CR> TO CONTINUE",X:DTIME
  1. ;
  1. 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
  1. Q
  1. ITEM S PRCHDI0=^PRC(442,PRCHPO,2,PRCHDI,0),PRCHDI2=^(2),DIWL=1,DIWR=33,DIWF="",PRCHDIW=0 K ^UTILITY($J,"W")
  1. 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))
  1. K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
  1. S PRCHDCNT=$G(^TMP($J,"W",1)) W !?2,$J(+$P(PRCHDI0,U,1),3),?7,$G(^(1,1,0))
  1. ;W ?40,$J($P(PRCHDI0,U,2),5),?47,$S($D(^PRCD(420.5,+$P(PRCHDI0,U,3),0)):$P(^(0),U,1),1:"")
  1. W ?40,$J($P(PRCHDI0,U,2),5),?47,$P($G(^PRCD(420.5,+$P(PRCHDI0,U,3),0)),U,1)
  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
  1. 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)
  1. I $P(PRCHDI0,U,5)]"" W !?8,"IMF #: ",$P(PRCHDI0,U,5)_" " W:$P(PRCHDI2,U,2)]"" "CONTRACT: ",$P(PRCHDI2,U,2)
  1. W !
  1. Q
  1. 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)
  1. I 'PRCHDQ W ?61,$J($P(Y,U,2),5),?68,$J($P(Y,U,3),8,2)
  1. Q
  1. 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
  1. Q
  1. 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 "-"
  1. Q
  1. DT I Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700
  1. Q