| [613] | 1 | PRCPAGS1 ;WISC/RFJ-autogenerate secondary order ; 10/30/06 12:32pm
|
|---|
| 2 | V ;;5.1;IFCAP;**1,98**;Oct 20, 2000;Build 37
|
|---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ; PRCPSCHE is a flag passed by the Scheduler
|
|---|
| 7 | ; PRCPFBAR is a flag passed by the barcode upload
|
|---|
| 8 | ;
|
|---|
| 9 | START ; start autogenerating items
|
|---|
| 10 | N %,CONV,COST,DESCNSN,EACHONE,ERROR,EXIT,GROUP,GROUPNM
|
|---|
| 11 | N INACTIVE,ISSMULT,ITEMDA,ITEMDATA,LASTONE,LEVEL,MINISS,NOWDT,NUMBER
|
|---|
| 12 | N ORDER,PRIMDATA,QTY,QTYAVAIL,TEMPLVL,TOTITEMS,TYPE
|
|---|
| 13 | N UNITI,UNITR,VENDATA,VENDOR,VENDORNM,X,Y
|
|---|
| 14 | D NOW^%DTC S NOWDT=%
|
|---|
| 15 | L +^PRCP(445,PRCP("I"),1):5 I '$T D Q
|
|---|
| 16 | . I '$D(PRCPSCHE) D SHOWWHO^PRCPULOC(445,PRCP("I")_"-1",0)
|
|---|
| 17 | . I $D(PRCPSCHE) S $P(PRCPSCHE,"^",2)=4
|
|---|
| 18 | D ADD^PRCPULOC(445,PRCP("I")_"-1",0,"Autogeneration")
|
|---|
| 19 | W !!,"<<< Starting Auto-generation ...",!
|
|---|
| 20 | I '$D(PRCPSCHE) S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
|
|---|
| 21 | S (TOTITEMS,ITEMDA)=0
|
|---|
| 22 | F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S ITEMDATA=$G(^(ITEMDA,0)) I ITEMDATA'="" D
|
|---|
| 23 | . I '$D(PRCPSCHE) S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
|
|---|
| 24 | . S DESCNSN=$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,16)
|
|---|
| 25 | . S:DESCNSN="" DESCNSN=" "
|
|---|
| 26 | . S GROUP=+$P(ITEMDATA,"^",21)
|
|---|
| 27 | . S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
|
|---|
| 28 | . I GROUPNM'="" S GROUPNM=$E(GROUPNM,1,20)_"(#"_GROUP_")"
|
|---|
| 29 | . S:GROUPNM="" GROUPNM=" "
|
|---|
| 30 | . ; remove temp stock level if greater than date
|
|---|
| 31 | . I $P(ITEMDATA,"^",23)>0,NOWDT>$P(ITEMDATA,"^",24) D
|
|---|
| 32 | . . D DELTEMP^PRCPAGU1(PRCP("I"),ITEMDA)
|
|---|
| 33 | . . S $P(ITEMDATA,"^",23,24)="^"
|
|---|
| 34 | . ; check for 'delete item when inventory 0'
|
|---|
| 35 | . I $P(ITEMDATA,"^",26)="Y" D Q
|
|---|
| 36 | . . I $P(ITEMDATA,"^",7)!($P(ITEMDATA,"^",19))!($P(ITEMDATA,"^",27)) Q
|
|---|
| 37 | . . S INACTIVE=$P(^PRCP(445,PRCP("I"),0),"^",13)
|
|---|
| 38 | . . I INACTIVE D I EXIT Q
|
|---|
| 39 | . . . N X1,X2 ; initialization of X1,X2 added with PRC*5.1*98
|
|---|
| 40 | . . . S EXIT=0
|
|---|
| 41 | . . . D NOW^%DTC
|
|---|
| 42 | . . . S X1=X,X2=-(INACTIVE*30+1)
|
|---|
| 43 | . . . D C^%DTC
|
|---|
| 44 | . . . I $O(^PRCP(445,PRCP("I"),1,ITEMDA,2,$E(X,1,5)-.1)) S EXIT=1 Q
|
|---|
| 45 | . . . I $O(^PRCP(445,PRCP("I"),1,ITEMDA,3,X)) S EXIT=1 Q
|
|---|
| 46 | . . I $$ORDCHK^PRCPUITM(ITEMDA,PRCP("I"),"RCE","") D D ERROR Q
|
|---|
| 47 | . . . S ERROR="INACTIVE ITEM ON ORDER - can't delete from inventory point (KWZ)"
|
|---|
| 48 | . . S ERROR="DELETING ITEM from inventory point (KWZ)"
|
|---|
| 49 | . . D ERROR
|
|---|
| 50 | . . D DELITEM^PRCPUITM(PRCP("I"),ITEMDA)
|
|---|
| 51 | . ;
|
|---|
| 52 | . ; primary vendor not selected
|
|---|
| 53 | . S VENDOR=$P(ITEMDATA,"^",12)
|
|---|
| 54 | . I 'VENDOR D D ERROR Q
|
|---|
| 55 | . . S ERROR="MANDATORY OR REQUESTED SOURCE is missing for item"
|
|---|
| 56 | . I VENDOR["PRC(440" D D ERROR Q
|
|---|
| 57 | . . S ERROR="MANDATORY OR REQUESTED SOURCE should be a primary distribution point"
|
|---|
| 58 | . S VENDOR=+VENDOR
|
|---|
| 59 | . I '$D(^TMP($J,"PRCPAG","V",VENDOR)) D Q
|
|---|
| 60 | . . S %=$S('VENDOR:" ",1:$$INVNAME^PRCPUX1(VENDOR))
|
|---|
| 61 | . . S:%="" %=" "
|
|---|
| 62 | . . S ^TMP($J,"PRCPAG","NOV",%,VENDOR,DESCNSN,ITEMDA)=""
|
|---|
| 63 | . I $P(ITEMDATA,"^",26)="Y" D D ERROR Q
|
|---|
| 64 | . . S ERROR="KWZ is set to YES, item not ordered"
|
|---|
| 65 | . ; check normal stock level (O allowed for ODI per PRC*5.1*98)
|
|---|
| 66 | . I $P(ITEMDATA,"^",9)=0&($P(ITEMDATA,"^",30)'="Y")!($P(ITEMDATA,"^",9)']"") D D ERROR Q
|
|---|
| 67 | . . S ERROR="NORMAL STOCK LEVEL missing for item"
|
|---|
| 68 | . ; check standard re-order point (no nils, 0 valid with PRC*5.1*1)
|
|---|
| 69 | . I $P(ITEMDATA,"^",10)']"" D D ERROR Q
|
|---|
| 70 | . . S ERROR="STANDARD REORDER POINT missing for item"
|
|---|
| 71 | . S VENDORNM=$$INVNAME^PRCPUX1(VENDOR)
|
|---|
| 72 | . S VENDATA=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,VENDOR_";PRCP(445,",1)
|
|---|
| 73 | . I 'VENDATA D D ERROR Q
|
|---|
| 74 | . . S ERROR="Primary '"_VENDORNM_" is NOT a procurement source"
|
|---|
| 75 | . S PRIMDATA=$G(^PRCP(445,VENDOR,1,ITEMDA,0))
|
|---|
| 76 | . I PRIMDATA="" D D ERROR Q
|
|---|
| 77 | . . S ERROR="Item NOT stored in primary inventory point: "_VENDORNM
|
|---|
| 78 | . S UNITI=$$UNIT^PRCPUX1(VENDOR,ITEMDA,"/")
|
|---|
| 79 | . S UNITR=$$UNITVAL^PRCPUX1($P(VENDATA,"^",3),$P(VENDATA,"^",2),"/")
|
|---|
| 80 | . I UNITI'=UNITR D D ERROR Q
|
|---|
| 81 | . . S ERROR="UNIT/REC: "_UNITR_" does not equal UNIT/ISS: "_UNITI_" for primary inventory point: "_VENDORNM
|
|---|
| 82 | . S CONV=+$P(VENDATA,"^",4) S:CONV<1 CONV=1
|
|---|
| 83 | . S COST=$P(PRIMDATA,"^",22)
|
|---|
| 84 | . I $P(PRIMDATA,"^",15)>COST S COST=$P(PRIMDATA,"^",15)
|
|---|
| 85 | . S MINISS=$P(PRIMDATA,"^",17)
|
|---|
| 86 | . S ISSMULT=$P(PRIMDATA,"^",25)
|
|---|
| 87 | . D QTYORD^PRCPAGU2
|
|---|
| 88 | D CLEAR^PRCPULOC(445,PRCP("I")_"-1",0)
|
|---|
| 89 | L -^PRCP(445,PRCP("I"),1)
|
|---|
| 90 | ;
|
|---|
| 91 | I '$D(PRCPSCHE) D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
|
|---|
| 92 | W !!,"<<< Finished !"
|
|---|
| 93 | D CONT^PRCPAGS2
|
|---|
| 94 | Q
|
|---|
| 95 | ;
|
|---|
| 96 | ;
|
|---|
| 97 | ERROR ; set tmp with error message
|
|---|
| 98 | S ^TMP($J,"PRCPAG","ER",DESCNSN,ITEMDA)=ERROR Q
|
|---|
