Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPRPK1

PRCPRPK1.m

Go to the documentation of this file.
  1. PRCPRPK1 ;WISC/RFJ-packaging discrepancy report (find errors) ;04 Oct 91
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. PROCESS ; start finding errors
  1. N ITEMDA,ITEMDATA,MANNAME,MANSRCE,NSN,OUTSDATA,OUTST,OUTSTERR,OUTSUNIT,PSDA,PSDATA,PSUNIT,TRANDA,TRANUNIT,UNITISS,VENDA,VENDATA,VENUNIT
  1. K ^TMP($J,"PRCPRPKG")
  1. S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA I $G(PRCPALLI)!($D(^TMP($J,"PRCPURS4",ITEMDA))) D
  1. . I '$$PURCHASE^PRCPU441(ITEMDA) Q ; not purchasable
  1. . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),UNITISS=$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),NSN=$$NSN^PRCPUX1(ITEMDA)
  1. . I NSN="" S NSN=" " I PRCP("DPTYPE")="W" S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,15)=""
  1. . I PRCP("DPTYPE")="W",$P(ITEMDATA,"^",5)'=$P($G(^PRC(441,ITEMDA,3)),"^",8) S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,16)=$$UNITCODE^PRCPUX1($P($G(^PRC(441,ITEMDA,3)),"^",8))_"^"_$$UNITCODE^PRCPUX1($P(ITEMDATA,"^",5))
  1. . S MANSRCE=$P($G(^PRC(441,ITEMDA,0)),"^",8)_";PRC(440,",MANNAME=""
  1. . I 'MANSRCE S MANSRCE=""
  1. . E S MANNAME=$E($$VENNAME^PRCPUX1(MANSRCE),1,15)_"#"_+MANSRCE
  1. . ; mandatory source defined
  1. . ; only check mandatory source vendor data (except for whse)
  1. . I MANSRCE D
  1. . . S VENDATA=$G(^PRC(441,ITEMDA,2,+MANSRCE,0)),VENUNIT=$$UNITVAL^PRCPUX1($P(VENDATA,"^",8),$P(VENDATA,"^",7),"/")
  1. . . I VENDATA="" S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,1)=MANNAME
  1. . . I VENUNIT["?" S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,2)=VENUNIT_"^"_MANNAME
  1. . . ; for warehouse, set mandatory source=null and check vendors
  1. . . I PRCP("DPTYPE")="W",+MANSRCE=+WHSESRCE D S MANSRCE="" Q
  1. . . . I UNITISS'=VENUNIT S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,3)=UNITISS_"^"_VENUNIT_"^"_MANNAME
  1. . . I PRCP("DPTYPE")="W" Q
  1. . . ; for primaries
  1. . . I $P(ITEMDATA,"^",12)'=MANSRCE S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,4)=$P(ITEMDATA,"^",12)_"^"_MANNAME
  1. . . S PSDATA=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,MANSRCE,1) I 'PSDATA S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,5)=MANNAME
  1. . . S PSUNIT=$$UNITVAL^PRCPUX1($P(PSDATA,"^",3),$P(PSDATA,"^",2),"/")
  1. . . I PSUNIT'=VENUNIT S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,6)=PSUNIT_"^"_MANNAME_"^"_VENUNIT
  1. . ;
  1. . ;mandatory source is not defined
  1. . I 'MANSRCE D
  1. . . ; loop vendors and check item master file for errors
  1. . . S VENDA=0 F S VENDA=$O(^PRC(441,ITEMDA,2,VENDA)) Q:'VENDA S VENDATA=$G(^(VENDA,0)) I VENDATA'="",'$P($G(^PRC(440,VENDA,10)),"^",5) D
  1. . . . I PRCP("DPTYPE")="W",VENDA=WHSESRCE Q ;do not want to add warehouse as a procurement source
  1. . . . S VENUNIT=$$UNITVAL^PRCPUX1($P(VENDATA,"^",8),$P(VENDATA,"^",7),"/")
  1. . . . I VENUNIT["?" S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,7,VENDA,0)=VENUNIT ;im file unit of purchase wrong
  1. . . . S PSDATA=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,VENDA_";PRC(440,",0)
  1. . . . I 'PSDATA S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,7,VENDA,1)="" ;vendor needs adding as procurement source
  1. . . ; loop procurement sources and check inventory point for errors
  1. . . S PSDA=0 F S PSDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA,5,PSDA)) Q:'PSDA S PSDATA=^(PSDA,0) D
  1. . . . I $D(^TMP($J,"PRCPRPKG",NSN,ITEMDA,7,+PSDATA)) Q ;other errors already found
  1. . . . S PSUNIT=$$UNITVAL^PRCPUX1($P(PSDATA,"^",3),$P(PSDATA,"^",2),"/")
  1. . . . S VENDATA=$G(^PRC(441,ITEMDA,2,+PSDATA,0)),VENUNIT=$$UNITVAL^PRCPUX1($P(VENDATA,"^",8),$P(VENDATA,"^",7),"/")
  1. . . . ;unit per receipt not equal to unit per purchase
  1. . . . I PSUNIT'=VENUNIT S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,7,+PSDATA,2)=PSUNIT_"^"_VENUNIT
  1. . ;
  1. . ; check for vendors which need to be removed as procurement sources
  1. . S PSDA=0 F S PSDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA,5,PSDA)) Q:'PSDA S PSDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,5,PSDA,0)) D
  1. . . I '$D(^PRC(441,ITEMDA,2,+PSDATA,0))!($P($G(^PRC(440,+PSDATA,10)),"^",5)) K ^TMP($J,"PRCPRPKG",NSN,ITEMDA,7,+PSDATA) S ^(+PSDATA,3)="" Q ;vendor needs to be removed as a procurement source
  1. . . I MANSRCE,$P(PSDATA,"^")'=MANSRCE K ^TMP($J,"PRCPRPKG",NSN,ITEMDA,7,+PSDATA) S ^(+PSDATA,3)=""
  1. . ;
  1. . ; check outstanding transactions
  1. . S TRANDA=0 F S TRANDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA)) Q:'TRANDA D CHECKOUT^PRCPUTRA(PRCP("I"),ITEMDA,TRANDA) D
  1. . . I $D(OUTSTERR) S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,8,TRANDA,3)=OUTSTERR Q
  1. . . I '$D(OUTSDATA) Q
  1. . . S OUTST=$G(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0))
  1. . . S OUTSUNIT=$$UNITVAL^PRCPUX1($P(OUTST,"^",4),$P(OUTST,"^",3),"/")
  1. . . S TRANUNIT=$$UNITVAL^PRCPUX1($P(OUTSDATA,"^",2),$P(OUTSDATA,"^",3),"/")
  1. . . S ^TMP($J,"PRCPRPKG",NSN,ITEMDA,8,TRANDA,4)=OUTSUNIT_"^"_TRANUNIT
  1. Q