PRCHRPT3 ;BOISE/TKW-SUPPLEMENT TO PRCHRPT2--ACTUAL PRINT OF FPDS REPORTS ;8JUL1986/7:20 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN S PRCHPAGE=0,PRCHDY=99 S ^TMP($J,"TOTAL")="** REPORT TOTAL **"
I PRCHRPT=1 S N="BREAKOUT CODE",PRCHRFLG="B",PRCHKEY=-1 D RD1 S X=^TMP($J,"TOTAL") D PRTT
I PRCHRPT=1 S N="TYPE CODE",PRCHRFLG="T",PRCHPAGE=0,PRCHDY=99,PRCHKEY=-1,^TMP($J,"TOTAL")="** REPORT TOTAL **" D RD1 S X=^TMP($J,"TOTAL") D PRTT Q
I PRCHRPT=2 S N="P.O.NUMBER",PRCHPONO=-1 D RD2 S X=^TMP($J,"TOTAL") D PRTT Q
I PRCHRPT=3 S N="CONTRACT NO.",PRCHRFLG="C",PRCHKEY=-1 D RD1 S X=^TMP($J,"TOTAL") D PRTT Q
I PRCHRPT=4 S N="",X=^TMP($J),PRCHKEY="" D PRT1 Q
I PRCHRPT=5 S N="FUND CONTROL POINT",PRCHRFLG="F",PRCHKEY=-1 S (PRCHOTCT,PRCHLTOT,PRCHTTOT)=0 D
. D RD1
. W !?30,"----------",?45,"---------",?65,"------------"
. W !?15,"TOTALS",?35,PRCHOTCT,?50,PRCHLTOT,?68,PRCHTTOT
. K PRCHOTCT,PRCHLTOT,PRCHTTOT Q
Q
RD1 ; READ REPORT FILE ^TMP AND PRINT REPORT
S PRCHKEY=$O(^TMP($J,"R",PRCHRFLG,PRCHKEY)) Q:PRCHKEY="" S X=^(PRCHKEY) D D PRT1
. S PRCHOTCT=PRCHOTCT+$P(X,U,2)
. S PRCHLTOT=PRCHLTOT+$P(X,U,3)
. S PRCHTTOT=PRCHTTOT+$P(X,U,4)
S $P(^TMP($J,"TOTAL"),U,2)=$P(^TMP($J,"TOTAL"),U,2)+$P(X,U,2),$P(^("TOTAL"),U,3)=$P(^("TOTAL"),U,3)+$P(X,U,3),$P(^("TOTAL"),U,4)=$P(^("TOTAL"),U,4)+$P(X,U,4)
G RD1
RD2 ; READ ^TMP FILE FOR REPORT BY P.O.NUMBER
S PRCHPONO=$O(^TMP($J,"R",PRCHPONO)) Q:'PRCHPONO S X=^(PRCHPONO) D PRT2
S $P(^TMP($J,"TOTAL"),U,2)=$P(^TMP($J,"TOTAL"),U,2)+1,$P(^("TOTAL"),U,3)=$P(^("TOTAL"),U,3)+$P(X,U,2)
S I=0,PRCHTOT=0 F K=1:1 S I=$O(^TMP($J,"R",PRCHPONO,"C",I)) Q:I="" S X=^(I),PRCHTOT=PRCHTOT+$P(X,U,2) D PRT3 S $P(^("TOTAL"),U,4)=$P(^TMP($J,"TOTAL"),U,4)+$P(X,U,2)
I K>2 D:PRCHDY>(IOSL-4) HDR W ?57,"*TOTAL*",?66,$J(PRCHTOT,11,2),! S PRCHDY=PRCHDY+1
W ! S PRCHDY=PRCHDY+1 G RD2
PRT1 D:PRCHDY>(IOSL-6) HDR W PRCHKEY,?3,$P(X,U,1) I $L($P(X,U,1))>27 W ! S PRCHDY=PRCHDY+1
W ?30,$J($P(X,U,2),8),?45,$J($P(X,U,3),8),?66,$J($P(X,U,4),11,2),!! S PRCHDY=PRCHDY+2 Q
PRT2 D:PRCHDY>(IOSL-6) HDR W $P(PRCHPONO,"-",2),?12,"P.O.DATE:",$P(X,U,1),?45,$J($P(X,U,2),8),! S PRCHDY=PRCHDY+1 Q
PRT3 D:PRCHDY>(IOSL-4) HDR W:K=1 ?18,"CONTRACTS:" W ?30,I
W ?66,$J($P(X,U,2),11,2),! S PRCHDY=PRCHDY+1 Q
PRTT ; PRINT REPORT GRAND TOTALS
D:PRCHDY>(IOSL-7) HDR W !!!,?8,$P(X,U,1)
W ?30,$J($P(X,U,2),8),?45,$J($P(X,U,3),8),?66,$J($P(X,U,4),11,2),! Q
HDR S PRCHPAGE=PRCHPAGE+1 W @IOF,"PROCUREMENT & ACCOUNTING TRANSACTIONS STATISTICS",?51,PRCHPDAT,?74,"PAGE ",PRCHPAGE,!
W "CONTROL POINTS/MONTH FOR STATION: ",PRC("SITE")
W " P.O.DATES "_PRCHPFR_" - "_PRCHPTO,!!
W ?45,"LINE/ITEM",!,N,?30,"P.O.COUNT",?47,"TOTAL",?65,"TOTAL AMOUNT",!
F J=0:1:(IOM-2) W "-"
W !! S PRCHDY=6 Q
DEL2237 ; The option Delete 2237 Request from Worksheet file is being de-
; activated. It is no longer needed, as the 2237s with status of
; Returned to Service by PPM or by P&C no longer appear on the
; Outstanding 2237 Report. This Delete option was removing the
; 2237 from file 443,but leaving the approving e-sig info in file
; file 410, making inaccessable to A&MM and to the service.
W !!,"This option has been de-activated, as it is no longer needed."
W !,"Instead of deleting the 2237, return it to the service. 2237s"
W !,"returned to the service no longer appear on the Outstanding 2237"
W !,"Report."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPT3 3434 printed Dec 13, 2024@02:10:30 Page 2
PRCHRPT3 ;BOISE/TKW-SUPPLEMENT TO PRCHRPT2--ACTUAL PRINT OF FPDS REPORTS ;8JUL1986/7:20 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN SET PRCHPAGE=0
SET PRCHDY=99
SET ^TMP($JOB,"TOTAL")="** REPORT TOTAL **"
+1 IF PRCHRPT=1
SET N="BREAKOUT CODE"
SET PRCHRFLG="B"
SET PRCHKEY=-1
DO RD1
SET X=^TMP($JOB,"TOTAL")
DO PRTT
+2 IF PRCHRPT=1
SET N="TYPE CODE"
SET PRCHRFLG="T"
SET PRCHPAGE=0
SET PRCHDY=99
SET PRCHKEY=-1
SET ^TMP($JOB,"TOTAL")="** REPORT TOTAL **"
DO RD1
SET X=^TMP($JOB,"TOTAL")
DO PRTT
QUIT
+3 IF PRCHRPT=2
SET N="P.O.NUMBER"
SET PRCHPONO=-1
DO RD2
SET X=^TMP($JOB,"TOTAL")
DO PRTT
QUIT
+4 IF PRCHRPT=3
SET N="CONTRACT NO."
SET PRCHRFLG="C"
SET PRCHKEY=-1
DO RD1
SET X=^TMP($JOB,"TOTAL")
DO PRTT
QUIT
+5 IF PRCHRPT=4
SET N=""
SET X=^TMP($JOB)
SET PRCHKEY=""
DO PRT1
QUIT
+6 IF PRCHRPT=5
SET N="FUND CONTROL POINT"
SET PRCHRFLG="F"
SET PRCHKEY=-1
SET (PRCHOTCT,PRCHLTOT,PRCHTTOT)=0
Begin DoDot:1
+7 DO RD1
+8 WRITE !?30,"----------",?45,"---------",?65,"------------"
+9 WRITE !?15,"TOTALS",?35,PRCHOTCT,?50,PRCHLTOT,?68,PRCHTTOT
+10 KILL PRCHOTCT,PRCHLTOT,PRCHTTOT
QUIT
End DoDot:1
+11 QUIT
RD1 ; READ REPORT FILE ^TMP AND PRINT REPORT
+1 SET PRCHKEY=$ORDER(^TMP($JOB,"R",PRCHRFLG,PRCHKEY))
if PRCHKEY=""
QUIT
SET X=^(PRCHKEY)
Begin DoDot:1
+2 SET PRCHOTCT=PRCHOTCT+$PIECE(X,U,2)
+3 SET PRCHLTOT=PRCHLTOT+$PIECE(X,U,3)
+4 SET PRCHTTOT=PRCHTTOT+$PIECE(X,U,4)
End DoDot:1
DO PRT1
+5 SET $PIECE(^TMP($JOB,"TOTAL"),U,2)=$PIECE(^TMP($JOB,"TOTAL"),U,2)+$PIECE(X,U,2)
SET $PIECE(^("TOTAL"),U,3)=$PIECE(^("TOTAL"),U,3)+$PIECE(X,U,3)
SET $PIECE(^("TOTAL"),U,4)=$PIECE(^("TOTAL"),U,4)+$PIECE(X,U,4)
+6 GOTO RD1
RD2 ; READ ^TMP FILE FOR REPORT BY P.O.NUMBER
+1 SET PRCHPONO=$ORDER(^TMP($JOB,"R",PRCHPONO))
if 'PRCHPONO
QUIT
SET X=^(PRCHPONO)
DO PRT2
+2 SET $PIECE(^TMP($JOB,"TOTAL"),U,2)=$PIECE(^TMP($JOB,"TOTAL"),U,2)+1
SET $PIECE(^("TOTAL"),U,3)=$PIECE(^("TOTAL"),U,3)+$PIECE(X,U,2)
+3 SET I=0
SET PRCHTOT=0
FOR K=1:1
SET I=$ORDER(^TMP($JOB,"R",PRCHPONO,"C",I))
if I=""
QUIT
SET X=^(I)
SET PRCHTOT=PRCHTOT+$PIECE(X,U,2)
DO PRT3
SET $PIECE(^("TOTAL"),U,4)=$PIECE(^TMP($JOB,"TOTAL"),U,4)+$PIECE(X,U,2)
+4 IF K>2
if PRCHDY>(IOSL-4)
DO HDR
WRITE ?57,"*TOTAL*",?66,$JUSTIFY(PRCHTOT,11,2),!
SET PRCHDY=PRCHDY+1
+5 WRITE !
SET PRCHDY=PRCHDY+1
GOTO RD2
PRT1 if PRCHDY>(IOSL-6)
DO HDR
WRITE PRCHKEY,?3,$PIECE(X,U,1)
IF $LENGTH($PIECE(X,U,1))>27
WRITE !
SET PRCHDY=PRCHDY+1
+1 WRITE ?30,$JUSTIFY($PIECE(X,U,2),8),?45,$JUSTIFY($PIECE(X,U,3),8),?66,$JUSTIFY($PIECE(X,U,4),11,2),!!
SET PRCHDY=PRCHDY+2
QUIT
PRT2 if PRCHDY>(IOSL-6)
DO HDR
WRITE $PIECE(PRCHPONO,"-",2),?12,"P.O.DATE:",$PIECE(X,U,1),?45,$JUSTIFY($PIECE(X,U,2),8),!
SET PRCHDY=PRCHDY+1
QUIT
PRT3 if PRCHDY>(IOSL-4)
DO HDR
if K=1
WRITE ?18,"CONTRACTS:"
WRITE ?30,I
+1 WRITE ?66,$JUSTIFY($PIECE(X,U,2),11,2),!
SET PRCHDY=PRCHDY+1
QUIT
PRTT ; PRINT REPORT GRAND TOTALS
+1 if PRCHDY>(IOSL-7)
DO HDR
WRITE !!!,?8,$PIECE(X,U,1)
+2 WRITE ?30,$JUSTIFY($PIECE(X,U,2),8),?45,$JUSTIFY($PIECE(X,U,3),8),?66,$JUSTIFY($PIECE(X,U,4),11,2),!
QUIT
HDR SET PRCHPAGE=PRCHPAGE+1
WRITE @IOF,"PROCUREMENT & ACCOUNTING TRANSACTIONS STATISTICS",?51,PRCHPDAT,?74,"PAGE ",PRCHPAGE,!
+1 WRITE "CONTROL POINTS/MONTH FOR STATION: ",PRC("SITE")
+2 WRITE " P.O.DATES "_PRCHPFR_" - "_PRCHPTO,!!
+3 WRITE ?45,"LINE/ITEM",!,N,?30,"P.O.COUNT",?47,"TOTAL",?65,"TOTAL AMOUNT",!
+4 FOR J=0:1:(IOM-2)
WRITE "-"
+5 WRITE !!
SET PRCHDY=6
QUIT
DEL2237 ; The option Delete 2237 Request from Worksheet file is being de-
+1 ; activated. It is no longer needed, as the 2237s with status of
+2 ; Returned to Service by PPM or by P&C no longer appear on the
+3 ; Outstanding 2237 Report. This Delete option was removing the
+4 ; 2237 from file 443,but leaving the approving e-sig info in file
+5 ; file 410, making inaccessable to A&MM and to the service.
+6 WRITE !!,"This option has been de-activated, as it is no longer needed."
+7 WRITE !,"Instead of deleting the 2237, return it to the service. 2237s"
+8 WRITE !,"returned to the service no longer appear on the Outstanding 2237"
+9 WRITE !,"Report."
+10 QUIT
