PRCPWDOU ;WISC/RFJ-update due-outs@whse ;24 Jul 91
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N %,%H,%I,PRCPDT,PRCPDT1,PRCPPVNO,X,Y
D ^PRCPUSEL Q:'$G(PRCP("I"))
I PRCP("DPTYPE")'="W" W !,"YOU NEED TO BE A 'WAREHOUSE' INVENTORY POINT TO RUN THIS OPTION!" Q
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
W !!,"Finalize Transactions and Update Due-Outs for Inventory Point: ",PRCP("IN"),!
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
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."
D DISPLAY^PRCPUX2(5,75,.X)
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."
D DISPLAY^PRCPUX2(5,75,.X)
ZIS S (%ZIS,IOP)="Q",%ZIS("B")="",%ZIS("A")="QUEUE TO PRINT ON DEVICE: " W ! D ^%ZIS I POP Q
I IO=IO(0) W !,"YOU CANNOT SELECT YOUR CURRENT DEVICE." G ZIS
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."
I $$YN^PRCPUYN(2)'=1 D Q Q
W !!,"The 'OUTSTANDING TRANSACTION REPORT' will print when finished."
S ZTRTN="DQ^PRCPWDOU",ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@",ZTDESC="Finalize Transactions and update Due-Outs" D ^%ZTLOAD K ZTSK G Q
DQ ; queue comes here
N PRCPDAT0,PRCPDAT1,PRCPDAT3,PRCPDAT7,PRCPDAT9,PRCPITEM,PRCPLINE,PRCPNSN,PRCPOUT,PRCPSRC1,PRCPTRAN,PRCPTRDA,PRCPWDOU
S PRCPTRAN=0
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
. L +^PRCS(410,PRCPTRDA)
. 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))
. I $P(PRCPDAT0,"^",2)="O",$P(PRCPDAT0,"^",4)=5,$P(PRCPDAT3,"^",4)=+PRCPPVNO,$P(PRCPDAT7,"^",6)'="",$P(PRCPDAT9,"^",3)="",$P(PRCPDAT1,"^")<PRCPDT D
. . S $P(^PRCS(410,PRCPTRDA,9),"^",3)=PRCPDT,PRCPSRC1=+$P(PRCPDAT0,"^",6) Q:'$D(^PRCP(445,PRCPSRC1,0))
. . 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)
. L -^PRCS(410,PRCPTRDA)
;
S PRCPWDOU=1 D DQ^PRCPWDOR
;
S PRCPITEM=0 F S PRCPITEM=$O(^PRCP(445,PRCP("I"),1,PRCPITEM)) Q:'PRCPITEM D
. S PRCPNSN=$$NSN^PRCPUX1(PRCPITEM)
. ; set dueout=newqty (subtract off current dueout qty)
. I PRCPNSN'="" S PRCPOUT=+$P($G(^TMP($J,"PRCPWDOR",PRCPNSN,PRCPITEM)),"^",4),%=$$GETOUT^PRCPUDUE(PRCP("I"),PRCPITEM) D SETOUT^PRCPUDUE(PRCP("I"),PRCPITEM,PRCPOUT-%)
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."
D END^PRCPUREP
Q K ^TMP($J,"PRCPWDOR") D ^%ZISC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWDOU 3545 printed Sep 23, 2025@19:52:41 Page 2
PRCPWDOU ;WISC/RFJ-update due-outs@whse ;24 Jul 91
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 NEW %,%H,%I,PRCPDT,PRCPDT1,PRCPPVNO,X,Y
+4 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+5 IF PRCP("DPTYPE")'="W"
WRITE !,"YOU NEED TO BE A 'WAREHOUSE' INVENTORY POINT TO RUN THIS OPTION!"
QUIT
+6 SET PRCPPVNO=+$ORDER(^PRC(440,"AC","S",0))_";PRC(440,"
IF '$DATA(^PRC(440,+PRCPPVNO,0))
WRITE !!,"THERE IS NOT A VENDOR IN THE VENDOR FILE (#440) DESIGNATED AS A SUPPLY WHSE."
QUIT
+7 WRITE !!,"Finalize Transactions and Update Due-Outs for Inventory Point: ",PRCP("IN"),!
+8 DO NOW^%DTC
SET X1=X
SET X2=-3
DO C^%DTC
SET %DT("A")="Remove Due-Outs and make ALL transactions final up to DATE: "
SET %DT="AEPX"
SET %DT(0)=-X
DO ^%DT
KILL %DT
if Y<1
QUIT
SET PRCPDT=Y
DO DD^%DT
SET PRCPDT1=Y
+9 KILL X
SET 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."
+10 DO DISPLAY^PRCPUX2(5,75,.X)
+11 KILL X
SET 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."
+12 DO DISPLAY^PRCPUX2(5,75,.X)
ZIS SET (%ZIS,IOP)="Q"
SET %ZIS("B")=""
SET %ZIS("A")="QUEUE TO PRINT ON DEVICE: "
WRITE !
DO ^%ZIS
IF POP
QUIT
+1 IF IO=IO(0)
WRITE !,"YOU CANNOT SELECT YOUR CURRENT DEVICE."
GOTO ZIS
+2 SET XP="ARE YOU SURE YOU WANT TO RUN THIS OPTION"
SET XH="Enter 'YES' to start finalizing transactions and updating the Due-Outs."
SET XH(1)="Enter 'NO' or '^' to exit."
+3 IF $$YN^PRCPUYN(2)'=1
DO Q
QUIT
+4 WRITE !!,"The 'OUTSTANDING TRANSACTION REPORT' will print when finished."
+5 SET ZTRTN="DQ^PRCPWDOU"
SET ZTSAVE("PRCP*")=""
SET ZTSAVE("ZTREQ")="@"
SET ZTDESC="Finalize Transactions and update Due-Outs"
DO ^%ZTLOAD
KILL ZTSK
GOTO Q
DQ ; queue comes here
+1 NEW PRCPDAT0,PRCPDAT1,PRCPDAT3,PRCPDAT7,PRCPDAT9,PRCPITEM,PRCPLINE,PRCPNSN,PRCPOUT,PRCPSRC1,PRCPTRAN,PRCPTRDA,PRCPWDOU
+2 SET PRCPTRAN=0
+3 FOR
SET PRCPTRAN=$ORDER(^PRCS(410,"B",PRCPTRAN))
if PRCPTRAN=""
QUIT
SET PRCPTRDA=0
FOR
SET PRCPTRDA=$ORDER(^PRCS(410,"B",PRCPTRAN,PRCPTRDA))
if 'PRCPTRDA
QUIT
IF $DATA(^PRCS(410,PRCPTRDA,0))
Begin DoDot:1
+4 LOCK +^PRCS(410,PRCPTRDA)
+5 SET PRCPDAT0=^PRCS(410,PRCPTRDA,0)
SET PRCPDAT1=$GET(^PRCS(410,PRCPTRDA,1))
SET PRCPDAT3=$GET(^PRCS(410,PRCPTRDA,3))
SET PRCPDAT7=$GET(^PRCS(410,PRCPTRDA,7))
SET PRCPDAT9=$GET(^PRCS(410,PRCPTRDA,9))
+6 IF $PIECE(PRCPDAT0,"^",2)="O"
IF $PIECE(PRCPDAT0,"^",4)=5
IF $PIECE(PRCPDAT3,"^",4)=+PRCPPVNO
IF $PIECE(PRCPDAT7,"^",6)'=""
IF $PIECE(PRCPDAT9,"^",3)=""
IF $PIECE(PRCPDAT1,"^")<PRCPDT
Begin DoDot:2
+7 SET $PIECE(^PRCS(410,PRCPTRDA,9),"^",3)=PRCPDT
SET PRCPSRC1=+$PIECE(PRCPDAT0,"^",6)
if '$DATA(^PRCP(445,PRCPSRC1,0))
QUIT
+8 SET PRCPLINE=0
FOR
SET PRCPLINE=$ORDER(^PRCS(410,PRCPTRDA,"IT",PRCPLINE))
if 'PRCPLINE
QUIT
SET PRCPITEM=+$PIECE(^(PRCPLINE,0),"^",5)
IF $DATA(^PRCP(445,PRCPSRC1,1,PRCPITEM,7,PRCPTRDA,0))
DO KILLTRAN^PRCPUTRA(PRCPSRC1,PRCPITEM,PRCPTRDA)
End DoDot:2
+9 LOCK -^PRCS(410,PRCPTRDA)
End DoDot:1
+10 ;
+11 SET PRCPWDOU=1
DO DQ^PRCPWDOR
+12 ;
+13 SET PRCPITEM=0
FOR
SET PRCPITEM=$ORDER(^PRCP(445,PRCP("I"),1,PRCPITEM))
if 'PRCPITEM
QUIT
Begin DoDot:1
+14 SET PRCPNSN=$$NSN^PRCPUX1(PRCPITEM)
+15 ; set dueout=newqty (subtract off current dueout qty)
+16 IF PRCPNSN'=""
SET PRCPOUT=+$PIECE($GET(^TMP($JOB,"PRCPWDOR",PRCPNSN,PRCPITEM)),"^",4)
SET %=$$GETOUT^PRCPUDUE(PRCP("I"),PRCPITEM)
DO SETOUT^PRCPUDUE(PRCP("I"),PRCPITEM,PRCPOUT-%)
End DoDot:1
+17 WRITE !!,"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."
+18 DO END^PRCPUREP
Q KILL ^TMP($JOB,"PRCPWDOR")
DO ^%ZISC
+1 QUIT
