PRCPAGP1 ;WISC/RFJ-autogenerate primary or whse order ; 10/30/06 12:31pm
V ;;5.1;IFCAP;**1,98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
START ; start autogenerating items
; new of X,X1,X2 added with PRC*5.1*98
N %,CONV,COST,DESCNSN,EACHONE,ERROR,EXIT,G,GROUP,GROUPNM
N INACTIVE,ISSMULT,ITEMDA,ITEMDATA,LASTONE,LEVEL,MANSRCE,MINISS
N NOWDT,NUMBER,ORDER,PRCPFLAG,QTY,QTYAVAIL,TEMPLVL,TOTITEMS,TYPE
N UNITI,UNITR,VENDATA,VENDOR,VENDORNM,WHSEDATA,X,X1,X2
D NOW^%DTC S NOWDT=%
L +^PRCP(445,PRCP("I"),1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCP("I")_"-1",0) Q
D ADD^PRCPULOC(445,PRCP("I")_"-1",0,"Autogeneration")
W !!,"<<< Starting Auto-generation ...",!
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
. S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
. ; use this for sorting (primary:description, whse:nsn)
. I PRCP("DPTYPE")="P" D
. . S DESCNSN=$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,16)
. . S:DESCNSN="" DESCNSN=" "
. E S DESCNSN=$$NSN^PRCPUX1(ITEMDA) I DESCNSN="" D D ERROR Q
. . S DESCNSN=" "
. . S ERROR="NSN is missing for item"
. ; 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
. . . 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 S EXIT=1 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)
. ; not a purchasable item
. I '$$PURCHASE^PRCPU441(ITEMDA) Q
. ; BOC
. I $$SUBACCT^PRCPU441(ITEMDA)="" S ERROR="BOC is missing for item" D ERROR Q
. ; inactive items
. I $$INACTIVE^PRCPU441(ITEMDA) D D ERROR Q
. . S %=^PRC(441,ITEMDA,3)
. . S ERROR="INACTIVATED item. "_$S($P(%,"^",4)<1:"There are NO substitute items",1:"Use item number: "_$P(%,"^",4))
. ;
. ; group not selected
. S GROUP=+$P(ITEMDATA,"^",21)
. S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
. I GROUPNM'="" S GROUPNM=$E(GROUPNM,1,20)_" (#"_GROUP_")"
. S:GROUPNM="" GROUPNM=" "
. I GROUPNM=" " S ERROR="GROUP CATEGORY missing for item" D ERROR Q
. I $G(GROUPALL),$D(^TMP($J,"PRCPAG","GN",GROUP)) D Q
. . S ^TMP($J,"PRCPAG","NOG",GROUPNM,DESCNSN,ITEMDA)="" Q
. I '$G(GROUPALL),'$D(^TMP($J,"PRCPAG","GY",GROUP)) D Q
. . S ^TMP($J,"PRCPAG","NOG",GROUPNM,DESCNSN,ITEMDA)="" Q
. ;
. ; vendor not selected
. S MANSRCE=$P(ITEMDATA,"^",12)
. S VENDOR=+MANSRCE I MANSRCE["PRCP(445" S VENDOR=WHSE
. S VENDORNM=$P($G(^PRC(440,VENDOR,0)),"^")
. I VENDORNM="" D D ERROR Q
. . S ERROR="MANDATORY OR REQUESTED SOURCE is missing for item"
. I $G(VENDALL),$D(^TMP($J,"PRCPAG","VN",VENDOR)) D Q
. . S ^TMP($J,"PRCPAG","NOV",VENDORNM,VENDOR,DESCNSN,ITEMDA)="" Q
. I '$G(VENDALL),'$D(^TMP($J,"PRCPAG","VY",VENDOR)) D Q
. . S ^TMP($J,"PRCPAG","NOV",VENDORNM,VENDOR,DESCNSN,ITEMDA)="" Q
. I $P(ITEMDATA,"^",26)="Y" D D ERROR Q
. . S ERROR="KWZ is set to YES, item not ordered"
. ; check normal stock level (zero allowed for on-demand items - 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 reorder 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 VENDATA=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,MANSRCE,1)
. I 'VENDATA D D ERROR Q
. . S ERROR="Vendor '"_VENDORNM_" is NOT a procurement source"
. ;
. ; get vendor data
. K PRCPFLAG D I $G(PRCPFLAG) Q
. . I MANSRCE["PRCP(445" D Q
. . . S WHSEDATA=$G(^PRCP(445,+MANSRCE,1,ITEMDA,0))
. . . I WHSEDATA="" D Q
. . . . S ERROR="Item NOT stored in the warehouse inventory point"
. . . . D ERROR
. . . . S PRCPFLAG=1 Q
. . . S UNITI=$$UNIT^PRCPUX1(+MANSRCE,ITEMDA,"/")
. . . S COST=$P(WHSEDATA,"^",15)
. . . S:$P(WHSEDATA,"^",22)>COST COST=$P(WHSEDATA,"^",22)
. . . S MINISS=$P(WHSEDATA,"^",17)
. . . S ISSMULT=$P(WHSEDATA,"^",25)
. . S %=$G(^PRC(441,ITEMDA,2,+MANSRCE,0))
. . S UNITI=$$UNITVAL^PRCPUX1($P(%,"^",8),$P(%,"^",7),"/")
. . S COST=$P(%,"^",2)
. . S MINISS=$P(%,"^",12)
. . S ISSMULT=$P(%,"^",11)
. 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 vendor: "_VENDORNM
. S CONV=+$P(VENDATA,"^",4) S:CONV<1 CONV=1
. D QTYORD^PRCPAGU2
D CLEAR^PRCPULOC(445,PRCP("I")_"-1",0)
L -^PRCP(445,PRCP("I"),1)
;
D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
W !!,"<<< Finished !"
D CONT^PRCPAGP2 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[HPRCPAGP1 5524 printed Sep 23, 2025@19:48:37 Page 2
PRCPAGP1 ;WISC/RFJ-autogenerate primary or whse order ; 10/30/06 12:31pm
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 ;
START ; start autogenerating items
+1 ; new of X,X1,X2 added with PRC*5.1*98
+2 NEW %,CONV,COST,DESCNSN,EACHONE,ERROR,EXIT,G,GROUP,GROUPNM
+3 NEW INACTIVE,ISSMULT,ITEMDA,ITEMDATA,LASTONE,LEVEL,MANSRCE,MINISS
+4 NEW NOWDT,NUMBER,ORDER,PRCPFLAG,QTY,QTYAVAIL,TEMPLVL,TOTITEMS,TYPE
+5 NEW UNITI,UNITR,VENDATA,VENDOR,VENDORNM,WHSEDATA,X,X1,X2
+6 DO NOW^%DTC
SET NOWDT=%
+7 LOCK +^PRCP(445,PRCP("I"),1):5
IF '$TEST
DO SHOWWHO^PRCPULOC(445,PRCP("I")_"-1",0)
QUIT
+8 DO ADD^PRCPULOC(445,PRCP("I")_"-1",0,"Autogeneration")
+9 WRITE !!,"<<< Starting Auto-generation ...",!
+10 SET EACHONE=$$INPERCNT^PRCPUX2(+$PIECE($GET(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
+11 SET (TOTITEMS,ITEMDA)=0
+12 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
+13 SET LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
+14 ; use this for sorting (primary:description, whse:nsn)
+15 IF PRCP("DPTYPE")="P"
Begin DoDot:2
+16 SET DESCNSN=$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,16)
+17 if DESCNSN=""
SET DESCNSN=" "
End DoDot:2
+18 IF '$TEST
SET DESCNSN=$$NSN^PRCPUX1(ITEMDA)
IF DESCNSN=""
Begin DoDot:2
+19 SET DESCNSN=" "
+20 SET ERROR="NSN is missing for item"
End DoDot:2
DO ERROR
QUIT
+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 SET EXIT=0
+31 DO NOW^%DTC
+32 SET X1=X
SET X2=-(INACTIVE*30+1)
+33 DO C^%DTC
+34 IF $ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,$EXTRACT(X,1,5)-.1))
SET EXIT=1
QUIT
+35 IF $ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,3,X))
SET EXIT=1
QUIT
End DoDot:3
IF EXIT
QUIT
+36 IF $$ORDCHK^PRCPUITM(ITEMDA,PRCP("I"),"RCE","")
Begin DoDot:3
+37 SET ERROR="INACTIVE ITEM ON ORDER - can't delete from inventory point (KWZ)"
End DoDot:3
DO ERROR
SET EXIT=1
QUIT
+38 SET ERROR="DELETING ITEM from inventory point (KWZ)"
DO ERROR
+39 DO DELITEM^PRCPUITM(PRCP("I"),ITEMDA)
End DoDot:2
QUIT
+40 ; not a purchasable item
+41 IF '$$PURCHASE^PRCPU441(ITEMDA)
QUIT
+42 ; BOC
+43 IF $$SUBACCT^PRCPU441(ITEMDA)=""
SET ERROR="BOC is missing for item"
DO ERROR
QUIT
+44 ; inactive items
+45 IF $$INACTIVE^PRCPU441(ITEMDA)
Begin DoDot:2
+46 SET %=^PRC(441,ITEMDA,3)
+47 SET ERROR="INACTIVATED item. "_$SELECT($PIECE(%,"^",4)<1:"There are NO substitute items",1:"Use item number: "_$PIECE(%,"^",4))
End DoDot:2
DO ERROR
QUIT
+48 ;
+49 ; group not selected
+50 SET GROUP=+$PIECE(ITEMDATA,"^",21)
+51 SET GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
+52 IF GROUPNM'=""
SET GROUPNM=$EXTRACT(GROUPNM,1,20)_" (#"_GROUP_")"
+53 if GROUPNM=""
SET GROUPNM=" "
+54 IF GROUPNM=" "
SET ERROR="GROUP CATEGORY missing for item"
DO ERROR
QUIT
+55 IF $GET(GROUPALL)
IF $DATA(^TMP($JOB,"PRCPAG","GN",GROUP))
Begin DoDot:2
+56 SET ^TMP($JOB,"PRCPAG","NOG",GROUPNM,DESCNSN,ITEMDA)=""
QUIT
End DoDot:2
QUIT
+57 IF '$GET(GROUPALL)
IF '$DATA(^TMP($JOB,"PRCPAG","GY",GROUP))
Begin DoDot:2
+58 SET ^TMP($JOB,"PRCPAG","NOG",GROUPNM,DESCNSN,ITEMDA)=""
QUIT
End DoDot:2
QUIT
+59 ;
+60 ; vendor not selected
+61 SET MANSRCE=$PIECE(ITEMDATA,"^",12)
+62 SET VENDOR=+MANSRCE
IF MANSRCE["PRCP(445"
SET VENDOR=WHSE
+63 SET VENDORNM=$PIECE($GET(^PRC(440,VENDOR,0)),"^")
+64 IF VENDORNM=""
Begin DoDot:2
+65 SET ERROR="MANDATORY OR REQUESTED SOURCE is missing for item"
End DoDot:2
DO ERROR
QUIT
+66 IF $GET(VENDALL)
IF $DATA(^TMP($JOB,"PRCPAG","VN",VENDOR))
Begin DoDot:2
+67 SET ^TMP($JOB,"PRCPAG","NOV",VENDORNM,VENDOR,DESCNSN,ITEMDA)=""
QUIT
End DoDot:2
QUIT
+68 IF '$GET(VENDALL)
IF '$DATA(^TMP($JOB,"PRCPAG","VY",VENDOR))
Begin DoDot:2
+69 SET ^TMP($JOB,"PRCPAG","NOV",VENDORNM,VENDOR,DESCNSN,ITEMDA)=""
QUIT
End DoDot:2
QUIT
+70 IF $PIECE(ITEMDATA,"^",26)="Y"
Begin DoDot:2
+71 SET ERROR="KWZ is set to YES, item not ordered"
End DoDot:2
DO ERROR
QUIT
+72 ; check normal stock level (zero allowed for on-demand items - PRC*5.1*98)
+73 IF $PIECE(ITEMDATA,"^",9)=0&($PIECE(ITEMDATA,"^",30)'="Y")!($PIECE(ITEMDATA,"^",9)']"")
Begin DoDot:2
+74 SET ERROR="NORMAL STOCK LEVEL missing for item"
End DoDot:2
DO ERROR
QUIT
+75 ; check standard reorder point (no nils, 0 valid with PRC*5.1*1)
+76 IF $PIECE(ITEMDATA,"^",10)']""
Begin DoDot:2
+77 SET ERROR="STANDARD REORDER POINT missing for item"
End DoDot:2
DO ERROR
QUIT
+78 SET VENDATA=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,MANSRCE,1)
+79 IF 'VENDATA
Begin DoDot:2
+80 SET ERROR="Vendor '"_VENDORNM_" is NOT a procurement source"
End DoDot:2
DO ERROR
QUIT
+81 ;
+82 ; get vendor data
+83 KILL PRCPFLAG
Begin DoDot:2
+84 IF MANSRCE["PRCP(445"
Begin DoDot:3
+85 SET WHSEDATA=$GET(^PRCP(445,+MANSRCE,1,ITEMDA,0))
+86 IF WHSEDATA=""
Begin DoDot:4
+87 SET ERROR="Item NOT stored in the warehouse inventory point"
+88 DO ERROR
+89 SET PRCPFLAG=1
QUIT
End DoDot:4
QUIT
+90 SET UNITI=$$UNIT^PRCPUX1(+MANSRCE,ITEMDA,"/")
+91 SET COST=$PIECE(WHSEDATA,"^",15)
+92 if $PIECE(WHSEDATA,"^",22)>COST
SET COST=$PIECE(WHSEDATA,"^",22)
+93 SET MINISS=$PIECE(WHSEDATA,"^",17)
+94 SET ISSMULT=$PIECE(WHSEDATA,"^",25)
End DoDot:3
QUIT
+95 SET %=$GET(^PRC(441,ITEMDA,2,+MANSRCE,0))
+96 SET UNITI=$$UNITVAL^PRCPUX1($PIECE(%,"^",8),$PIECE(%,"^",7),"/")
+97 SET COST=$PIECE(%,"^",2)
+98 SET MINISS=$PIECE(%,"^",12)
+99 SET ISSMULT=$PIECE(%,"^",11)
End DoDot:2
IF $GET(PRCPFLAG)
QUIT
+100 SET UNITR=$$UNITVAL^PRCPUX1($PIECE(VENDATA,"^",3),$PIECE(VENDATA,"^",2),"/")
+101 IF UNITI'=UNITR
Begin DoDot:2
+102 SET ERROR="UNIT/REC: "_UNITR_" does not equal UNIT/ISS: "_UNITI_" for vendor: "_VENDORNM
End DoDot:2
DO ERROR
QUIT
+103 SET CONV=+$PIECE(VENDATA,"^",4)
if CONV<1
SET CONV=1
+104 DO QTYORD^PRCPAGU2
End DoDot:1
+105 DO CLEAR^PRCPULOC(445,PRCP("I")_"-1",0)
+106 LOCK -^PRCP(445,PRCP("I"),1)
+107 ;
+108 DO QPERCNT^PRCPUX2(+$GET(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
+109 WRITE !!,"<<< Finished !"
+110 DO CONT^PRCPAGP2
QUIT
+111 ;
+112 ;
ERROR ; set tmp with error message
+1 SET ^TMP($JOB,"PRCPAG","ER",DESCNSN,ITEMDA)=ERROR
QUIT
