PRCHRPL1.m

PRCHRPL1 ;SF/TKW,WISC/CLH-PUBLIC LAW 100-322 LOCAL PROC--CONTINUED ;11-4-92/16:41

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

EN S (PRCHTOT,PRCHRC)=0 F I=1:1 S PRCHRC=$O(^TMP($J,"RC",PRCHRC)) Q:'PRCHRC  S PRCHTOT=PRCHTOT+^(PRCHRC)

 D HDR,RD1 W ?132,"___________",!!,?120,"**TOTAL**",?132,$J(PRCHTOT,11,2),!,$C(13) Q  ;,@IOF  ;REMOVE IF PROBLEM WITH KERNEL V6.5

RD1 ;PRINT DETAILED REPORT

 S PRCHRC=0 F ZZJ=1:1 D:PRCHRC RC S PRCHRC=$O(^TMP($J,"R",PRCHRC)) Q:'PRCHRC  D:PRCHDY>55 HDR W !!,?3,"REASON: (",PRCHRC,") ",$P(^PRC(443.8,PRCHRC,0),"^",2),!! S PRCHDY=PRCHDY+8 D RD2

 Q

RD2 S PRCHFSC=0 F ZZI=0:0 D:PRCHFSC FSC S PRCHFSC=$O(^TMP($J,"R",PRCHRC,PRCHFSC)) Q:'PRCHFSC  S PRCHDESC="" F J=0:0 S PRCHDESC=$O(^TMP($J,"R",PRCHRC,PRCHFSC,PRCHDESC)) Q:PRCHDESC=""  D RD3

 Q

RD3 S PRCHV="" F K=0:0 S PRCHV=$O(^TMP($J,"R",PRCHRC,PRCHFSC,PRCHDESC,PRCHV)) Q:PRCHV=""  F L=0:0 S L=$O(^TMP($J,"R",PRCHRC,PRCHFSC,PRCHDESC,PRCHV,L)) Q:'L  S X=^(L) I "2B"[$P(X,U,9) D PRT

 Q

RC W ?90,"SUB TOTAL FOR REASON CODE: ",PRCHRC,?132,$J(^TMP($J,"RC",PRCHRC),11,2),! S PRCHDY=PRCHDY+1

 Q

FSC W !,?132,"___________",!,?90,"SUB TOTAL FOR FSC:",?132,$J(^TMP($J,"RC","FSC",PRCHRC,PRCHFSC),11,2),! S PRCHDY=PRCHDY+3

 Q

PRT D:PRCHDY>60 HDR W !,PRCHDESC,?31,PRCHFSC,?37,$P(X,U,2),?52,$P(X,U,9),?56,$P(X,U,3),?72,PRCHV,?104,$P(X,U,1),?113,$J($P(X,U,4),6)

 W ?121,$J($P(X,U,5),9,2),?132,$J($P(X,U,6),11,2),?145,$P(X,U,7)

 S PRCHDY=PRCHDY+1 Q

HDR S PRCHPAGE=PRCHPAGE+1 W @IOF W "P.L. 100-322 LOCAL PROCUREMENT REASON REPORT",?123,PRCHPDAT,?146,"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 "DESCRIPTION",?31,"FSC",?37,"N.I.I.N",?49,"SOURCE",?57,"NDC",?72,"VENDOR",?104,"P.O.NO.",?112,"QTY.REC.",?121,"UNIT COST",?133,"TOTAL COST",?145,"FCP",!

 F I=0:1:(IOM-2) W "-"

 W !! S PRCHDY=7 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCHRPL1   1990     printed  Feb 18, 2025@23:36:49                                                                                                                                                                                                    Page 2

PRCHRPL1  ;SF/TKW,WISC/CLH-PUBLIC LAW 100-322 LOCAL PROC--CONTINUED ;11-4-92/16:41

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

EN         SET (PRCHTOT,PRCHRC)=0

           FOR I=1:1

               SET PRCHRC=$ORDER(^TMP($JOB,"RC",PRCHRC))

               if 'PRCHRC

                   QUIT 

               SET PRCHTOT=PRCHTOT+^(PRCHRC)

 +1       ;,@IOF  ;REMOVE IF PROBLEM WITH KERNEL V6.5

           DO HDR

           DO RD1

           WRITE ?132,"___________",!!,?120,"**TOTAL**",?132,$JUSTIFY(PRCHTOT,11,2),!,$CHAR(13)

           QUIT 

RD1       ;PRINT DETAILED REPORT

 +1        SET PRCHRC=0

           FOR ZZJ=1:1

               if PRCHRC

                   DO RC

               SET PRCHRC=$ORDER(^TMP($JOB,"R",PRCHRC))

               if 'PRCHRC

                   QUIT 

               if PRCHDY>55

                   DO HDR

               WRITE !!,?3,"REASON: (",PRCHRC,") ",$PIECE(^PRC(443.8,PRCHRC,0),"^",2),!!

               SET PRCHDY=PRCHDY+8

               DO RD2

 +2        QUIT 

RD2        SET PRCHFSC=0

           FOR ZZI=0:0

               if PRCHFSC

                   DO FSC

               SET PRCHFSC=$ORDER(^TMP($JOB,"R",PRCHRC,PRCHFSC))

               if 'PRCHFSC

                   QUIT 

               SET PRCHDESC=""

               FOR J=0:0

                   SET PRCHDESC=$ORDER(^TMP($JOB,"R",PRCHRC,PRCHFSC,PRCHDESC))

                   if PRCHDESC=""

                       QUIT 

                   DO RD3

 +1        QUIT 

RD3        SET PRCHV=""

           FOR K=0:0

               SET PRCHV=$ORDER(^TMP($JOB,"R",PRCHRC,PRCHFSC,PRCHDESC,PRCHV))

               if PRCHV=""

                   QUIT 

               FOR L=0:0

                   SET L=$ORDER(^TMP($JOB,"R",PRCHRC,PRCHFSC,PRCHDESC,PRCHV,L))

                   if 'L

                       QUIT 

                   SET X=^(L)

                   IF "2B"[$PIECE(X,U,9)

                       DO PRT

 +1        QUIT 

RC         WRITE ?90,"SUB TOTAL FOR REASON CODE: ",PRCHRC,?132,$JUSTIFY(^TMP($JOB,"RC",PRCHRC),11,2),!

           SET PRCHDY=PRCHDY+1

 +1        QUIT 

FSC        WRITE !,?132,"___________",!,?90,"SUB TOTAL FOR FSC:",?132,$JUSTIFY(^TMP($JOB,"RC","FSC",PRCHRC,PRCHFSC),11,2),!

           SET PRCHDY=PRCHDY+3

 +1        QUIT 

PRT        if PRCHDY>60

               DO HDR

           WRITE !,PRCHDESC,?31,PRCHFSC,?37,$PIECE(X,U,2),?52,$PIECE(X,U,9),?56,$PIECE(X,U,3),?72,PRCHV,?104,$PIECE(X,U,1),?113,$JUSTIFY($PIECE(X,U,4),6)

 +1        WRITE ?121,$JUSTIFY($PIECE(X,U,5),9,2),?132,$JUSTIFY($PIECE(X,U,6),11,2),?145,$PIECE(X,U,7)

 +2        SET PRCHDY=PRCHDY+1

           QUIT 

HDR        SET PRCHPAGE=PRCHPAGE+1

           WRITE @IOF

           WRITE "P.L. 100-322 LOCAL PROCUREMENT REASON REPORT",?123,PRCHPDAT,?146,"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 "DESCRIPTION",?31,"FSC",?37,"N.I.I.N",?49,"SOURCE",?57,"NDC",?72,"VENDOR",?104,"P.O.NO.",?112,"QTY.REC.",?121,"UNIT COST",?133,"TOTAL COST",?145,"FCP",!

 +4        FOR I=0:1:(IOM-2)

               WRITE "-"

 +5        WRITE !!

           SET PRCHDY=7

           QUIT