PRCHRPTA.m

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 ---PRCHRPTA   3726     printed  Mar 13, 2025@21:15:24                                                                                                                                                                                                    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