PRCPRLAS.m

PRCPRLAS ;WISC/RFJ-last procurement source for item report          ;22 Jul 91

 ;;5.1;IFCAP;;Oct 20, 2000

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

 D ^PRCPUSEL Q:'$G(PRCP("I"))

 N %,PRCPINV,X W !?2,"START WITH NSN: FIRST// @    <<-- ENTER '@' TO PRINT ITEMS WITHOUT A NSN"

 S PRCPINV=$$INVNAME^PRCPUX1(PRCP("I")),DIC="^PRCP(445,",L=0,FLDS="[PRCP REPORT:LAST SOURCE]",BY=".01,1,@.01:5;""NSN""",FR=PRCPINV_",?",TO=PRCPINV_",?",DIOEND="D END^PRCPUREP" D EN1^DIP Q

 ;

GETLAS ;called from print template PRCP REPORT:LAST SOURCE

 ;gets last procurement source for FCP

 I '$G(PRCP("I"))!('$D(PRC("SITE"))) Q

 N %,D,L,PRCPD,PRCPFCP,PRCPLIDA,PRCPQ,V,V1

 S PRCPFCP=+$$FCPDA^PRCPUX1(PRC("SITE"),PRCP("I"))

 S (%,D,L)=0 F  S %=$O(^PRC(441,D1,4,PRCPFCP,1,%)) Q:%=""  S X=$P($G(^PRC(442,%,1)),"^",15) I X>D S D=X,L=%

 I D=0 D  Q

 .   S V=+$P($G(^PRC(441,D1,0)),"^",4),V1=$P($G(^PRC(440,V,0)),"^") Q:V1=""

 .   W !?4,"LAST VENDOR",?24,"[#V]",!?4,$E(V1,1,18),?24,"[#",V,"]"

 S V=$P($G(^PRC(442,L,1)),"^"),V1=$P($G(^PRC(440,V,0)),"^")

 S PRCPLIDA=$O(^PRC(442,L,2,"AE",D1,0)) Q:PRCPLIDA=""  S PRCPD=$G(^PRC(442,L,2,PRCPLIDA,0)),(%,PRCPQ)=0 F  S %=$O(^PRC(442,L,2,PRCPLIDA,3,%)) Q:%=""!(%'?.N)  S PRCPQ=$P($G(^(%,0)),"^",2)

 W !?4,"LAST VENDOR",?24,"[#V]",?33,"P.O. #",?41,"UNIT per RECPT",?58,"UNIT PRICE",?72,"QTY RECD",!?4,$E(V1,1,18),?24,"[#",V,"]",?33,$P($P($G(^PRC(442,L,0)),"^"),"-",2)

 W ?41,$J($$UNITVAL^PRCPUX1($P(PRCPD,"^",12),$P(PRCPD,"^",3)," per "),11),?58,$J($P(PRCPD,"^",9),10,3),?70,$J(PRCPQ,10) Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCPRLAS   1543     printed  Apr 09, 2024@21:01:17                                                                                                                                                                                                    Page 2

PRCPRLAS  ;WISC/RFJ-last procurement source for item report          ;22 Jul 91

 +1       ;;5.1;IFCAP;;Oct 20, 2000

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

 +3        DO ^PRCPUSEL

           if '$GET(PRCP("I"))

               QUIT 

 +4        NEW %,PRCPINV,X

           WRITE !?2,"START WITH NSN: FIRST// @    <<-- ENTER '@' TO PRINT ITEMS WITHOUT A NSN"

 +5        SET PRCPINV=$$INVNAME^PRCPUX1(PRCP("I"))

           SET DIC="^PRCP(445,"

           SET L=0

           SET FLDS="[PRCP REPORT:LAST SOURCE]"

           SET BY=".01,1,@.01:5;""NSN"""

           SET FR=PRCPINV_",?"

           SET TO=PRCPINV_",?"

           SET DIOEND="D END^PRCPUREP"

           DO EN1^DIP

           QUIT 

 +6       ;

GETLAS    ;called from print template PRCP REPORT:LAST SOURCE

 +1       ;gets last procurement source for FCP

 +2        IF '$GET(PRCP("I"))!('$DATA(PRC("SITE")))

               QUIT 

 +3        NEW %,D,L,PRCPD,PRCPFCP,PRCPLIDA,PRCPQ,V,V1

 +4        SET PRCPFCP=+$$FCPDA^PRCPUX1(PRC("SITE"),PRCP("I"))

 +5        SET (%,D,L)=0

           FOR 

               SET %=$ORDER(^PRC(441,D1,4,PRCPFCP,1,%))

               if %=""

                   QUIT 

               SET X=$PIECE($GET(^PRC(442,%,1)),"^",15)

               IF X>D

                   SET D=X

                   SET L=%

 +6        IF D=0

               Begin DoDot:1

 +7                SET V=+$PIECE($GET(^PRC(441,D1,0)),"^",4)

                   SET V1=$PIECE($GET(^PRC(440,V,0)),"^")

                   if V1=""

                       QUIT 

 +8                WRITE !?4,"LAST VENDOR",?24,"[#V]",!?4,$EXTRACT(V1,1,18),?24,"[#",V,"]"

               End DoDot:1

               QUIT 

 +9        SET V=$PIECE($GET(^PRC(442,L,1)),"^")

           SET V1=$PIECE($GET(^PRC(440,V,0)),"^")

 +10       SET PRCPLIDA=$ORDER(^PRC(442,L,2,"AE",D1,0))

           if PRCPLIDA=""

               QUIT 

           SET PRCPD=$GET(^PRC(442,L,2,PRCPLIDA,0))

           SET (%,PRCPQ)=0

           FOR 

               SET %=$ORDER(^PRC(442,L,2,PRCPLIDA,3,%))

               if %=""!(%'?.N)

                   QUIT 

               SET PRCPQ=$PIECE($GET(^(%,0)),"^",2)

 +11       WRITE !?4,"LAST VENDOR",?24,"[#V]",?33,"P.O. #",?41,"UNIT per RECPT",?58,"UNIT PRICE",?72,"QTY RECD",!?4,$EXTRACT(V1,1,18),?24,"[#",V,"]",?33,$PIECE($PIECE($GET(^PRC(442,L,0)),"^"),"-",2)

 +12       WRITE ?41,$JUSTIFY($$UNITVAL^PRCPUX1($PIECE(PRCPD,"^",12),$PIECE(PRCPD,"^",3)," per "),11),?58,$JUSTIFY($PIECE(PRCPD,"^",9),10,3),?70,$JUSTIFY(PRCPQ,10)

           QUIT