source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWPL4.m@ 619

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

initial load of WorldVistAEHR
File size: 4.2 KB
RevLine 
[613]1PRCPWPL4 ;WISC/RFJ-whse post issue book (post cont) ;13 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 ;
7POST ; post issue book
8 S TOTLINES=0
9 S (TOTLINES,TOTALINV,TOTALSAL)=0
10 S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPWPLMPOST",LINEDA)) Q:'LINEDA S QTYPOST=^(LINEDA) I QTYPOST D
11 . S IBDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)) I IBDATA="" Q
12 . S ITEMDA=+$P(IBDATA,"^",5)
13 . S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q
14 . ; do not post qty < 0
15 . I QTYPOST>$P(ITEMDATA,"^",7) S QTYPOST=+$P(ITEMDATA,"^",7)
16 . I 'QTYPOST Q
17 . S UNITCOST=$P(ITEMDATA,"^",22) S:$P(ITEMDATA,"^",15)>UNITCOST UNITCOST=$P(ITEMDATA,"^",15) S:$P(IBDATA,"^",7)>UNITCOST UNITCOST=$P(IBDATA,"^",7)
18 . S TOTCOST=$J(QTYPOST*UNITCOST,0,2),INVCOST=$J(QTYPOST*$P(ITEMDATA,"^",22),0,2)
19 . S TOTALSAL=TOTALSAL+TOTCOST,TOTALINV=TOTALINV+INVCOST
20 . S TOTLINES=TOTLINES+1
21 . ;
22 . ; *** whse ***
23 . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)+QTYPOST
24 . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",7)=UNITCOST
25 . ; update totals posted
26 . S %=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
27 . S $P(%,"^",3)=$P(%,"^",3)+QTYPOST,$P(%,"^",4)=$P(%,"^",4)+INVCOST,$P(%,"^",5)=$P(%,"^",5)+TOTCOST
28 . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",3,5)=$P(%,"^",3,5)
29 . ; update beginning balance
30 . I '$D(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$E(DT,1,5))
31 . ; update whse invpt
32 . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)-QTYPOST
33 . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)-INVCOST
34 . ; update average cost
35 . S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
36 . I QUANTITY>0 S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
37 . S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
38 . D SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYPOST)
39 . ; usage
40 . D ADDUSAG^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST,INVCOST)
41 . ; transaction register
42 . K PRCPWPL3,Y
43 . S PRCPWPL3("QTY")=-QTYPOST,PRCPWPL3("INVVAL")=-INVCOST,PRCPWPL3("SELVAL")=-TOTCOST,PRCPWPL3("2237PO")=PRCPIBNM,PRCPWPL3("REF")=PRCPORD,PRCPWPL3("OTHERPT")=PRCPPRIM
44 . I $G(CANTEEN) S PRCPWPL3("REASON")="0:2:ISSUE to CANTEEN"
45 . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"R",PRCPWORD,.PRCPWPL3)
46 . ; set line number in transaction register
47 . I $D(^PRCP(445.2,+$G(Y),0)) S $P(^(0),"^",24)=LINEDA
48 . ;
49 . ;
50 . ; *** primary ***
51 . I 'PRCPFPRI Q
52 . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
53 . S ITEMDATA=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)) I ITEMDATA="" D Q
54 . . S COSTCNTR=$P($G(^PRCP(445,PRCPPRIM,0)),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
55 . S QTYPOST=QTYPOST*$P($$GETVEN^PRCPUVEN(PRCPPRIM,ITEMDA,PRCPPVNO,1),"^",4)
56 . ; update beginning balance
57 . I '$D(^PRCP(445.1,PRCPPRIM,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPPRIM,ITEMDA,$E(DT,1,5))
58 . ; update primary invpt
59 . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+QTYPOST
60 . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+TOTCOST
61 . ; update average cost
62 . S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)
63 . I QUANTITY S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
64 . ; update last cost
65 . S $P(ITEMDATA,"^",15)=$J(TOTCOST/QTYPOST,0,3),$P(ITEMDATA,"^",3)=DT
66 . S ^PRCP(445,PRCPPRIM,1,ITEMDA,0)=ITEMDATA
67 . ; remove due-in
68 . D OUTST^PRCPUTRA(PRCPPRIM,ITEMDA,PRCPDA,-QTYPOST)
69 . ; receipt history
70 . D RECEIPTS^PRCPUSAG(PRCPPRIM,ITEMDA,QTYPOST)
71 . ; distribution costs
72 . S COSTCNTR=$P(^PRCP(445,PRCPPRIM,0),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
73 . ; drug accountability
74 . I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPPRIM,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
75 . ; transaction register
76 . I PRCPPORD D
77 . . K PRCPWPL3
78 . . S PRCPWPL3("QTY")=QTYPOST,(PRCPWPL3("INVVAL"),PRCPWPL3("SELVAL"))=TOTCOST,PRCPWPL3("2237PO")=PRCPIBNM,PRCPWPL3("REF")=PRCPORD,PRCPWPL3("OTHERPT")=PRCPINPT
79 . . D ADDTRAN^PRCPUTRX(PRCPPRIM,ITEMDA,"RC",PRCPPORD,.PRCPWPL3)
80 ;
81 D ENDPOST^PRCPWPL5
82 Q
Note: See TracBrowser for help on using the repository browser.