source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAWI1.m@ 1800

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

initial load of WorldVistAEHR

File size: 3.6 KB
RevLine 
[613]1PRCPAWI1 ;WISC/RFJ/DL-adjust inventory level - issue adjustment cont. ;1/28/98 0915
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7ISUECONT ; issue book adjustment continuation
8 N CANTEEN,DATA,DRUGACCT,FY,ITEMDA,LINEDA,ORDERNO,PRCPID,PRIMORDR,QTR,TOTALINV,TOTALSAL,X,Y
9 S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
10 I DISTRPT S PRIMORDR=$$ORDERNO^PRCPUTRX(DISTRPT)
11 I $G(PRIMORDR),$P($G(^PRCP(445,+DISTRPT,0)),"^",20)="D" S X="PSAGIP" I $D(^%ZOSF("TEST")) X ^%ZOSF("TEST") I $T S DRUGACCT=1 W !!?10,">> NOTE: Primary is set up for DRUG ACCOUNTABILITY. <<"
12 I $P($G(^PRC(420,PRCPPSTA,1,PRCPPFCP,0)),"^",12)=4 S CANTEEN=1
13 ;
14 S (LINEDA,TOTALINV,TOTALSAL)=0 F S LINEDA=$O(^TMP($J,"PRCPAWI0","PROCESS",LINEDA)) Q:'LINEDA S DATA=^(LINEDA) I DATA'="" S ITEMDA=+$P(DATA,"^",7) I ITEMDA D
15 . ; update issue book
16 . D POSTDATA(PRCPDA,LINEDA,$P(DATA,"^"),$P(DATA,"^",3),$P(DATA,"^",2))
17 . S TOTALINV=TOTALINV+$P(DATA,"^",3),TOTALSAL=TOTALSAL+$P(DATA,"^",2)
18 . ; update whse
19 . K PRCPAWI0
20 . S PRCPAWI0("QTY")=-$P(DATA,"^"),PRCPAWI0("INVVAL")=-$P(DATA,"^",3),PRCPAWI0("SELVAL")=-$P(DATA,"^",2),PRCPAWI0("REF")=VOUCHER,PRCPAWI0("2237PO")=TRANNO
21 . S PRCPAWI0("REASON")="0:"_$S($G(CANTEEN):"2:",1:"")_$P(DATA,"^",6)
22 . I OTHERPT S PRCPAWI0("OTHERPT")=OTHERPT
23 . D ITEM^PRCPUUIW(PRCP("I"),ITEMDA,"A",ORDERNO,.PRCPAWI0)
24 . ; set issue book line number in TR
25 . I $D(^PRCP(445.2,+$G(PRCPID),0)) S $P(^(0),"^",24)=LINEDA
26 . K PRCPAWI0
27 . ; update primary
28 . I '$G(PRIMORDR) Q
29 . S PRCPAWI0("QTY")=$P(DATA,"^")*$P($$GETVEN^PRCPUVEN(OTHERPT,ITEMDA,+$O(^PRC(440,"AC","S",0))_";PRC(440,",1),"^",4)
30 . S (PRCPAWI0("INVVAL"),PRCPAWI0("SELVAL"))=$P(DATA,"^",2),PRCPAWI0("REF")=VOUCHER,PRCPAWI0("REASON")="0:ISSUE adjustment by the WHSE",PRCPAWI0("2237PO")=TRANNO,PRCPAWI0("OTHERPT")=PRCP("I")
31 . I $G(DRUGACCT) S PRCPAWI0("DRUGACCT")=1
32 . D ITEM^PRCPUUIW(OTHERPT,ITEMDA,"A",PRIMORDR,.PRCPAWI0)
33 . K PRCPAWI0
34 ;
35 I $G(DRUGACCT) D EX^PSAGIP
36 ;
37 S FY=$E(DT,2,3),FY=$E(100+$S(+$E(DT,4,5)>9:FY+1,1:FY),2,3)
38 S QTR=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",+$E(DT,4,5))
39 ;I TOTALINV,'$G(CANTEEN) D ISSUES^PRCSREC2(PRCPWSTA,FY,PRCPWFCP,QTR,-TOTALINV)
40 ;I TOTALSAL,'$G(CANTEEN) D ISSUES^PRCSREC2(PRCPPSTA,FY,PRCPPFCP,QTR,-TOTALSAL)
41 ; update 410 for running balance
42 S $P(^PRCS(410,PRCPDA,445),"^",3)=$P($G(^PRCS(410,PRCPDA,445)),"^",3)+TOTALSAL
43 I TOTALSAL,'$G(CANTEEN) D
44 . N A,B
45 . S A=^PRCS(410,PRCPDA,0),B=$P($G(^(3)),"^",11),A=$P($$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),"^",7)
46 . S PRCPRBSL=PRCPWSTA_"^"_PRCPWFCP_"^"_"A"_"^"_"^"_DT_"^"_-TOTALSAL_"^"_$P(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
47 . S $P(PRCPRBSL,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
48 . D A410^PRC0F(.PRCPXX,PRCPRBSL)
49 . S PRCPRBBY=PRCPPSTA_"^"_PRCPPFCP_"^"_"A"_"^"_"^"_DT_"^"_TOTALSAL_"^"_$P(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ" D
50 . S $P(PRCPRBBY,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
51 . D A410^PRC0F(.PRCPXX,PRCPRBBY)
52 . K PRCPRBSL,PRCPRBBY,PRCPXX
53 ;
54 ; create fms iv adjustment document
55 W !
56 I '$G(CANTEEN) D IV^PRCPSFIV(PRCP("I"),"A"_ORDERNO,TRANNO,"","")
57 I $G(CANTEEN) D SV^PRCPSFSV(PRCP("I"),"A"_ORDERNO,"","")
58 ; create log or isms code sheets
59 D CODESHTS^PRCPAWC0(PRCP("I"),"A"_ORDERNO)
60 ; print form
61 D PRINFORM^PRCPAWR0("A"_ORDERNO)
62 Q
63 ;
64 ;
65POSTDATA(PRCPDA,LINEDA,QTY,INVVALUE,SELVALUE) ; update posting values for IB
66 ; add qty,invvalue,selvalue to posting data
67 I '$D(^PRCS(410,PRCPDA,"IT",LINEDA,0)) Q
68 N POSTDATA
69 S POSTDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
70 S $P(POSTDATA,"^",3)=$P(POSTDATA,"^",3)+QTY
71 S $P(POSTDATA,"^",4)=$P(POSTDATA,"^",4)+INVVALUE
72 S $P(POSTDATA,"^",5)=$P(POSTDATA,"^",5)+SELVALUE
73 S $P(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",3,5)=$P(POSTDATA,"^",3,5)
74 Q
Note: See TracBrowser for help on using the repository browser.