- PRCPAWR0 ;WISC/RFJ/BGJ-print register approval form ;9.9.97
- ;;5.1;IFCAP;**14**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- I PRCP("DPTYPE")'="W" W !,"ONLY THE WAREHOUSE CAN USE THIS OPTION." Q
- N %,PRCPFALL,PRCPMULT,TOTAL,TRANID
- ;
- ; select list of adjustments
- K ^TMP($J,"PRCPAWR0")
- W !!,"To select ALL adjustments, press RETURN."
- S TOTAL=0 F S TRANID=$$ADJUSTNO^PRCPAWAP Q:TRANID["^" S ^TMP($J,"PRCPAWR0",TRANID)="",TOTAL=TOTAL+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
- I '$G(PRCPFALL),$O(^TMP($J,"PRCPAWR0",""))="" Q
- ;
- ; if more than one adjustment is selected, ask to print one
- ; report or multiple reports.
- S PRCPMULT=1
- I $G(PRCPFALL)!(TOTAL>1) D I %<1 Q
- . S XP="DO YOU WANT TO PRINT A SEPARATE REPORT FOR EACH ADJUSTMENT (THIS WILL",XP(1)="USE A LOT OF PAPER)"
- . 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."
- . W !! S %=$$YN^PRCPUYN(2) I %=2 K PRCPMULT
- ;
- S %ZIS="Q" W ! D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q
- . S ZTDESC="Adjustment Approval Form",ZTRTN="DQ^PRCPAWR0"
- . S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
- ;
- DQ ; queue starts here.
- N %,%H,%I,ACCOUNT,ACCT,ADJDT,DA,DATA,INVPT,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL,TRANID,VALUEINV,VALUESAL,VOUCHER,X,Y
- ; build adjustments from ^tmp($j,"prcpawr0",tranid)=""
- D BUILD^PRCPAWR1
- ;
- ; start printing report.
- D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=0,SCREEN=$$SCRPAUSE^PRCPUREP U IO
- 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
- . S DATA=$G(^PRCP(445.2,DA,0)) I DATA="" Q
- . S VOUCHER=$P(DATA,"^",15)
- . I $G(PRCPMULT),'$D(ADJDT) S Y=$P(DATA,"^",17) I +Y D DD^%DT S ADJDT=Y
- . I $G(PRCPMULT),'$D(INVPT),$P(DATA,"^",18) S INVPT=$$INVNAME^PRCPUX1($P(DATA,"^",18))
- . I PAGE=0 S PAGE=1 D H
- . ;
- . S NSN=$$NSN^PRCPUX1(+$P(DATA,"^",5)),ACCT=$$ACCT1^PRCPUX1($E(NSN,1,4))
- . 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)
- . S VALUEINV=$J($P(DATA,"^",7)*$P(DATA,"^",8),0,2),VALUESAL=$J($P(DATA,"^",7)*$P(DATA,"^",9),0,2)
- . I $P(DATA,"^",22)'="" S VALUEINV=$J($P(DATA,"^",22),0,2),VALUESAL=$J($P(DATA,"^",23),0,2)
- . S ACCOUNT(ACCT)=$G(ACCOUNT(ACCT))+VALUEINV
- . 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)
- . I $D(^PRCP(445.2,DA,1)) W !,$P(^(1),"^")
- . I $Y>(IOSL-7) D:$G(SCREEN) P^PRCPUREP Q:$D(PRCPFLAG) D H
- . I '$D(PRCPFLAG),$G(PRCPMULT),'$O(^TMP($J,"PRCPAWR0 DA",TRANID,DA)) D END^PRCPAWR1 Q:$D(PRCPFLAG)
- I $D(PRCPFLAG) S PRCPMULT=1
- I '$D(PRCPMULT) D END^PRCPAWR1
- Q D ^%ZISC K ^TMP($J,"PRCPAWR0"),^TMP($J,"PRCPAWR0 DA")
- Q
- ;
- ;
- H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
- W $C(13),"ADJUSTMENT APPROVAL FORM FROM ",PRCP("IN"),?(80-$L(%)),%
- I $D(INVPT) W !?5,"DISTRIBUTION TO: ",INVPT
- I $D(ADJDT) W !?5,"ADJUSTMENT DATE: ",ADJDT,?50,"VOUCHER: ",VOUCHER
- W !,"NSN",?19,"DESCRIPTION",?49,"[#MI]",?60,"ACCT CODE",?72,"INITIALS"
- S %="",$P(%,"-",81)="" W !,"TRANSID",?13,"TRANS./P.O.",?38,"U/I",?43,$J("QUANTITY",9),$J("SELL VALUE",14),$J("INV VALUE",14),!,%
- Q
- ;
- ;
- PRINFORM(TRANID) ; print adjustment approval form
- N %,PRCPMULT
- K ^TMP($J,"PRCPAWR0")
- S ^TMP($J,"PRCPAWR0",TRANID)=""
- S PRCPMULT=1
- W !!,"Queueing Approval Form to Print on 'Fiscal (Receiving Reports)' Printer ..." S %=$O(^PRC(411,PRC("SITE"),2,"AC","FR",0))
- 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
- E S ZTIO=%,ZTDTH=$H D D ^%ZTLOAD K IOP D ^%ZISC
- . S ZTDESC="Adjustment Approval Form (Fiscal)",ZTRTN="DQ^PRCPAWR0"
- . S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
- ;
- W !,"Queueing Approval Form to Print on 'Supply (PPM)' Printer ..." S %=$O(^PRC(411,PRC("SITE"),2,"AC","S",0))
- 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
- E S ZTIO=%,ZTDTH=$H D D ^%ZTLOAD K IOP D ^%ZISC
- . S ZTDESC="Adjustment Approval Form (Supply)",ZTRTN="DQ^PRCPAWR0"
- . S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
- ;
- K ^TMP($J,"PRCPAWR0")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAWR0 4837 printed Feb 18, 2025@23:39:18 Page 2
- PRCPAWR0 ;WISC/RFJ/BGJ-print register approval form ;9.9.97
- +1 ;;5.1;IFCAP;**14**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +4 IF PRCP("DPTYPE")'="W"
- WRITE !,"ONLY THE WAREHOUSE CAN USE THIS OPTION."
- QUIT
- +5 NEW %,PRCPFALL,PRCPMULT,TOTAL,TRANID
- +6 ;
- +7 ; select list of adjustments
- +8 KILL ^TMP($JOB,"PRCPAWR0")
- +9 WRITE !!,"To select ALL adjustments, press RETURN."
- +10 SET TOTAL=0
- FOR
- SET TRANID=$$ADJUSTNO^PRCPAWAP
- if TRANID["^"
- QUIT
- SET ^TMP($JOB,"PRCPAWR0",TRANID)=""
- SET TOTAL=TOTAL+1
- +11 IF $ORDER(^TMP($JOB,"PRCPAWR0",""))=""
- SET XP="Do you want to select ALL adjustments"
- SET XH="Enter 'YES' to select ALL adjustments, 'NO' or '^' to exit."
- WRITE !
- SET %=$$YN^PRCPUYN(1)
- if '%
- QUIT
- IF %=1
- SET PRCPFALL=1
- +12 IF '$GET(PRCPFALL)
- IF $ORDER(^TMP($JOB,"PRCPAWR0",""))=""
- QUIT
- +13 ;
- +14 ; if more than one adjustment is selected, ask to print one
- +15 ; report or multiple reports.
- +16 SET PRCPMULT=1
- +17 IF $GET(PRCPFALL)!(TOTAL>1)
- Begin DoDot:1
- +18 SET XP="DO YOU WANT TO PRINT A SEPARATE REPORT FOR EACH ADJUSTMENT (THIS WILL"
- SET XP(1)="USE A LOT OF PAPER)"
- +19 SET XH="ENTER 'YES' TO PRINT EACH UNAPPROVED ADJUSTMENT ON A SINGLE PIECE OF PAPER,"
- SET XH(1)=" 'NO' TO PRINT ALL UNAPPROVED ADJUSTMENTS ON THE SAME REPORT."
- +20 WRITE !!
- SET %=$$YN^PRCPUYN(2)
- IF %=2
- KILL PRCPMULT
- End DoDot:1
- IF %<1
- QUIT
- +21 ;
- +22 SET %ZIS="Q"
- WRITE !
- DO ^%ZIS
- if POP
- QUIT
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +23 SET ZTDESC="Adjustment Approval Form"
- SET ZTRTN="DQ^PRCPAWR0"
- +24 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("^TMP($J,""PRCPAWR0"",")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- DO Q
- QUIT
- +25 ;
- DQ ; queue starts here.
- +1 NEW %,%H,%I,ACCOUNT,ACCT,ADJDT,DA,DATA,INVPT,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL,TRANID,VALUEINV,VALUESAL,VOUCHER,X,Y
- +2 ; build adjustments from ^tmp($j,"prcpawr0",tranid)=""
- +3 DO BUILD^PRCPAWR1
- +4 ;
- +5 ; start printing report.
- +6 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET NOW=Y
- SET PAGE=0
- SET SCREEN=$$SCRPAUSE^PRCPUREP
- USE IO
- +7 SET TRANID="A"
- FOR
- SET TRANID=$ORDER(^TMP($JOB,"PRCPAWR0 DA",TRANID))
- if $EXTRACT(TRANID)'="A"!($DATA(PRCPFLAG))
- QUIT
- KILL ADJDT,INVPT
- SET DA=0
- FOR
- SET DA=$ORDER(^TMP($JOB,"PRCPAWR0 DA",TRANID,DA))
- if 'DA!($DATA(PRCPFLAG))
- QUIT
- Begin DoDot:1
- +8 SET DATA=$GET(^PRCP(445.2,DA,0))
- IF DATA=""
- QUIT
- +9 SET VOUCHER=$PIECE(DATA,"^",15)
- +10 IF $GET(PRCPMULT)
- IF '$DATA(ADJDT)
- SET Y=$PIECE(DATA,"^",17)
- IF +Y
- DO DD^%DT
- SET ADJDT=Y
- +11 IF $GET(PRCPMULT)
- IF '$DATA(INVPT)
- IF $PIECE(DATA,"^",18)
- SET INVPT=$$INVNAME^PRCPUX1($PIECE(DATA,"^",18))
- +12 IF PAGE=0
- SET PAGE=1
- DO H
- +13 ;
- +14 SET NSN=$$NSN^PRCPUX1(+$PIECE(DATA,"^",5))
- SET ACCT=$$ACCT1^PRCPUX1($EXTRACT(NSN,1,4))
- +15 WRITE !!,NSN,?19,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),$PIECE(DATA,"^",5)),1,28),?49,"#",$PIECE(DATA,"^",5),?60,"ACCT: ",ACCT,?73,$JUSTIFY($$INITIALS^PRCPUREP($PIECE(DATA,"^",16)),6)
- +16 SET VALUEINV=$JUSTIFY($PIECE(DATA,"^",7)*$PIECE(DATA,"^",8),0,2)
- SET VALUESAL=$JUSTIFY($PIECE(DATA,"^",7)*$PIECE(DATA,"^",9),0,2)
- +17 IF $PIECE(DATA,"^",22)'=""
- SET VALUEINV=$JUSTIFY($PIECE(DATA,"^",22),0,2)
- SET VALUESAL=$JUSTIFY($PIECE(DATA,"^",23),0,2)
- +18 SET ACCOUNT(ACCT)=$GET(ACCOUNT(ACCT))+VALUEINV
- +19 WRITE !,$PIECE(DATA,"^",2),?13,$PIECE(DATA,"^",19),?33,$JUSTIFY($PIECE(DATA,"^",6),8),$JUSTIFY($PIECE(DATA,"^",7),11),$JUSTIFY(VALUESAL,14,2),$JUSTIFY(VALUEINV,14,2)
- +20 IF $DATA(^PRCP(445.2,DA,1))
- WRITE !,$PIECE(^(1),"^")
- +21 IF $Y>(IOSL-7)
- if $GET(SCREEN)
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- +22 IF '$DATA(PRCPFLAG)
- IF $GET(PRCPMULT)
- IF '$ORDER(^TMP($JOB,"PRCPAWR0 DA",TRANID,DA))
- DO END^PRCPAWR1
- if $DATA(PRCPFLAG)
- QUIT
- End DoDot:1
- +23 IF $DATA(PRCPFLAG)
- SET PRCPMULT=1
- +24 IF '$DATA(PRCPMULT)
- DO END^PRCPAWR1
- Q DO ^%ZISC
- KILL ^TMP($JOB,"PRCPAWR0"),^TMP($JOB,"PRCPAWR0 DA")
- +1 QUIT
- +2 ;
- +3 ;
- H SET %=NOW_" PAGE "_PAGE
- SET PAGE=PAGE+1
- IF PAGE'=2!(SCREEN)
- WRITE @IOF
- +1 WRITE $CHAR(13),"ADJUSTMENT APPROVAL FORM FROM ",PRCP("IN"),?(80-$LENGTH(%)),%
- +2 IF $DATA(INVPT)
- WRITE !?5,"DISTRIBUTION TO: ",INVPT
- +3 IF $DATA(ADJDT)
- WRITE !?5,"ADJUSTMENT DATE: ",ADJDT,?50,"VOUCHER: ",VOUCHER
- +4 WRITE !,"NSN",?19,"DESCRIPTION",?49,"[#MI]",?60,"ACCT CODE",?72,"INITIALS"
- +5 SET %=""
- SET $PIECE(%,"-",81)=""
- WRITE !,"TRANSID",?13,"TRANS./P.O.",?38,"U/I",?43,$JUSTIFY("QUANTITY",9),$JUSTIFY("SELL VALUE",14),$JUSTIFY("INV VALUE",14),!,%
- +6 QUIT
- +7 ;
- +8 ;
- PRINFORM(TRANID) ; print adjustment approval form
- +1 NEW %,PRCPMULT
- +2 KILL ^TMP($JOB,"PRCPAWR0")
- +3 SET ^TMP($JOB,"PRCPAWR0",TRANID)=""
- +4 SET PRCPMULT=1
- +5 WRITE !!,"Queueing Approval Form to Print on 'Fiscal (Receiving Reports)' Printer ..."
- SET %=$ORDER(^PRC(411,PRC("SITE"),2,"AC","FR",0))
- FP IF %=""
- WRITE !?5,">> WARNING: DEVICE NOT FOUND IN SITE PARAMETERS FILE 411. >>",!
- SET IOP="Q"
- DO ^%ZIS
- SET %=IO
- IF '$GET(IO("Q"))
- WRITE !!,"MUST QUEUE OUTPUT",!
- SET %=""
- GOTO FP
- +1 IF '$TEST
- SET ZTIO=%
- SET ZTDTH=$HOROLOG
- Begin DoDot:1
- +2 SET ZTDESC="Adjustment Approval Form (Fiscal)"
- SET ZTRTN="DQ^PRCPAWR0"
- +3 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("^TMP($J,""PRCPAWR0"",")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IOP
- DO ^%ZISC
- +4 ;
- +5 WRITE !,"Queueing Approval Form to Print on 'Supply (PPM)' Printer ..."
- SET %=$ORDER(^PRC(411,PRC("SITE"),2,"AC","S",0))
- SP IF %=""
- WRITE !?5,">> WARNING: DEVICE NOT FOUND IN SITE PARAMETERS FILE 411. >>",!
- SET IOP="Q"
- DO ^%ZIS
- SET %=IO
- IF '$GET(IO("Q"))
- WRITE !!,"MUST QUEUE OUTPUT",!
- SET %=""
- GOTO SP
- +1 IF '$TEST
- SET ZTIO=%
- SET ZTDTH=$HOROLOG
- Begin DoDot:1
- +2 SET ZTDESC="Adjustment Approval Form (Supply)"
- SET ZTRTN="DQ^PRCPAWR0"
- +3 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("^TMP($J,""PRCPAWR0"",")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IOP
- DO ^%ZISC
- +4 ;
- +5 KILL ^TMP($JOB,"PRCPAWR0")
- +6 QUIT