source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAGP1.m@ 1246

Last change on this file since 1246 was 613, checked in by George Lilly, 16 years ago

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