source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPPOL1.m@ 1250

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

initial load of FOIAVistA 6/30/08 version
File size: 5.7 KB
Line 
1PRCPPOL1 ;WISC/RFJ-receive purchase order (list manager) ; 6/18/01 1:21pm
2 ;;5.1;IFCAP;**34**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7RECEIVE ; start receiving po into inventory point
8 D FULL^VALM1
9 S VALMBCK="R"
10 N X
11 I $G(PRCPFLAG) D Q
12 . K X S X(1)="You must FIX all errors before receiving this purchase order into your inventory point. Failure to correctly fix the errors may lead to incorrect values in your inventory point."
13 . D DISPLAY^PRCPUX2(5,75,.X)
14 . D R^PRCPUREP
15 ;
16 I $G(PRCPFCOS) D
17 . K X S X(1)="This is a friendly WARNING. There are items on this purchase order which are either not stored in your inventory point OR have not been costed to a distribution point."
18 . S X(2)="If you continue receiving this purcase order, these items will NOT be received or costed to any inventory point."
19 . D DISPLAY^PRCPUX2(5,75,.X)
20 ;
21 N %,DATA,DRUGACCT,ISMSFLAG,ITEMDA,ITEMDATA,LINEDA,ORDERNO,PONO,PRCPPOL1,QTYRECVE,QUANTITY,REFDA,TOTCOST,TRANDA,TRANID,Y
22 I PRCPTYPE="P",$P($G(^PRCP(445,PRCPINPT,0)),"^",20)="D" S X="PSAGIP" I $D(^%ZOSF("TEST")) X ^("TEST") I $T S DRUGACCT=1 K X S X(1)="NOTE: This is a DRUG ACCOUNTABILITY inventory point." D DISPLAY^PRCPUX2(1,79,.X)
23 ;
24 S XP="ARE YOU SURE YOU WANT TO RECEIVE THIS PURCHASE ORDER"
25 W ! I $$YN^PRCPUYN(1)'=1 Q
26 ;
27CHKFINAL ;This block of the code will check and flag any incomplete Partial
28 ;receipt for selected Final PO. NOIS=LIT-0800-72295.
29 G:'$D(^PRC(442,PRCPORDR,11,0)) OKFINAL
30 N LOOPCNT,PARTMSG,PARTNUM,PARTCNT,NODATA
31 S LOOPCNT=1,(CHKDATA,PARTMSG,PARTCNT,NODATA)=0
32 S PARTNUM=""
33 S PARTCNT=$P($G(^PRC(442,PRCPORDR,11,0)),"^",4)
34 I PARTCNT'="" G:PARTCNT'=PRCPPART OKFINAL
35 I (PARTCNT'=""),(PARTCNT>0) S PARTCNT=PARTCNT-1
36 F LOOPCNT=1:1:PARTCNT D
37 .S CHKDATA=$G(^PRC(442,PRCPORDR,11,LOOPCNT,0))
38 .I CHKDATA="" S NODATA=1
39 .I $P(CHKDATA,"^",16)="" S PARTMSG=1,PARTNUM=PARTNUM_LOOPCNT_","
40 G:'PARTMSG OKFINAL
41 I PARTMSG D Q
42 . S WRD1="number: " S:$L(PARTNUM)>2 WRD1="numbers: "
43 . S WRD2="is" S:$L(PARTNUM)>2 WRD2="are"
44 . S PARTNUM=$E(PARTNUM,1,$L(PARTNUM)-1)
45 . K X S X(1)=" WARNING: There is more than one partial pending receipt for this purchase order."
46 . S X(2)="Please make sure that receipts are posted in sequence order to prevent any problem."
47 . S X(3)="Partial "_WRD1_PARTNUM_" "_WRD2_" missing for this purchase order."
48 . D DISPLAY^PRCPUX2(5,75,.X)
49 . D R^PRCPUREP
50 . K LOOPCNT,CHKDATA,PARTMSG,PARTNUM,NODATA,WRD1,WRD2
51 ;
52OKFINAL ;
53 L +^PRCP(445,PRCPINPT,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0),R^PRCPUREP Q
54 D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Purchase Order")
55 ;
56 S ORDERNO=$$ORDERNO^PRCPUTRX(PRCPINPT)
57 S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPPOLMREC",LINEDA)) Q:'LINEDA S DATA=^(LINEDA) D
58 . S ITEMDA=$P(DATA,"^"),QTYRECVE=$P(DATA,"^",2),TOTCOST=$P(DATA,"^",3),TRANDA=$P(DATA,"^",4)
59 . I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) S %=$G(^TMP($J,"PRCPPOLMCOS",LINEDA)) D:$P(%,"^",2) COSTCNTR^PRCPUCC($P(%,"^",2),PRCPINPT,$P(%,"^",3),TOTCOST) Q
60 . ;
61 . ; for items stored in the inventory point
62 . ; update beginning balance
63 . I '$D(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$E(DT,1,5))
64 . ;
65 . ; update inventory point
66 . S ITEMDATA=^PRCP(445,PRCPINPT,1,ITEMDA,0)
67 . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+QTYRECVE
68 . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+TOTCOST
69 . ; update average cost
70 . S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
71 . I QUANTITY>0 S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
72 . ; update last cost in invpt
73 . S $P(ITEMDATA,"^",15)=$J(TOTCOST/QTYRECVE,0,3),$P(ITEMDATA,"^",3)=DT
74 . S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
75 . ;
76 . ; update last cost for supply whse vendor in IM file
77 . I PRCPTYPE="W",$D(^PRC(441,ITEMDA,2,+$O(^PRC(440,"AC","S",0)),0)) S $P(^(0),"^",2)=$S($P(ITEMDATA,"^",15)>$P(ITEMDATA,"^",22):$P(ITEMDATA,"^",15),1:$P(ITEMDATA,"^",22))
78 . ; update due-in
79 . D OUTST^PRCPUTRA(PRCPINPT,ITEMDA,TRANDA,-QTYRECVE)
80 . ; update receipt history
81 . D RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYRECVE)
82 . ; update drug accountability
83 . I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPINPT,ITEMDA,QTYRECVE*%,TRANDA,PRCPORDN,"RC"_ORDERNO,TOTCOST)
84 . ; transaction register
85 . I ORDERNO D
86 . . K PRCPPOL1
87 . . S PRCPPOL1("QTY")=QTYRECVE,(PRCPPOL1("INVVAL"),PRCPPOL1("SELVAL"))=TOTCOST,PRCPPOL1("PKG")=$P(DATA,"^",5),PRCPPOL1("2237PO")=PRCPORDN,PRCPPOL1("REF")=$E($P(PRCPORDN,"-",2))_$E($P(PRCPORDN,"-",2),3,6)
88 . . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",ORDERNO,.PRCPPOL1)
89 ;
90 I $G(DRUGACCT) D EX^PSAGIP
91 ; enter receiving information for partial
92 S Y="" D ENCODE^PRCHES2(PRCPORDR,PRCPPART,+DUZ,.Y) I Y>0 D NOW^%DTC S $P(^PRC(442,PRCPORDR,11,PRCPPART,0),"^",17,18)=%_"^"_+DUZ
93 ; clean up outstanding transactions
94 I $P(^PRC(442,PRCPORDR,11,PRCPPART,0),"^",9)="F" D
95 . S REFDA=0 F S REFDA=$O(^PRC(442,PRCPORDR,13,REFDA)) Q:'REFDA S TRANDA=$P(^(REFDA,0),"^"),LINEDA=0 F S LINEDA=$O(^PRCS(410,TRANDA,"IT",LINEDA)) Q:'LINEDA D KILLTRAN^PRCPUTRA(PRCPINPT,+$P(^(LINEDA,0),"^",5),TRANDA)
96 K X S X(1)="***** RECEIVING HAS BEEN POSTED *****" D DISPLAY^PRCPUX2(2,40,.X)
97 D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
98 L -^PRCP(445,PRCPINPT,1)
99 K VALMBCK
100 I PRCPTYPE'="W" D R^PRCPUREP Q
101 ;
102 ; create code sheets
103 K X S X(1)="The program will automatically create and transmit the code sheets to Austin. Please verify the accuracy of the data and submit adjustment code sheets if necessary."
104 D DISPLAY^PRCPUX2(2,75,.X)
105 S PRCPFLAG=0,PONO=PRCPORDN,TRANID="RC"_ORDERNO
106 S ISMSFLAG=$$ISMSFLAG^PRCPUX2(PRC("SITE")) I ISMSFLAG'=2 D DQ^PRCPSLOR
107 I ISMSFLAG=2 D DQ^PRCPSMPR
108 D R^PRCPUREP
109 Q
Note: See TracBrowser for help on using the repository browser.