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

PRCPAWR0.m

Go to the documentation of this file.
  1. PRCPAWR0 ;WISC/RFJ/BGJ-print register approval form ;9.9.97
  1. ;;5.1;IFCAP;**14**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. D ^PRCPUSEL Q:'$G(PRCP("I"))
  1. I PRCP("DPTYPE")'="W" W !,"ONLY THE WAREHOUSE CAN USE THIS OPTION." Q
  1. N %,PRCPFALL,PRCPMULT,TOTAL,TRANID
  1. ;
  1. ; select list of adjustments
  1. K ^TMP($J,"PRCPAWR0")
  1. W !!,"To select ALL adjustments, press RETURN."
  1. S TOTAL=0 F S TRANID=$$ADJUSTNO^PRCPAWAP Q:TRANID["^" S ^TMP($J,"PRCPAWR0",TRANID)="",TOTAL=TOTAL+1
  1. 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
  1. I '$G(PRCPFALL),$O(^TMP($J,"PRCPAWR0",""))="" Q
  1. ;
  1. ; if more than one adjustment is selected, ask to print one
  1. ; report or multiple reports.
  1. S PRCPMULT=1
  1. I $G(PRCPFALL)!(TOTAL>1) D I %<1 Q
  1. . S XP="DO YOU WANT TO PRINT A SEPARATE REPORT FOR EACH ADJUSTMENT (THIS WILL",XP(1)="USE A LOT OF PAPER)"
  1. . 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."
  1. . W !! S %=$$YN^PRCPUYN(2) I %=2 K PRCPMULT
  1. ;
  1. S %ZIS="Q" W ! D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q
  1. . S ZTDESC="Adjustment Approval Form",ZTRTN="DQ^PRCPAWR0"
  1. . S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
  1. ;
  1. DQ ; queue starts here.
  1. N %,%H,%I,ACCOUNT,ACCT,ADJDT,DA,DATA,INVPT,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL,TRANID,VALUEINV,VALUESAL,VOUCHER,X,Y
  1. ; build adjustments from ^tmp($j,"prcpawr0",tranid)=""
  1. D BUILD^PRCPAWR1
  1. ;
  1. ; start printing report.
  1. D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=0,SCREEN=$$SCRPAUSE^PRCPUREP U IO
  1. 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
  1. . S DATA=$G(^PRCP(445.2,DA,0)) I DATA="" Q
  1. . S VOUCHER=$P(DATA,"^",15)
  1. . I $G(PRCPMULT),'$D(ADJDT) S Y=$P(DATA,"^",17) I +Y D DD^%DT S ADJDT=Y
  1. . I $G(PRCPMULT),'$D(INVPT),$P(DATA,"^",18) S INVPT=$$INVNAME^PRCPUX1($P(DATA,"^",18))
  1. . I PAGE=0 S PAGE=1 D H
  1. . ;
  1. . S NSN=$$NSN^PRCPUX1(+$P(DATA,"^",5)),ACCT=$$ACCT1^PRCPUX1($E(NSN,1,4))
  1. . 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)
  1. . S VALUEINV=$J($P(DATA,"^",7)*$P(DATA,"^",8),0,2),VALUESAL=$J($P(DATA,"^",7)*$P(DATA,"^",9),0,2)
  1. . I $P(DATA,"^",22)'="" S VALUEINV=$J($P(DATA,"^",22),0,2),VALUESAL=$J($P(DATA,"^",23),0,2)
  1. . S ACCOUNT(ACCT)=$G(ACCOUNT(ACCT))+VALUEINV
  1. . 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)
  1. . I $D(^PRCP(445.2,DA,1)) W !,$P(^(1),"^")
  1. . I $Y>(IOSL-7) D:$G(SCREEN) P^PRCPUREP Q:$D(PRCPFLAG) D H
  1. . I '$D(PRCPFLAG),$G(PRCPMULT),'$O(^TMP($J,"PRCPAWR0 DA",TRANID,DA)) D END^PRCPAWR1 Q:$D(PRCPFLAG)
  1. I $D(PRCPFLAG) S PRCPMULT=1
  1. I '$D(PRCPMULT) D END^PRCPAWR1
  1. Q D ^%ZISC K ^TMP($J,"PRCPAWR0"),^TMP($J,"PRCPAWR0 DA")
  1. Q
  1. ;
  1. ;
  1. H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
  1. W $C(13),"ADJUSTMENT APPROVAL FORM FROM ",PRCP("IN"),?(80-$L(%)),%
  1. I $D(INVPT) W !?5,"DISTRIBUTION TO: ",INVPT
  1. I $D(ADJDT) W !?5,"ADJUSTMENT DATE: ",ADJDT,?50,"VOUCHER: ",VOUCHER
  1. W !,"NSN",?19,"DESCRIPTION",?49,"[#MI]",?60,"ACCT CODE",?72,"INITIALS"
  1. S %="",$P(%,"-",81)="" W !,"TRANSID",?13,"TRANS./P.O.",?38,"U/I",?43,$J("QUANTITY",9),$J("SELL VALUE",14),$J("INV VALUE",14),!,%
  1. Q
  1. ;
  1. ;
  1. PRINFORM(TRANID) ; print adjustment approval form
  1. N %,PRCPMULT
  1. K ^TMP($J,"PRCPAWR0")
  1. S ^TMP($J,"PRCPAWR0",TRANID)=""
  1. S PRCPMULT=1
  1. W !!,"Queueing Approval Form to Print on 'Fiscal (Receiving Reports)' Printer ..." S %=$O(^PRC(411,PRC("SITE"),2,"AC","FR",0))
  1. FP 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
  1. E S ZTIO=%,ZTDTH=$H D D ^%ZTLOAD K IOP D ^%ZISC
  1. . S ZTDESC="Adjustment Approval Form (Fiscal)",ZTRTN="DQ^PRCPAWR0"
  1. . S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
  1. ;
  1. W !,"Queueing Approval Form to Print on 'Supply (PPM)' Printer ..." S %=$O(^PRC(411,PRC("SITE"),2,"AC","S",0))
  1. SP 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
  1. E S ZTIO=%,ZTDTH=$H D D ^%ZTLOAD K IOP D ^%ZISC
  1. . S ZTDESC="Adjustment Approval Form (Supply)",ZTRTN="DQ^PRCPAWR0"
  1. . S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
  1. ;
  1. K ^TMP($J,"PRCPAWR0")
  1. Q