- 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 Mar 13, 2025@21:15:17 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
