- 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 Apr 23, 2025@18:31:07 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
