source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWPP3.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1PRCPWPP3 ;WISC/RFJ-primary receive issue book (receive) ;20 Jan 94
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7RECEIVE ; receive issue book
8 D FULL^VALM1
9 S VALMBCK="R"
10 I '$O(^TMP($J,"PRCPWPPLPOST",0)) S VALMSG="THERE ARE NO ITEMS TO RECEIVE" Q
11 ;
12 N %,COSTCNTR,DRUGACCT,IBDATA,ITEMDA,ITEMDATA,LINEDA,PRCPFLAG,PRCPPORD,PRCPWPP3,QTYPOST,QUANTITY,TOTCOST,TOTLINES,UNITCOST,X
13 ;
14 I $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)
15 ;
16 S XP="ARE YOU SURE YOU WANT TO RECEIVE THIS ISSUE BOOK"
17 W ! I $$YN^PRCPUYN(1)'=1 Q
18 L +^PRCP(445,PRCPINPT,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0) Q
19 D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Issue Book")
20 S PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPINPT)
21 S TOTLINES=0
22 S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPWPPLPOST",LINEDA)) Q:'LINEDA S QTYPOST=^(LINEDA) I QTYPOST D
23 . S IBDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)) I IBDATA="" Q
24 . S ITEMDA=+$P(IBDATA,"^",5)
25 . S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q
26 . S UNITCOST=$P(IBDATA,"^",7)
27 . S TOTCOST=$J(QTYPOST*UNITCOST,0,2)
28 . S TOTLINES=TOTLINES+1
29 . ;
30 . ; *** primary ***
31 . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
32 . S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" D Q
33 . . S COSTCNTR=$P($G(^PRCP(445,PRCPINPT,0)),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
34 . S QTYPOST=QTYPOST*$P($$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,PRCPPVNO,1),"^",4)
35 . ; update beginning balance
36 . I '$D(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$E(DT,1,5))
37 . ; update primary invpt
38 . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+QTYPOST
39 . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+TOTCOST
40 . ; update average cost
41 . S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)
42 . I QUANTITY S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
43 . ; update last cost
44 . S $P(ITEMDATA,"^",15)=$J(TOTCOST/QTYPOST,0,3),$P(ITEMDATA,"^",3)=DT
45 . S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
46 . ; remove due-in
47 . D OUTST^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA,-QTYPOST)
48 . ; receipt history
49 . D RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST)
50 . ; distribution costs
51 . S COSTCNTR=$P(^PRCP(445,PRCPINPT,0),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
52 . ; drug accountability
53 . I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPINPT,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
54 . ; transaction register
55 . I PRCPPORD D
56 . . K PRCPWPP3
57 . . S PRCPWPP3("QTY")=QTYPOST,(PRCPWPP3("INVVAL"),PRCPWPP3("SELVAL"))=TOTCOST,PRCPWPP3("2237PO")=PRCPIBNM,PRCPWPP3("OTHERPT")=PRCPWHSE
58 . . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",PRCPPORD,.PRCPWPP3)
59 ;
60 K VALMBCK
61 ;
62 I $G(DRUGACCT) D EX^PSAGIP
63 K X S X(1)="TOTAL LINE ITEMS POSTED: "_TOTLINES D DISPLAY^PRCPUX2(1,40,.X)
64 ;
65 ; make issue book a final
66 I $G(PRCPFINL) D
67 . K X S X(1)="This issue book is a final. You have the option to remove all outstanding due-ins for this issue book." D DISPLAY^PRCPUX2(5,75,.X)
68 . S XP="Do you want to remove the due-ins for this issue book",XH="Enter YES to remove the due-ins, NO to leave the due-ins."
69 . I $$YN^PRCPUYN(1)'=1 Q
70 . S LINEDA=0 F S LINEDA=$O(^PRCS(410,PRCPDA,"IT",LINEDA)) Q:'LINEDA S ITEMDA=+$P(^(LINEDA,0),"^",5),QTYOUT=$P(^(0),"^",2)-$P(^(0),"^",13) I QTYOUT>0 D
71 . . D KILLTRAN^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA)
72 ;
73 D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
74 L -^PRCP(445,PRCPINPT,1)
75 ;
76 I TOTLINES=0 Q:$G(PRCPFINL) S VALMSG="NO LINE ITEMS TO POST",VALMBCK="R" Q
77 D R^PRCPUREP
78 Q
Note: See TracBrowser for help on using the repository browser.