Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPRTRA

PRCPRTRA.m

Go to the documentation of this file.
  1. PRCPRTRA ;WISC/RFJ-transaction register report ;07 Sep 91
  1. V ;;5.1;IFCAP;**1,142**;Oct 20, 2000;Build 5
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. D ^PRCPUSEL Q:'$G(PRCP("I"))
  1. N %,%H,%I,ALLITEMS,ITEMDA,PRCPDT,PRCPDATE,PRCPDATB,PRCPSUMM,X,Y
  1. ;
  1. K X S X(1)="The Transaction Register Report prints all activity for specified items, including the opening and closing balances."
  1. S X(2)="The current month-year balance on file appears under the calculated closing balance if the two values differ."
  1. D DISPLAY^PRCPUX2(40,79,.X)
  1. ;
  1. K X S X(1)="Enter the beginning/ending month-year for printing the transaction register. If printing 'ALL' items the beginning/ending dates MUST be the same."
  1. D DISPLAY^PRCPUX2(2,40,.X)
  1. DAT S Y=$E(DT,1,5)_"00" S %DT(0)=-Y
  1. D DD^%DT
  1. DAT1 S %DT="AEP",%DT("B")=Y
  1. S %DT("A")="Print Transaction Register for beginning MONTH and YEAR: "
  1. D ^%DT K %DT I Y<1 Q
  1. S (Y,PRCPDATB)=$E(Y,1,5)
  1. DAT2 S Y=$E(Y,1,5)_"00" D DD^%DT
  1. S %DT="AEP",%DT("B")=Y
  1. S %DT("A")="Print Transaction Register for ending MONTH and YEAR: "
  1. D ^%DT K %DT I Y<1 Q
  1. S (Y,PRCPDATE)=$E(Y,1,5)
  1. I PRCPDATE<PRCPDATB W !," Ending date CANNOT be prior to beginning date" G DAT2
  1. ;
  1. SELECT I PRCPDATE=$E(DT,1,5),PRCPDATB=$E(DT,1,5) D I '% Q
  1. . K X S X(1)="You may now select to print only items whose calculated closing balance differs from the current on-hand inventory."
  1. . D DISPLAY^PRCPUX2(2,40,.X)
  1. . S XP="Display only items out of balance"
  1. . S XH="Enter 'YES' to only show those items out of balance, 'NO' to select items."
  1. . S %=$$YN^PRCPUYN(2) I '% Q
  1. . I %=1 S PRCPSUMM=1
  1. ;
  1. I $G(PRCPSUMM) S ALLITEMS=1 G DEVICE
  1. ;
  1. ITEMS ;return here after printing report
  1. ; get selected item list
  1. S HPRCPDT=PRCPDATE,PRCPDATE=""
  1. D ITEMMAST^PRCPURS4(PRCPDATE)
  1. S PRCPDATE=HPRCPDT K HPRCPDT
  1. I '$O(^TMP($J,"PRCPITEMS",0)),'$D(ALLITEMS) Q
  1. I $D(ALLITEMS),(PRCPDATB'=PRCPDATE) W !,"** All Items selection MUST use same begin/end month and year **" K ALLITEMS G DAT
  1. ;
  1. DEVICE ; ask device
  1. S %ZIS="Q" D ^%ZIS Q:POP
  1. I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK,^TMP($J,"PRCPITEMS") Q
  1. . S ZTDESC="Transaction Register Report",ZTRTN="DQ^PRCPRTRA"
  1. . S ZTSAVE("PRCP*")="",ZTSAVE("ALLITEMS")="",ZTSAVE("^TMP($J,""PRCPITEMS"",")="",ZTSAVE("ZTREQ")="@"
  1. W !!,"<*> please wait <*>"
  1. ;
  1. DQ ;queue comes here
  1. N %,CURRQTY,CURRVAL,D,DATE,DESCR,ITEMDA,ITEMDATA,NSN,OPENQTY,OPENVAL,TOTALQTY,TOTALVAL,TRX,TT,UNIT,X,Y
  1. K ^TMP($J,"PRCPRTRA")
  1. S PRCPDT=PRCPDATB
  1. D1 S ITEMDA=0,TOTALQTY=0,TOTALVAL=0
  1. F S ITEMDA=$O(^PRCP(445.1,PRCP("I"),1,ITEMDA)) Q:'ITEMDA I $D(^(ITEMDA,1,PRCPDT,0))&($D(ALLITEMS)!($D(^TMP($J,"PRCPITEMS",ITEMDA)))) D
  1. . S %=$$GETOPEN^PRCPUBAL(PRCP("I"),ITEMDA,PRCPDT)
  1. . S OPENQTY=$P(%,"^",2)+$P(%,"^",3)
  1. . S OPENVAL=+$P(%,"^",8)
  1. . S NSN=$$NSN^PRCPUX1(ITEMDA) S:NSN="" NSN=" "
  1. . S TOTALQTY=OPENQTY,TOTALVAL=OPENVAL
  1. . S TRX=0
  1. . F S TRX=$O(^PRCP(445.2,"AD",PRCP("I"),ITEMDA,TRX)) Q:'TRX D
  1. . . S D=$G(^PRCP(445.2,TRX,0)),DATE=$P($P(D,"^",17),".")
  1. . . I $E(DATE,1,5)=PRCPDT D
  1. . . . S TT=$P(D,"^",4)
  1. . . . S TT=$S($E(TT,1,2)="RC":"R",$E(TT)="R":"D",1:TT)
  1. . . . S %=$E($P(D,"^",2),2,10) S:$E(%)?1A %=$E(%,2,10)
  1. . . . I PRCP("DPTYPE")="P"&(TT="D"!(TT="C")!(TT="E")) D
  1. . . . . S X=$P($P($G(^PRCP(445,+$P(D,"^",18),0)),"^"),"-",2,99)
  1. . . . . S:X'="" X=$E("to: "_X,1,18)
  1. . . . . S:$P(D,"^",19)="" $P(D,"^",19)=X
  1. . . . I PRCP("DPTYPE")="S",TT="U" D
  1. . . . . S X=$P($G(^PRCP(445.2,TRX,2)),"^",2)
  1. . . . . S:X'="" X=$E("to: "_X,1,18)
  1. . . . . S $P(D,"^",19)=X
  1. . . . I $P(D,"^",22)="",$P(D,"^",23)="" D
  1. . . . . S $P(D,"^",22)=$J($P(D,"^",7)*$S($E(TT,1,2)="R":$P(D,"^",9),1:$P(D,"^",8)),0,2)
  1. . . . . S $P(D,"^",23)=$J($P(D,"^",7)*$P(D,"^",9),0,2)
  1. . . . S $P(D,"^",22)=$J($P(D,"^",22),0,2)
  1. . . . S $P(D,"^",23)=$J($P(D,"^",23),0,2)
  1. . . . ; nonissuable
  1. . . . I $P(D,"^",11)'="" D
  1. . . . . S $P(D,"^",19)=$S($P(D,"^",7)<0:" TO",1:"FROM")
  1. . . . . S $P(D,"^",19)=$P(D,"^",19)_" noniss qty: "
  1. . . . . S $P(D,"^",19)=$P(D,"^",19)_$S($P(D,"^",7)<0:-$P(D,"^",7),1:$P(D,"^",7))
  1. . . . . S $P(D,"^",7)=""
  1. . . . . S $P(D,"^",22,23)="^"
  1. . . . S TOTALQTY=TOTALQTY+$P(D,"^",7),TOTALVAL=TOTALVAL+$P(D,"^",22)
  1. . . . S ^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT,DATE,TRX)=TT_%_"^"_$P(D,"^",19)_"^"_$P(D,"^",6)_"^"_$P(D,"^",22)_"^"_$P(D,"^",23)_"^"_$P(D,"^",7)
  1. . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
  1. . S CURRQTY=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
  1. . S CURRVAL=$P(ITEMDATA,"^",27)
  1. . I CURRVAL="" S CURRVAL=+$J(CURRQTY*$P(ITEMDATA,"^",22),0,2)
  1. . I $G(PRCPSUMM),CURRQTY=TOTALQTY,CURRVAL=TOTALVAL K ^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT) Q
  1. . S DESCR=$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,30)
  1. . S UNIT=$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")
  1. . S ^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT)=NSN_"^"_DESCR_"^"_UNIT_"^"_$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)_"^"_$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)_"^"_$P(ITEMDATA,"^",19)_"^"_OPENQTY_"^"_OPENVAL_"^"_TOTALQTY_"^"_TOTALVAL
  1. . I CURRQTY=TOTALQTY,CURRVAL=TOTALVAL Q
  1. . S ^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT,"BAL")=CURRQTY_"^"_CURRVAL
  1. S PRCPDT=PRCPDT+1 S:$E(PRCPDT,4,5)=13 PRCPDT=$E(PRCPDT,1,3)+1_"01"
  1. I PRCPDT'>PRCPDATE G D1
  1. D PRINT^PRCPRTR1
  1. I '$D(ZTQUEUED) W !!!! K PRCPSUMM G ITEMS
  1. Q