| 1 | PRCPWDOR ;WISC/RFJ-print outstanding (due-outs) items ;24 Jul 91
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | N PRCPPVNO
|
|---|
| 5 | D ^PRCPUSEL Q:'$G(PRCP("I"))
|
|---|
| 6 | I PRCP("DPTYPE")'="W" W !,"YOU NEED TO BE A 'WAREHOUSE' INVENTORY POINT TO RUN THIS OPTION!" Q
|
|---|
| 7 | S PRCPPVNO=+$O(^PRC(440,"AC","S",0))_";PRC(440," I '$D(^PRC(440,+PRCPPVNO,0)) W !!,"THERE IS NOT A VENDOR IN THE VENDOR FILE (#440) DESIGNATED AS A SUPPLY WHSE." Q
|
|---|
| 8 | W !,"THIS REPORT WILL TAKE A WHILE TO RUN. IT IS RECOMMENDED THE REPORT BE",!,"QUEUED TO RUN AT NIGHT."
|
|---|
| 9 | K PRCPWDOU S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) S ZTRTN="DQ^PRCPWDOR",ZTDESC="Outstanding Due-Outs for Warehouse",ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@" D ^%ZTLOAD K IO("Q"),ZTSK Q
|
|---|
| 10 | W !!,"<*> please wait <*>"
|
|---|
| 11 | DQ ; queue comes here
|
|---|
| 12 | N %,PRCPDATA,PRCPDAT0,PRCPDAT3,MASTITEM,ITEMDATA,PRCPDAT7,PRCPDAT9,PAGE,PRCPCONV,PRCPDATE,PRCPERR,PRCPFLAG,PRCPITEM,PRCPLIDA,PRCPLINE,PRCPNSN,PRCPOUT,PRCPSRC1,PRCPTRAN,PRCPTRDA,REFNUM,SCREEN,X,Y
|
|---|
| 13 | K ^TMP($J,"PRCPWDOR")
|
|---|
| 14 | D NOW^%DTC S Y=% D DD^%DT S PRCPDATE=Y,PRCPTRDA=0
|
|---|
| 15 | F S PRCPTRDA=$O(^PRCS(410,PRCPTRDA)) Q:'PRCPTRDA!($G(PRCPFLAG)) S PRCPDAT0=$G(^PRCS(410,PRCPTRDA,0)) I PRCPDAT0'="" S PRCPTRAN=$P(PRCPDAT0,"^") D
|
|---|
| 16 | . S PRCPDAT3=$G(^PRCS(410,PRCPTRDA,3)),PRCPDAT7=$G(^PRCS(410,PRCPTRDA,7)),PRCPDAT9=$G(^PRCS(410,PRCPTRDA,9))
|
|---|
| 17 | . I $P(PRCPDAT0,"^",2)="O",$P(PRCPDAT0,"^",4)=5,$P(PRCPDAT3,"^",4)=+PRCPPVNO,$P(PRCPDAT7,"^",6)'="",$P(PRCPDAT9,"^",3)="" D
|
|---|
| 18 | . . S PRCPSRC1=+$P(PRCPDAT0,"^",6),PRCPLIDA=0 F S PRCPLIDA=$O(^PRCS(410,PRCPTRDA,"IT",PRCPLIDA)) Q:'PRCPLIDA S PRCPLINE=$G(^(PRCPLIDA,0)) I PRCPLINE'="",$P(PRCPLINE,"^",14)="" D
|
|---|
| 19 | . . . S PRCPITEM=+$P(PRCPLINE,"^",5),PRCPCONV=$P($$GETVEN^PRCPUVEN(PRCPSRC1,PRCPITEM,PRCPPVNO,1),"^",4)
|
|---|
| 20 | . . . S PRCPOUT=$P(PRCPLINE,"^",2) I $P(PRCPLINE,"^",12)'="" S PRCPOUT=$P(PRCPLINE,"^",2)-$P(PRCPLINE,"^",12)
|
|---|
| 21 | . . . I $P(PRCPLINE,"^",12)="" S %=$G(^PRCP(445,PRCPSRC1,1,PRCPITEM,7,PRCPTRDA,0)) I %'="" S PRCPOUT=$P(%,"^",2)\PRCPCONV
|
|---|
| 22 | . . . S:PRCPOUT<0 PRCPOUT=0 Q:'PRCPOUT S MASTITEM=$G(^PRC(441,PRCPITEM,0)) I MASTITEM="" S ^TMP($J,"PRCPWDOR"," ",PRCPITEM,"ERROR")="ITEM NOT IN ITEM MASTER FILE #441" Q
|
|---|
| 23 | . . . S PRCPNSN=$P(MASTITEM,"^",5) S:PRCPNSN="" PRCPNSN=" " S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,PRCPITEM,0)) K PRCPERR I ITEMDATA="" S PRCPERR="ITEM NOT FOUND IN INVENTORY POINT"
|
|---|
| 24 | . . . I '$D(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM)) S ^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM)=$P(MASTITEM,"^",2)_"^"_$P(ITEMDATA,"^",7)_"^"_$$GETOUT^PRCPUDUE(PRCP("I"),PRCPITEM)
|
|---|
| 25 | . . . S:$D(PRCPERR) ^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM,"ERROR")=PRCPERR S Y=$P($G(^PRCS(410,PRCPTRDA,1)),"^",1) I Y'="" D DD^%DT
|
|---|
| 26 | . . . S REFNUM=$P($G(^PRCS(410,PRCPTRDA,445)),"^") I REFNUM="" S REFNUM=$P($G(^PRCS(410,PRCPTRDA,100)),"^")
|
|---|
| 27 | . . . I '$D(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM,PRCPTRDA)) S ^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM,PRCPTRDA)=PRCPTRAN_"^"_REFNUM_"^"_PRCPSRC1_"^"_Y
|
|---|
| 28 | . . . S $P(^(PRCPTRDA),"^",5)=$P(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM,PRCPTRDA),"^",5)+PRCPOUT,$P(^(PRCPITEM),"^",4)=$P(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM),"^",4)+PRCPOUT
|
|---|
| 29 | . . . S %=$G(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM,PRCPTRDA,"L")) S ^("L")=%_$S(%="":"",1:",")_$P(PRCPLINE,"^")
|
|---|
| 30 | I $G(PRCPFLAG) D Q Q
|
|---|
| 31 | S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
|
|---|
| 32 | S PRCPNSN="" F S PRCPNSN=$O(^TMP($J,"PRCPWDOR",PRCPNSN)) Q:PRCPNSN=""!($G(PRCPFLAG)) S PRCPITEM=0 F S PRCPITEM=$O(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM)) Q:'PRCPITEM!($G(PRCPFLAG)) S PRCPDATA=^(PRCPITEM) D
|
|---|
| 33 | . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
|
|---|
| 34 | . S %=$E($P(PRCPDATA,"^"),1,20-$L(PRCPITEM)-2)_"("_PRCPITEM_")"
|
|---|
| 35 | . I $D(PRCPWDOU),$P(PRCPDATA,"^",3)'=$P(PRCPDATA,"^",4),'$D(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM,"ERROR")) S $P(PRCPDATA,"^",3)="* "_$P(PRCPDATA,"^",3)
|
|---|
| 36 | . W !!,PRCPNSN,?19,%,?40,$J($P(PRCPDATA,"^",2),13),$J($P(PRCPDATA,"^",3),13),$J($P(PRCPDATA,"^",4),13) I $D(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM,"ERROR")) W !?19,^("ERROR")
|
|---|
| 37 | . S PRCPTRDA=0 F S PRCPTRDA=$O(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM,PRCPTRDA)) Q:'PRCPTRDA!($G(PRCPFLAG)) S PRCPDATA=^(PRCPTRDA) D
|
|---|
| 38 | . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
|
|---|
| 39 | . . W !?5,$P(PRCPDATA,"^"),?24,$P(PRCPDATA,"^",2),?31,"#",$G(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM,PRCPTRDA,"L")),?42,$P(PRCPDATA,"^",4),?55,$E($P($$INVNAME^PRCPUX1($P(PRCPDATA,"^",3)),"-",2,99),1,15),?70,$J($P(PRCPDATA,"^",5),9)
|
|---|
| 40 | I $G(PRCPFLAG) D Q Q
|
|---|
| 41 | I $D(PRCPWDOU) W !!,"* indicates the quantity due-out has been changed to the quantity outstanding"
|
|---|
| 42 | I '$D(PRCPWDOU) D END^PRCPUREP
|
|---|
| 43 | Q I '$D(PRCPWDOU) K ^TMP($J,"PRCPWDOR") D ^%ZISC
|
|---|
| 44 | Q
|
|---|
| 45 | ;
|
|---|
| 46 | H S %=PRCPDATE_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
|
|---|
| 47 | W $C(13),"OUTSTANDING TRANSACTION REPORT",?(79-$L(%)),% S %="INVENTORY POINT: "_PRCP("IN") W !?(79-$L(%)\2),%
|
|---|
| 48 | W !,?19,"ITEM",?40,$J("QUANTITY",13),$J("QUANTITY",13),$J("QUANTITY",13) S %="",$P(%,"-",80)="" W !,"NSN",?19,"DESCRIPTION (#)",?40,$J("ON-HAND",13),$J("DUE-OUT",13),$J("OUTSTANDING",13),!,%
|
|---|
| 49 | Q
|
|---|
