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