source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWDOU.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1PRCPWDOU ;WISC/RFJ-update due-outs@whse ;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 %,%H,%I,PRCPDT,PRCPDT1,PRCPPVNO,X,Y
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 !!,"Finalize Transactions and Update Due-Outs for Inventory Point: ",PRCP("IN"),!
9 D NOW^%DTC S X1=X,X2=-3 D C^%DTC S %DT("A")="Remove Due-Outs and make ALL transactions final up to DATE: ",%DT="AEPX",%DT(0)=-X D ^%DT K %DT Q:Y<1 S PRCPDT=Y D DD^%DT S PRCPDT1=Y
10 K X S X(1)="WARNING: I will make all transactions final up to date: "_PRCPDT1_". I will also update your DUE-OUT Quantity in your inventory point. You will not be able to post/receive a transaction after it has been made a final."
11 D DISPLAY^PRCPUX2(5,75,.X)
12 K X S X(1)="THIS REPORT WILL LOCK THE 'CONTROL POINT ACTIVITY' FILE #410. OTHER USERS WILL NOT BE ABLE TO ACCESS THIS FILE UNTIL THIS REPORT FINISHES. THEREFORE, I STRONGLY RECOMMEND RUNNING THIS REPORT AT NIGHT."
13 D DISPLAY^PRCPUX2(5,75,.X)
14ZIS S (%ZIS,IOP)="Q",%ZIS("B")="",%ZIS("A")="QUEUE TO PRINT ON DEVICE: " W ! D ^%ZIS I POP Q
15 I IO=IO(0) W !,"YOU CANNOT SELECT YOUR CURRENT DEVICE." G ZIS
16 S XP="ARE YOU SURE YOU WANT TO RUN THIS OPTION",XH="Enter 'YES' to start finalizing transactions and updating the Due-Outs.",XH(1)="Enter 'NO' or '^' to exit."
17 I $$YN^PRCPUYN(2)'=1 D Q Q
18 W !!,"The 'OUTSTANDING TRANSACTION REPORT' will print when finished."
19 S ZTRTN="DQ^PRCPWDOU",ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@",ZTDESC="Finalize Transactions and update Due-Outs" D ^%ZTLOAD K ZTSK G Q
20DQ ; queue comes here
21 N PRCPDAT0,PRCPDAT1,PRCPDAT3,PRCPDAT7,PRCPDAT9,PRCPITEM,PRCPLINE,PRCPNSN,PRCPOUT,PRCPSRC1,PRCPTRAN,PRCPTRDA,PRCPWDOU
22 S PRCPTRAN=0
23 F S PRCPTRAN=$O(^PRCS(410,"B",PRCPTRAN)) Q:PRCPTRAN="" S PRCPTRDA=0 F S PRCPTRDA=$O(^PRCS(410,"B",PRCPTRAN,PRCPTRDA)) Q:'PRCPTRDA I $D(^PRCS(410,PRCPTRDA,0)) D
24 . L +^PRCS(410,PRCPTRDA)
25 . S PRCPDAT0=^PRCS(410,PRCPTRDA,0),PRCPDAT1=$G(^PRCS(410,PRCPTRDA,1)),PRCPDAT3=$G(^PRCS(410,PRCPTRDA,3)),PRCPDAT7=$G(^PRCS(410,PRCPTRDA,7)),PRCPDAT9=$G(^PRCS(410,PRCPTRDA,9))
26 . I $P(PRCPDAT0,"^",2)="O",$P(PRCPDAT0,"^",4)=5,$P(PRCPDAT3,"^",4)=+PRCPPVNO,$P(PRCPDAT7,"^",6)'="",$P(PRCPDAT9,"^",3)="",$P(PRCPDAT1,"^")<PRCPDT D
27 . . S $P(^PRCS(410,PRCPTRDA,9),"^",3)=PRCPDT,PRCPSRC1=+$P(PRCPDAT0,"^",6) Q:'$D(^PRCP(445,PRCPSRC1,0))
28 . . S PRCPLINE=0 F S PRCPLINE=$O(^PRCS(410,PRCPTRDA,"IT",PRCPLINE)) Q:'PRCPLINE S PRCPITEM=+$P(^(PRCPLINE,0),"^",5) I $D(^PRCP(445,PRCPSRC1,1,PRCPITEM,7,PRCPTRDA,0)) D KILLTRAN^PRCPUTRA(PRCPSRC1,PRCPITEM,PRCPTRDA)
29 . L -^PRCS(410,PRCPTRDA)
30 ;
31 S PRCPWDOU=1 D DQ^PRCPWDOR
32 ;
33 S PRCPITEM=0 F S PRCPITEM=$O(^PRCP(445,PRCP("I"),1,PRCPITEM)) Q:'PRCPITEM D
34 . S PRCPNSN=$$NSN^PRCPUX1(PRCPITEM)
35 . ; set dueout=newqty (subtract off current dueout qty)
36 . I PRCPNSN'="" S PRCPOUT=+$P($G(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM)),"^",4),%=$$GETOUT^PRCPUDUE(PRCP("I"),PRCPITEM) D SETOUT^PRCPUDUE(PRCP("I"),PRCPITEM,PRCPOUT-%)
37 W !!,"TRANSACTIONS BEFORE DATE ",PRCPDT1," HAVE BEEN FINALIZED. ALL INVENTORY ITEMS",!,"SHOULD NOW HAVE THE CORRECT DUE-OUT QUANTITY. ITEMS NOT APPEARING ON THIS LIST",!,"WILL HAVE A DUE-OUT EQUAL TO ZERO."
38 D END^PRCPUREP
39Q K ^TMP($J,"PRCPWDOR") D ^%ZISC
40 Q
Note: See TracBrowser for help on using the repository browser.