- 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 ---[H[J[2J[HPRCPRLAS 1543 printed Feb 18, 2025@23:41:29 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
