- 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 Mar 13, 2025@21:17:19 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
