source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAWR0.m@ 1605

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

initial load of WorldVistAEHR
File size: 4.6 KB
Line 
1PRCPAWR0 ;WISC/RFJ/BGJ-print register approval form ;9.9.97
2 ;;5.1;IFCAP;**14**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 I PRCP("DPTYPE")'="W" W !,"ONLY THE WAREHOUSE CAN USE THIS OPTION." Q
6 N %,PRCPFALL,PRCPMULT,TOTAL,TRANID
7 ;
8 ; select list of adjustments
9 K ^TMP($J,"PRCPAWR0")
10 W !!,"To select ALL adjustments, press RETURN."
11 S TOTAL=0 F S TRANID=$$ADJUSTNO^PRCPAWAP Q:TRANID["^" S ^TMP($J,"PRCPAWR0",TRANID)="",TOTAL=TOTAL+1
12 I $O(^TMP($J,"PRCPAWR0",""))="" S XP="Do you want to select ALL adjustments",XH="Enter 'YES' to select ALL adjustments, 'NO' or '^' to exit." W ! S %=$$YN^PRCPUYN(1) Q:'% I %=1 S PRCPFALL=1
13 I '$G(PRCPFALL),$O(^TMP($J,"PRCPAWR0",""))="" Q
14 ;
15 ; if more than one adjustment is selected, ask to print one
16 ; report or multiple reports.
17 S PRCPMULT=1
18 I $G(PRCPFALL)!(TOTAL>1) D I %<1 Q
19 . S XP="DO YOU WANT TO PRINT A SEPARATE REPORT FOR EACH ADJUSTMENT (THIS WILL",XP(1)="USE A LOT OF PAPER)"
20 . S XH="ENTER 'YES' TO PRINT EACH UNAPPROVED ADJUSTMENT ON A SINGLE PIECE OF PAPER,",XH(1)=" 'NO' TO PRINT ALL UNAPPROVED ADJUSTMENTS ON THE SAME REPORT."
21 . W !! S %=$$YN^PRCPUYN(2) I %=2 K PRCPMULT
22 ;
23 S %ZIS="Q" W ! D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q
24 . S ZTDESC="Adjustment Approval Form",ZTRTN="DQ^PRCPAWR0"
25 . S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
26 ;
27DQ ; queue starts here.
28 N %,%H,%I,ACCOUNT,ACCT,ADJDT,DA,DATA,INVPT,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL,TRANID,VALUEINV,VALUESAL,VOUCHER,X,Y
29 ; build adjustments from ^tmp($j,"prcpawr0",tranid)=""
30 D BUILD^PRCPAWR1
31 ;
32 ; start printing report.
33 D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=0,SCREEN=$$SCRPAUSE^PRCPUREP U IO
34 S TRANID="A" F S TRANID=$O(^TMP($J,"PRCPAWR0 DA",TRANID)) Q:$E(TRANID)'="A"!($D(PRCPFLAG)) K ADJDT,INVPT S DA=0 F S DA=$O(^TMP($J,"PRCPAWR0 DA",TRANID,DA)) Q:'DA!($D(PRCPFLAG)) D
35 . S DATA=$G(^PRCP(445.2,DA,0)) I DATA="" Q
36 . S VOUCHER=$P(DATA,"^",15)
37 . I $G(PRCPMULT),'$D(ADJDT) S Y=$P(DATA,"^",17) I +Y D DD^%DT S ADJDT=Y
38 . I $G(PRCPMULT),'$D(INVPT),$P(DATA,"^",18) S INVPT=$$INVNAME^PRCPUX1($P(DATA,"^",18))
39 . I PAGE=0 S PAGE=1 D H
40 . ;
41 . S NSN=$$NSN^PRCPUX1(+$P(DATA,"^",5)),ACCT=$$ACCT1^PRCPUX1($E(NSN,1,4))
42 . W !!,NSN,?19,$E($$DESCR^PRCPUX1(PRCP("I"),$P(DATA,"^",5)),1,28),?49,"#",$P(DATA,"^",5),?60,"ACCT: ",ACCT,?73,$J($$INITIALS^PRCPUREP($P(DATA,"^",16)),6)
43 . S VALUEINV=$J($P(DATA,"^",7)*$P(DATA,"^",8),0,2),VALUESAL=$J($P(DATA,"^",7)*$P(DATA,"^",9),0,2)
44 . I $P(DATA,"^",22)'="" S VALUEINV=$J($P(DATA,"^",22),0,2),VALUESAL=$J($P(DATA,"^",23),0,2)
45 . S ACCOUNT(ACCT)=$G(ACCOUNT(ACCT))+VALUEINV
46 . W !,$P(DATA,"^",2),?13,$P(DATA,"^",19),?33,$J($P(DATA,"^",6),8),$J($P(DATA,"^",7),11),$J(VALUESAL,14,2),$J(VALUEINV,14,2)
47 . I $D(^PRCP(445.2,DA,1)) W !,$P(^(1),"^")
48 . I $Y>(IOSL-7) D:$G(SCREEN) P^PRCPUREP Q:$D(PRCPFLAG) D H
49 . I '$D(PRCPFLAG),$G(PRCPMULT),'$O(^TMP($J,"PRCPAWR0 DA",TRANID,DA)) D END^PRCPAWR1 Q:$D(PRCPFLAG)
50 I $D(PRCPFLAG) S PRCPMULT=1
51 I '$D(PRCPMULT) D END^PRCPAWR1
52Q D ^%ZISC K ^TMP($J,"PRCPAWR0"),^TMP($J,"PRCPAWR0 DA")
53 Q
54 ;
55 ;
56H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
57 W $C(13),"ADJUSTMENT APPROVAL FORM FROM ",PRCP("IN"),?(80-$L(%)),%
58 I $D(INVPT) W !?5,"DISTRIBUTION TO: ",INVPT
59 I $D(ADJDT) W !?5,"ADJUSTMENT DATE: ",ADJDT,?50,"VOUCHER: ",VOUCHER
60 W !,"NSN",?19,"DESCRIPTION",?49,"[#MI]",?60,"ACCT CODE",?72,"INITIALS"
61 S %="",$P(%,"-",81)="" W !,"TRANSID",?13,"TRANS./P.O.",?38,"U/I",?43,$J("QUANTITY",9),$J("SELL VALUE",14),$J("INV VALUE",14),!,%
62 Q
63 ;
64 ;
65PRINFORM(TRANID) ; print adjustment approval form
66 N %,PRCPMULT
67 K ^TMP($J,"PRCPAWR0")
68 S ^TMP($J,"PRCPAWR0",TRANID)=""
69 S PRCPMULT=1
70 W !!,"Queueing Approval Form to Print on 'Fiscal (Receiving Reports)' Printer ..." S %=$O(^PRC(411,PRC("SITE"),2,"AC","FR",0))
71FP I %="" W !?5,">> WARNING: DEVICE NOT FOUND IN SITE PARAMETERS FILE 411. >>",! S IOP="Q" D ^%ZIS S %=IO I '$G(IO("Q")) W !!,"MUST QUEUE OUTPUT",! S %="" G FP
72 E S ZTIO=%,ZTDTH=$H D D ^%ZTLOAD K IOP D ^%ZISC
73 . S ZTDESC="Adjustment Approval Form (Fiscal)",ZTRTN="DQ^PRCPAWR0"
74 . S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
75 ;
76 W !,"Queueing Approval Form to Print on 'Supply (PPM)' Printer ..." S %=$O(^PRC(411,PRC("SITE"),2,"AC","S",0))
77SP I %="" W !?5,">> WARNING: DEVICE NOT FOUND IN SITE PARAMETERS FILE 411. >>",! S IOP="Q" D ^%ZIS S %=IO I '$G(IO("Q")) W !!,"MUST QUEUE OUTPUT",! S %="" G SP
78 E S ZTIO=%,ZTDTH=$H D D ^%ZTLOAD K IOP D ^%ZISC
79 . S ZTDESC="Adjustment Approval Form (Supply)",ZTRTN="DQ^PRCPAWR0"
80 . S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
81 ;
82 K ^TMP($J,"PRCPAWR0")
83 Q
Note: See TracBrowser for help on using the repository browser.