source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRADJ.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1PRCPRADJ ;WISC/RFJ-adjustment voucher recap (option, whse) ;9.9.97
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 N %,%DT,%H,%I,DEFAULT,PRCPDATE,PRCPSUMM,X,Y
6 K X S X(1)="The Adjustment Voucher Recap Report will print all adjustments to the inventory point for a specified month-year."
7 I PRCP("DPTYPE")="W" S X(2)="The report will sort Warehouse inventory items by the NSN and the date of the adjustment."
8 E S X(2)="The report will sort Primary and Secondary inventory items by the description and the date of the adjustment."
9 D DISPLAY^PRCPUX2(40,79,.X)
10 S Y=$E(DT,1,5)_"00" D DD^%DT S DEFAULT=Y
11 K X S X(1)="Select the Adjustment Month-Year to display" D DISPLAY^PRCPUX2(2,40,.X)
12 S %DT("A")="Print Adjustment Voucher Recap for Month-Year: ",%DT("B")=DEFAULT,%DT="AEP",%DT(0)=-DT D ^%DT I Y<0 Q
13 S PRCPDATE=Y
14 S PRCPSUMM=$$SUMMARY^PRCPURS0 I PRCPSUMM<0 Q
15 W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
16 . S ZTDESC="Adjustment Voucher Recap",ZTRTN="DQ^PRCPRADJ"
17 . S ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@"
18 W !!,"<*> please wait <*>"
19DQ ; queue starts here
20 I PRCP("DPTYPE")'="W" D DQ^PRCPRADP Q
21 ; adjustment voucher recap for whse
22 N ACCT,DA,DATA,DATE,DATEREPT,FCP,ITEMDA,ITEMDATA,NOW,NSN,PAGE,PRCPFLAG,REASON,SCREEN,TOTAL,TOTALM,TOTALP
23 K ^TMP($J,"PRCPRADJ")
24 S DATE=$E(PRCPDATE,1,5)_"00" F S DATE=$O(^PRCP(445.2,"AX",PRCP("I"),DATE)) Q:'DATE!($E(DATE,1,5)'=$E(PRCPDATE,1,5)) D
25 . S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,"A",DA)) Q:'DA D
26 . . S DATA=$G(^PRCP(445.2,DA,0)),ITEMDA=+$P(DATA,"^",5) I 'ITEMDA Q
27 . . S NSN=$$NSN^PRCPUX1(ITEMDA),ACCT=$$ACCT1^PRCPUX1($E(NSN,1,4)) S:NSN="" NSN=" "
28 . . S %=$P(DATA,"^",19),REASON="O",FCP=$P(%,"-",4) I FCP'="" S REASON="I"
29 . . I %'="",FCP="" S REASON="R"
30 . . S ^TMP($J,"PRCPRADJ",ACCT,NSN,ITEMDA,DATE,DA)=$P(DATA,"^",15)_"^"_$P(DATA,"^",2)_"^"_$P(DATA,"^",6)_"^"_$P(DATA,"^",7)_"^"_$P(DATA,"^",22)_"^"_$P(DATA,"^",23)_"^"_FCP_"^"_REASON_"^"_$P(DATA,"^",16)
31 ; print report
32 S Y=PRCPDATE D DD^%DT S DATEREPT=Y
33 D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
34 K TOTAL
35 S ACCT=0 F S ACCT=$O(^TMP($J,"PRCPRADJ",ACCT)) Q:'ACCT!($G(PRCPFLAG)) D
36 . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
37 . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
38 . W:'PRCPSUMM !!?5,"ACCOUNT NUMBER: ",ACCT
39 . S NSN="" F S NSN=$O(^TMP($J,"PRCPRADJ",ACCT,NSN)) Q:NSN=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRADJ",ACCT,NSN,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
40 . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
41 . . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
42 . . W:'PRCPSUMM !!,$TR(NSN,"-"),?15,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,23),?39,"[",ITEMDA,"]",?48,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8)
43 . . S DATE=0 F S DATE=$O(^TMP($J,"PRCPRADJ",ACCT,NSN,ITEMDA,DATE)) Q:'DATE!($G(PRCPFLAG)) S DA=0 F S DA=$O(^TMP($J,"PRCPRADJ",ACCT,NSN,ITEMDA,DATE,DA)) Q:'DA!($G(PRCPFLAG)) S DATA=^(DA) D
44 . . . W:'PRCPSUMM !?5,$P(DATA,"^"),?12,$P(DATA,"^",2),?22,$J($E(DATE,6,7),2),$J($P(DATA,"^",3),8),$J($P(DATA,"^",4),10),$J($P(DATA,"^",5),12,2),$J($P(DATA,"^",6),12,2),$J($P(DATA,"^",7),6),$J($P(DATA,"^",8),3)
45 . . . W:'PRCPSUMM $J($E($$INITIALS^PRCPUREP($P(DATA,"^",9)),1,5),5)
46 . . . I $P(DATA,"^",5)>0 S TOTAL(ACCT,"+")=$G(TOTAL(ACCT,"+"))+$P(DATA,"^",5)
47 . . . I $P(DATA,"^",5)<0 S TOTAL(ACCT,"-")=$G(TOTAL(ACCT,"-"))+$P(DATA,"^",5)
48 . . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
49 I $G(PRCPFLAG) D Q Q
50 I $Y>(IOSL-10) D:SCREEN P^PRCPUREP G:$G(PRCPFLAG) Q D H
51 W !!?5,"ACCT SUMMARY",?20,$J("PLUS ADJUSTMENTS",20),$J("MINUS ADJUSTMENTS",20),$J("DIFFERENCE",20)
52 S (ACCT,TOTALM,TOTALP)=0 F S ACCT=$O(TOTAL(ACCT)) Q:'ACCT!($G(PRCPFLAG)) D
53 . W !?5,"ACCT: ",ACCT,?20,$J($G(TOTAL(ACCT,"+")),20,2),$J($G(TOTAL(ACCT,"-")),20,2),$J($G(TOTAL(ACCT,"+"))+$G(TOTAL(ACCT,"-")),20,2)
54 . S TOTALM=TOTALM+$G(TOTAL(ACCT,"-")),TOTALP=TOTALP+$G(TOTAL(ACCT,"+"))
55 . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
56 I $G(PRCPFLAG) D Q Q
57 W !?5,"TOTAL",?20,$J(TOTALP,20,2),$J(TOTALM,20,2),$J(TOTALP+TOTALM,20,2)
58 W:'PRCPSUMM !!?26,"REASON CODE (I:ISSUES, O:OTHER, R:RECEIPTS) == RC"
59 D END^PRCPUREP
60Q D ^%ZISC K ^TMP($J,"PRCPRADJ")
61 Q
62 ;
63H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
64 W $C(13),"ADJUSTMENT VOUCHER RECAP FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
65 W !?5,"ADJUSTMENTS FOR MONTH-YEAR: ",DATEREPT
66 S %="",$P(%,"-",81)=""
67 I PRCPSUMM W !?1,"*** ONLY SUMMARY OF ADJUSTMENTS PRINTED ***",!,% Q
68 W !,"NSN",?15,"DESCRIPTION",?40,"MI",$J("ISSUE",14)
69 W !?5,"REF#",?12,"TRAN#",?22,"DT",$J("UNITS",8),$J("QUANTITY",10),$J("INV VALUE",12),$J("SELL VALUE",12),$J("FCP",6),$J("RC",3),$J("USER",5)
70 W !,%
71 Q
Note: See TracBrowser for help on using the repository browser.