- PRCPUTIL ;(WIRMFO)/DXH,DGL - GIP utilities ; 10.7.99
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- QTY ; utility to maintain the quantities for selected Inventory Points
- ; as they are replenished via receipts against a Purchase Order
- ; line item which they are sharing with other Inventory Points
- ; PRC*5*197
- ; da(3)=>p.o.
- ; da(2)=>item
- ; da(1)=>date received
- ; da=>inventory point
- N QTY,PRCP,PRCPDA
- S PRCP("IP")=$P(^PRC(442,DA(3),2,DA(2),3,DA(1),1,DA,0),U)
- S (QTY,PRCPDA)=0 F S PRCPDA=$O(^PRC(442,DA(3),2,DA(2),3,PRCPDA)) Q:'PRCPDA S PRCP("DT")=$O(^(PRCPDA,1,"B",PRCP("IP"),0)) D:PRCP("DT")
- . S QTY=QTY+$P(^PRC(442,DA(3),2,DA(2),3,PRCPDA,1,PRCP("DT"),0),U,2)
- S PRCP("LP")=$O(^PRC(442,DA(3),2,DA(2),5,"B",PRCP("IP"),0)) S:PRCP("LP") $P(^PRC(442,DA(3),2,DA(2),5,PRCP("LP"),0),U,4)=QTY
- Q
- ;
- DISPIP(FCPDA) ; display inv pts for FCP
- I '$D(^PRC(420,+$G(PRC("SITE")),1,+FCPDA,7,0)) Q
- N I
- S I=0
- F S I=$O(^PRC(420,"AF",+$G(PRC("SITE")),+FCPDA,I)) Q:'I W !,?10,$P($G(^PRCP(445,I,0)),U,1)
- Q
- ;
- DISPFCP(IP) ; display FCP for inv pt
- Q:'$O(^PRC(420,"AE",+PRC("SITE"),IP,0))
- N FCP
- S (FCP,CNT)=0
- W !!,"To make a change, first select the existing control point and 'unlink' it.",!,"Then select a new one if you want to."
- W !!,"Current selection:"
- F S FCP=$O(^PRC(420,"AE",+PRC("SITE"),IP,FCP)) Q:'FCP W:CNT ! W ?20,$P($G(^PRC(420,+PRC("SITE"),1,FCP,0)),U) S CNT=CNT+1
- Q
- ;
- ;PRCPUTIL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUTIL 1519 printed Jan 18, 2025@03:17:36 Page 2
- PRCPUTIL ;(WIRMFO)/DXH,DGL - GIP utilities ; 10.7.99
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- QTY ; utility to maintain the quantities for selected Inventory Points
- +1 ; as they are replenished via receipts against a Purchase Order
- +2 ; line item which they are sharing with other Inventory Points
- +3 ; PRC*5*197
- +4 ; da(3)=>p.o.
- +5 ; da(2)=>item
- +6 ; da(1)=>date received
- +7 ; da=>inventory point
- +8 NEW QTY,PRCP,PRCPDA
- +9 SET PRCP("IP")=$PIECE(^PRC(442,DA(3),2,DA(2),3,DA(1),1,DA,0),U)
- +10 SET (QTY,PRCPDA)=0
- FOR
- SET PRCPDA=$ORDER(^PRC(442,DA(3),2,DA(2),3,PRCPDA))
- if 'PRCPDA
- QUIT
- SET PRCP("DT")=$ORDER(^(PRCPDA,1,"B",PRCP("IP"),0))
- if PRCP("DT")
- Begin DoDot:1
- +11 SET QTY=QTY+$PIECE(^PRC(442,DA(3),2,DA(2),3,PRCPDA,1,PRCP("DT"),0),U,2)
- End DoDot:1
- +12 SET PRCP("LP")=$ORDER(^PRC(442,DA(3),2,DA(2),5,"B",PRCP("IP"),0))
- if PRCP("LP")
- SET $PIECE(^PRC(442,DA(3),2,DA(2),5,PRCP("LP"),0),U,4)=QTY
- +13 QUIT
- +14 ;
- DISPIP(FCPDA) ; display inv pts for FCP
- +1 IF '$DATA(^PRC(420,+$GET(PRC("SITE")),1,+FCPDA,7,0))
- QUIT
- +2 NEW I
- +3 SET I=0
- +4 FOR
- SET I=$ORDER(^PRC(420,"AF",+$GET(PRC("SITE")),+FCPDA,I))
- if 'I
- QUIT
- WRITE !,?10,$PIECE($GET(^PRCP(445,I,0)),U,1)
- +5 QUIT
- +6 ;
- DISPFCP(IP) ; display FCP for inv pt
- +1 if '$ORDER(^PRC(420,"AE",+PRC("SITE"),IP,0))
- QUIT
- +2 NEW FCP
- +3 SET (FCP,CNT)=0
- +4 WRITE !!,"To make a change, first select the existing control point and 'unlink' it.",!,"Then select a new one if you want to."
- +5 WRITE !!,"Current selection:"
- +6 FOR
- SET FCP=$ORDER(^PRC(420,"AE",+PRC("SITE"),IP,FCP))
- if 'FCP
- QUIT
- if CNT
- WRITE !
- WRITE ?20,$PIECE($GET(^PRC(420,+PRC("SITE"),1,FCP,0)),U)
- SET CNT=CNT+1
- +7 QUIT
- +8 ;
- +9 ;PRCPUTIL