- 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 Jan 18, 2025@03:07:55 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