source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRADP.m@ 1351

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

initial load of WorldVistAEHR
File size: 3.4 KB
Line 
1PRCPRADP ;WISC/RFJ-adjustment voucher recap (primary,second) ;25 May 93
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7DQ ; queue starts here
8 ; adjusment voucher recap for primary,secondary (called from prcpradj)
9 N DA,DATA,DATE,DATEREPT,DESCR,ITEMDA,ITEMDATA,NOW,PAGE,PRCPFLAG,REASON,SCREEN,TOTALM,TOTALP
10 K ^TMP($J,"PRCPRADP")
11 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
12 . S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,"A",DA)) Q:'DA D
13 . . S DATA=$G(^PRCP(445.2,DA,0)),ITEMDA=+$P(DATA,"^",5) I 'ITEMDA Q
14 . . S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
15 . . S %=$P(DATA,"^",19),REASON="O" I $P(%,"-",4)'="" S REASON="I"
16 . . I %'="",REASON'="I" S REASON="R"
17 . . S ^TMP($J,"PRCPRADP",$E(DESCR,1,12),ITEMDA,DATE,DA)=$P(DATA,"^",2)_"^"_$P(DATA,"^",6)_"^"_$P(DATA,"^",7)_"^"_$P(DATA,"^",22)_"^"_REASON_"^"_$P(DATA,"^",16)
18 . S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,"P",DA)) Q:'DA D
19 . . S DATA=$G(^PRCP(445.2,DA,0)),ITEMDA=+$P(DATA,"^",5) I 'ITEMDA Q
20 . . S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
21 . . S %=$P(DATA,"^",19),REASON="O"
22 . . S ^TMP($J,"PRCPRADP",$E(DESCR,1,12),ITEMDA,DATE,DA)=$P(DATA,"^",2)_"^"_$P(DATA,"^",6)_"^"_$P(DATA,"^",7)_"^"_$P(DATA,"^",22)_"^"_REASON_"^"_$P(DATA,"^",16)
23 ; print report
24 ; print report
25 S Y=PRCPDATE D DD^%DT S DATEREPT=Y
26 D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
27 S (TOTALM,TOTALP)=0
28 S DESCR="" F S DESCR=$O(^TMP($J,"PRCPRADP",DESCR)) Q:DESCR=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRADP",DESCR,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
29 . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
30 . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
31 . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
32 . W:'PRCPSUMM !!,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,32),?33,"[",ITEMDA,"]",?42,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8)
33 . S DATE=0 F S DATE=$O(^TMP($J,"PRCPRADP",DESCR,ITEMDA,DATE)) Q:'DATE!($G(PRCPFLAG)) S DA=0 F S DA=$O(^TMP($J,"PRCPRADP",DESCR,ITEMDA,DATE,DA)) Q:'DA!($G(PRCPFLAG)) S DATA=^(DA) D
34 . . W:'PRCPSUMM !?30,$P(DATA,"^"),?40,$J($E(DATE,6,7),2),$J($P(DATA,"^",2),8),$J($P(DATA,"^",3),10),$J($P(DATA,"^",4),12,2),$J($P(DATA,"^",5),3)
35 . . W:'PRCPSUMM $J($E($$INITIALS^PRCPUREP($P(DATA,"^",6)),1,5),5)
36 . . I $P(DATA,"^",4)>0 S TOTALP=TOTALP+$P(DATA,"^",4)
37 . . I $P(DATA,"^",4)<0 S TOTALM=TOTALM+$P(DATA,"^",4)
38 . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
39 I $G(PRCPFLAG) D Q Q
40 I $Y>(IOSL-8) D:SCREEN P^PRCPUREP G:$G(PRCPFLAG) Q D H
41 W !!?5,"ADJ SUMMARY",?20,$J("PLUS ADJUSTMENTS",20),$J("MINUS ADJUSTMENTS",20),$J("DIFFERENCE",20)
42 W !?5,"TOTAL",?20,$J(TOTALP,20,2),$J(TOTALM,20,2),$J(TOTALP+TOTALM,20,2)
43 W:'PRCPSUMM !!?26,"REASON CODE (I:ISSUES, O:OTHER, R:RECEIPTS) == RC"
44 D END^PRCPUREP
45Q D ^%ZISC K ^TMP($J,"PRCPRADP")
46 Q
47 ;
48H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
49 W $C(13),"ADJUSTMENT VOUCHER RECAP FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
50 W !?5,"ADJUSTMENTS FOR MONTH-YEAR: ",DATEREPT
51 S %="",$P(%,"-",81)=""
52 I PRCPSUMM W !?1,"*** ONLY SUMMARY OF ADJUSTMENTS PRINTED ***",!,% Q
53 W !,"DESCRIPTION",?33,"MI",$J("ISSUE",15)
54 W !?30,"TRAN#",?40,"DT",$J("UNITS",8),$J("QUANTITY",10),$J("INV VALUE",12),$J("RC",3),$J("USER",5)
55 W !,%
56 Q
Note: See TracBrowser for help on using the repository browser.