PRCHRPTA ;WISC/TKW-PUBLIC LAW 100-322 REPORT--CONTINUED ;4/13/93 11:15
V ;;5.1;IFCAP;*89*;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN S (PRCHTOT,PRCHTOTD)=0 D RD1 W $C(13) Q ;W ?132,"___________",!!,?120,"**TOTAL**",?132,$J(PRCHTOT,11,2),!,$C(13)
Q
;
RD1 ;PRINT DETAILED REPORT
S PRCHFSC="" F J=1:1 S PRCHFSC=$O(^TMP($J,"R",PRCHFSC)) G:PRCHFSC="" Q D:PRCHDY>55 HDR S PRCHDY=PRCHDY+1 D RD2
Q
;
RD2 S PRCHDESC=0 F S PRCHDESC=$O(^TMP($J,"R",PRCHFSC,PRCHDESC)) Q:PRCHDESC="" D RD3
Q
;
RD3 S (PRCHV,L)="" F S PRCHV=$O(^TMP($J,"R",PRCHFSC,PRCHDESC,PRCHV)) Q:PRCHV="" F S L=$O(^TMP($J,"R",PRCHFSC,PRCHDESC,PRCHV,L)) Q:L="" S PRCHSRC="" D
. F S PRCHSRC=$O(^TMP($J,"R",PRCHFSC,PRCHDESC,PRCHV,L,PRCHSRC)) Q:PRCHSRC="" S X=^(PRCHSRC) I "2B"[$P(X,U,9) S AVRG=$S($P(X,U,4)'=0:($P(X,U,6))/($P(X,U,4)),1:0) S PRCHTOTD=PRCHTOTD+$P(X,U,6) D PRT
Q
;
PRT D:PRCHDY>60 HDR W PRCHDESC,?32,$J($P(X,U,12),5),?39,PRCHFSC,?46,$S($P(X,U,2)'=0:$P(X,U,2),1:"-"),?61,$J($FN($P(X,U,4),","),7),?73,$S(PRCHV'=0:PRCHV,1:"-")
W ?77,$J($P(X,U,6),11,2),?90,$J($P(X,U,10),9,2),?101,$J($P(X,U,11),9,2),?112,$J(AVRG,9,2),!
S PRCHTOT=PRCHTOT+$P(X,U,6),PRCHDY=PRCHDY+1
Q
;
HDR S PRCHPAGE=PRCHPAGE+1 W @IOF,?55,"P.L. 100-322 Local Procurement",!,?56,"Aggregated Item Detail Report",!,?108,$P(PRCHPDAT,"@"),?122,"PAGE ",PRCHPAGE,!
W ?4,"STATION: "_PRC("SITE")_"-"_PRCHSITE,!,"Dates Received: "_PRCHFT_" FSC CODES: " F I=0:0 S I=$O(^TMP($J,"FSCG",I)) Q:'I W I_" "
W " Non-Expendable Purchases NOT Included",!
W ?33,"ITEM",?63,"TOTAL",?82,"TOTAL",?96,"LOW",?106,"HIGH",?115,"AVERAGE",!
W "DESCRIPTION",?32,"NUMBER",?40,"FSC",?48,"N.I.I.N",?62,"QUANTITY",?72,"UNIT",?81,"DOLLARS",?95,"COST",?106,"COST",?116,"COST",!
F I=0:1:(IOM-2) W "-"
W !! S PRCHDY=7
Q
;
EN2 ;PRINT SUMMARY TOTALS
D HDR2,RDS
Q
;
RDS S (PRCHFSCG,PRCHGT,PRCHT)="" F PRCHFSC=0:0 S PRCHFSC=$O(^TMP($J,"FSC",PRCHFSC)) Q:'PRCHFSC D:$E(PRCHFSC,1,2)'=PRCHFSCG GT S X=^TMP($J,"FSC",PRCHFSC) D ACM W PRCHFSC_" "_$P(^TMP($J,"FSC",PRCHFSC),U,1) D PRT2
S:PRCHFSCG]"" PRCHFSCG="END" D GT,T
Q
;
PRT2 S PRCHTOT=+$P(X,U,2)
W ?41,$J(PRCHTOT,11,2) I PRCHTOT W ?60,$J($P(X,U,3),11,2),?79,$J((($P(X,U,3)/PRCHTOT)*100),6,2),?91,$J($P(X,U,4),11,2),?110,$J((($P(X,U,4)/PRCHTOT)*100),6,2),?122,$J($P(X,U,5),11,2),?141,$J((($P(X,U,5)/PRCHTOT)*100),6,2)
W ! S PRCHDY=PRCHDY+1
Q
;
GT ;PRINT GROUP SUB-TOTALS
D:PRCHDY>55 HDR2 I PRCHFSCG="" G GT1
W ?2,"SUB-TOTAL" S X=PRCHGT D PRT2 Q:PRCHFSCG="END"
;
GT1 S PRCHGT="",PRCHFSCG=$E(PRCHFSC,1,2)
W !,?2,"FSC GROUP: "_$S($D(^TMP($J,"FSCG",PRCHFSCG)):^(PRCHFSCG),1:"**INVALID**"),! S PRCHDY=PRCHDY+2
Q
;
ACM F I=2:1:5 S $P(PRCHGT,U,I)=$P(PRCHGT,U,I)+$P(X,U,I),$P(PRCHT,U,I)=$P(PRCHT,U,I)+$P(X,U,I)
Q
;
T S I="___________" W ?41,I,?60,I,?79,$E(I,1,6),?91,I,?110,$E(I,1,6),?122,I,?141,$E(I,1,6),!
S PRCHDY=PRCHDY+1,X=PRCHT W ?1,"* TOTAL *" D PRT2
Q
;
HDR2 S PRCHPAGE=PRCHPAGE+1 W @IOF,?55,"P.L. 100-322 SUMMARY TOTALS REPORT",?108,$P(PRCHPDAT,"@"),?122,"PAGE ",PRCHPAGE,!
W ?4,"STATION: "_PRC("SITE")_"-"_PRCHSITE,!,"Dates Received: "_PRCHFT_" FSC CODES: " F I=0:0 S I=$O(^TMP($J,"FSCG",I)) Q:'I W I_" "
W " Non-Expendable Purchases NOT Included",!!
W ?63,"ALL OPEN",?81,"% OF",?94,"OPEN MKT",?112,"% OF",?123,"OPEN MARKET",?143,"% OF",!
W "FSC",?47,"TOTAL",?65,"MARKET",?80,"TOTAL",?93,"EMERGENCY",?111,"TOTAL",?120,"LESS EMERGENCY",?142,"TOTAL",!
F J=0:1:(IOM-2) W "-"
W !! S PRCHDY=8
Q
;
NONE ; perform this if no records were gathered
D HDR
W !,"No records matched the selected criteria.",!
Q
;
Q D:PRCHDY>55 HDR S PRCHDY=PRCHDY+1 W ?77,"___________",!," * TOTAL *",?80,PRCHTOTD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPTA 3726 printed Nov 22, 2024@17:20:42 Page 2
PRCHRPTA ;WISC/TKW-PUBLIC LAW 100-322 REPORT--CONTINUED ;4/13/93 11:15
V ;;5.1;IFCAP;*89*;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
EN ;W ?132,"___________",!!,?120,"**TOTAL**",?132,$J(PRCHTOT,11,2),!,$C(13)
SET (PRCHTOT,PRCHTOTD)=0
DO RD1
WRITE $CHAR(13)
QUIT
+1 QUIT
+2 ;
RD1 ;PRINT DETAILED REPORT
+1 SET PRCHFSC=""
FOR J=1:1
SET PRCHFSC=$ORDER(^TMP($JOB,"R",PRCHFSC))
if PRCHFSC=""
GOTO Q
if PRCHDY>55
DO HDR
SET PRCHDY=PRCHDY+1
DO RD2
+2 QUIT
+3 ;
RD2 SET PRCHDESC=0
FOR
SET PRCHDESC=$ORDER(^TMP($JOB,"R",PRCHFSC,PRCHDESC))
if PRCHDESC=""
QUIT
DO RD3
+1 QUIT
+2 ;
RD3 SET (PRCHV,L)=""
FOR
SET PRCHV=$ORDER(^TMP($JOB,"R",PRCHFSC,PRCHDESC,PRCHV))
if PRCHV=""
QUIT
FOR
SET L=$ORDER(^TMP($JOB,"R",PRCHFSC,PRCHDESC,PRCHV,L))
if L=""
QUIT
SET PRCHSRC=""
Begin DoDot:1
+1 FOR
SET PRCHSRC=$ORDER(^TMP($JOB,"R",PRCHFSC,PRCHDESC,PRCHV,L,PRCHSRC))
if PRCHSRC=""
QUIT
SET X=^(PRCHSRC)
IF "2B"[$PIECE(X,U,9)
SET AVRG=$SELECT($PIECE(X,U,4)'=0:($PIECE(X,U,6))/($PIECE(X,U,4)),1:0)
SET PRCHTOTD=PRCHTOTD+$PIECE(X,U,6)
DO PRT
End DoDot:1
+2 QUIT
+3 ;
PRT if PRCHDY>60
DO HDR
WRITE PRCHDESC,?32,$JUSTIFY($PIECE(X,U,12),5),?39,PRCHFSC,?46,$SELECT($PIECE(X,U,2)'=0:$PIECE(X,U,2),1:"-"),?61,$JUSTIFY($FNUMBER($PIECE(X,U,4),","),7),?73,$SELECT(PRCHV'=0:PRCHV,1:"-")
+1 WRITE ?77,$JUSTIFY($PIECE(X,U,6),11,2),?90,$JUSTIFY($PIECE(X,U,10),9,2),?101,$JUSTIFY($PIECE(X,U,11),9,2),?112,$JUSTIFY(AVRG,9,2),!
+2 SET PRCHTOT=PRCHTOT+$PIECE(X,U,6)
SET PRCHDY=PRCHDY+1
+3 QUIT
+4 ;
HDR SET PRCHPAGE=PRCHPAGE+1
WRITE @IOF,?55,"P.L. 100-322 Local Procurement",!,?56,"Aggregated Item Detail Report",!,?108,$PIECE(PRCHPDAT,"@"),?122,"PAGE ",PRCHPAGE,!
+1 WRITE ?4,"STATION: "_PRC("SITE")_"-"_PRCHSITE,!,"Dates Received: "_PRCHFT_" FSC CODES: "
FOR I=0:0
SET I=$ORDER(^TMP($JOB,"FSCG",I))
if 'I
QUIT
WRITE I_" "
+2 WRITE " Non-Expendable Purchases NOT Included",!
+3 WRITE ?33,"ITEM",?63,"TOTAL",?82,"TOTAL",?96,"LOW",?106,"HIGH",?115,"AVERAGE",!
+4 WRITE "DESCRIPTION",?32,"NUMBER",?40,"FSC",?48,"N.I.I.N",?62,"QUANTITY",?72,"UNIT",?81,"DOLLARS",?95,"COST",?106,"COST",?116,"COST",!
+5 FOR I=0:1:(IOM-2)
WRITE "-"
+6 WRITE !!
SET PRCHDY=7
+7 QUIT
+8 ;
EN2 ;PRINT SUMMARY TOTALS
+1 DO HDR2
DO RDS
+2 QUIT
+3 ;
RDS SET (PRCHFSCG,PRCHGT,PRCHT)=""
FOR PRCHFSC=0:0
SET PRCHFSC=$ORDER(^TMP($JOB,"FSC",PRCHFSC))
if 'PRCHFSC
QUIT
if $EXTRACT(PRCHFSC,1,2)'=PRCHFSCG
DO GT
SET X=^TMP($JOB,"FSC",PRCHFSC)
DO ACM
WRITE PRCHFSC_" "_$PIECE(^TMP($JOB,"FSC",PRCHFSC),U,1)
DO PRT2
+1 if PRCHFSCG]""
SET PRCHFSCG="END"
DO GT
DO T
+2 QUIT
+3 ;
PRT2 SET PRCHTOT=+$PIECE(X,U,2)
+1 WRITE ?41,$JUSTIFY(PRCHTOT,11,2)
IF PRCHTOT
WRITE ?60,$JUSTIFY($PIECE(X,U,3),11,2),?79,$JUSTIFY((($PIECE(X,U,3)/PRCHTOT)*100),6,2),?91,$JUSTIFY($PIECE(X,U,4),11,2),?110,$JUSTIFY((($PIECE(X,U,4)/PRCHTOT)*100),6,2),?122,$JUSTIFY($PIECE(X,U,5),11,2),?141,$JUSTIFY((($PIECE(X,U,5)/PRCHTOT
)*100),6,2)
+2 WRITE !
SET PRCHDY=PRCHDY+1
+3 QUIT
+4 ;
GT ;PRINT GROUP SUB-TOTALS
+1 if PRCHDY>55
DO HDR2
IF PRCHFSCG=""
GOTO GT1
+2 WRITE ?2,"SUB-TOTAL"
SET X=PRCHGT
DO PRT2
if PRCHFSCG="END"
QUIT
+3 ;
GT1 SET PRCHGT=""
SET PRCHFSCG=$EXTRACT(PRCHFSC,1,2)
+1 WRITE !,?2,"FSC GROUP: "_$SELECT($DATA(^TMP($JOB,"FSCG",PRCHFSCG)):^(PRCHFSCG),1:"**INVALID**"),!
SET PRCHDY=PRCHDY+2
+2 QUIT
+3 ;
ACM FOR I=2:1:5
SET $PIECE(PRCHGT,U,I)=$PIECE(PRCHGT,U,I)+$PIECE(X,U,I)
SET $PIECE(PRCHT,U,I)=$PIECE(PRCHT,U,I)+$PIECE(X,U,I)
+1 QUIT
+2 ;
T SET I="___________"
WRITE ?41,I,?60,I,?79,$EXTRACT(I,1,6),?91,I,?110,$EXTRACT(I,1,6),?122,I,?141,$EXTRACT(I,1,6),!
+1 SET PRCHDY=PRCHDY+1
SET X=PRCHT
WRITE ?1,"* TOTAL *"
DO PRT2
+2 QUIT
+3 ;
HDR2 SET PRCHPAGE=PRCHPAGE+1
WRITE @IOF,?55,"P.L. 100-322 SUMMARY TOTALS REPORT",?108,$PIECE(PRCHPDAT,"@"),?122,"PAGE ",PRCHPAGE,!
+1 WRITE ?4,"STATION: "_PRC("SITE")_"-"_PRCHSITE,!,"Dates Received: "_PRCHFT_" FSC CODES: "
FOR I=0:0
SET I=$ORDER(^TMP($JOB,"FSCG",I))
if 'I
QUIT
WRITE I_" "
+2 WRITE " Non-Expendable Purchases NOT Included",!!
+3 WRITE ?63,"ALL OPEN",?81,"% OF",?94,"OPEN MKT",?112,"% OF",?123,"OPEN MARKET",?143,"% OF",!
+4 WRITE "FSC",?47,"TOTAL",?65,"MARKET",?80,"TOTAL",?93,"EMERGENCY",?111,"TOTAL",?120,"LESS EMERGENCY",?142,"TOTAL",!
+5 FOR J=0:1:(IOM-2)
WRITE "-"
+6 WRITE !!
SET PRCHDY=8
+7 QUIT
+8 ;
NONE ; perform this if no records were gathered
+1 DO HDR
+2 WRITE !,"No records matched the selected criteria.",!
+3 QUIT
+4 ;
Q if PRCHDY>55
DO HDR
SET PRCHDY=PRCHDY+1
WRITE ?77,"___________",!," * TOTAL *",?80,PRCHTOTD
+1 QUIT
