source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAGS1.m@ 710

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

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1PRCPAGS1 ;WISC/RFJ-autogenerate secondary order ; 10/30/06 12:32pm
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 ; PRCPSCHE is a flag passed by the Scheduler
7 ; PRCPFBAR is a flag passed by the barcode upload
8 ;
9START ; 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 ;
97ERROR ; set tmp with error message
98 S ^TMP($J,"PRCPAG","ER",DESCNSN,ITEMDA)=ERROR Q
Note: See TracBrowser for help on using the repository browser.