source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAWI1.m@ 1194

PRCPAWI1 ;WISC/RFJ/DL-adjust inventory level - issue adjustment cont.  ;1/28/98  0915
 ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
 ;
 ;
ISUECONT ;  issue book adjustment continuation
 N CANTEEN,DATA,DRUGACCT,FY,ITEMDA,LINEDA,ORDERNO,PRCPID,PRIMORDR,QTR,TOTALINV,TOTALSAL,X,Y
 S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
 I DISTRPT S PRIMORDR=$$ORDERNO^PRCPUTRX(DISTRPT)
 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. <<"
 I $P($G(^PRC(420,PRCPPSTA,1,PRCPPFCP,0)),"^",12)=4 S CANTEEN=1
 ;
 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
 .   ;  update issue book
 .   D POSTDATA(PRCPDA,LINEDA,$P(DATA,"^"),$P(DATA,"^",3),$P(DATA,"^",2))
 .   S TOTALINV=TOTALINV+$P(DATA,"^",3),TOTALSAL=TOTALSAL+$P(DATA,"^",2)
 .   ;  update whse
 .   K PRCPAWI0
 .   S PRCPAWI0("QTY")=-$P(DATA,"^"),PRCPAWI0("INVVAL")=-$P(DATA,"^",3),PRCPAWI0("SELVAL")=-$P(DATA,"^",2),PRCPAWI0("REF")=VOUCHER,PRCPAWI0("2237PO")=TRANNO
 .   S PRCPAWI0("REASON")="0:"_$S($G(CANTEEN):"2:",1:"")_$P(DATA,"^",6)
 .   I OTHERPT S PRCPAWI0("OTHERPT")=OTHERPT
 .   D ITEM^PRCPUUIW(PRCP("I"),ITEMDA,"A",ORDERNO,.PRCPAWI0)
 .   ;  set issue book line number in TR
 .   I $D(^PRCP(445.2,+$G(PRCPID),0)) S $P(^(0),"^",24)=LINEDA
 .   K PRCPAWI0
 .   ;  update primary
 .   I '$G(PRIMORDR) Q
 .   S PRCPAWI0("QTY")=$P(DATA,"^")*$P($$GETVEN^PRCPUVEN(OTHERPT,ITEMDA,+$O(^PRC(440,"AC","S",0))_";PRC(440,",1),"^",4)
 .   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")
 .   I $G(DRUGACCT) S PRCPAWI0("DRUGACCT")=1
 .   D ITEM^PRCPUUIW(OTHERPT,ITEMDA,"A",PRIMORDR,.PRCPAWI0)
 .   K PRCPAWI0
 ;
 I $G(DRUGACCT) D EX^PSAGIP
 ;
 S FY=$E(DT,2,3),FY=$E(100+$S(+$E(DT,4,5)>9:FY+1,1:FY),2,3)
 S QTR=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",+$E(DT,4,5))
 ;I TOTALINV,'$G(CANTEEN) D ISSUES^PRCSREC2(PRCPWSTA,FY,PRCPWFCP,QTR,-TOTALINV)
 ;I TOTALSAL,'$G(CANTEEN) D ISSUES^PRCSREC2(PRCPPSTA,FY,PRCPPFCP,QTR,-TOTALSAL)
 ;  update 410 for running balance
 S $P(^PRCS(410,PRCPDA,445),"^",3)=$P($G(^PRCS(410,PRCPDA,445)),"^",3)+TOTALSAL
 I TOTALSAL,'$G(CANTEEN) D
 . N A,B
 . S A=^PRCS(410,PRCPDA,0),B=$P($G(^(3)),"^",11),A=$P($$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),"^",7)
 . S PRCPRBSL=PRCPWSTA_"^"_PRCPWFCP_"^"_"A"_"^"_"^"_DT_"^"_-TOTALSAL_"^"_$P(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
 . S $P(PRCPRBSL,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
 . D A410^PRC0F(.PRCPXX,PRCPRBSL)
 . S PRCPRBBY=PRCPPSTA_"^"_PRCPPFCP_"^"_"A"_"^"_"^"_DT_"^"_TOTALSAL_"^"_$P(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ" D
 . S $P(PRCPRBBY,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
 . D A410^PRC0F(.PRCPXX,PRCPRBBY)
 . K PRCPRBSL,PRCPRBBY,PRCPXX
 ;
 ;  create fms iv adjustment document
 W !
 I '$G(CANTEEN) D IV^PRCPSFIV(PRCP("I"),"A"_ORDERNO,TRANNO,"","")
 I $G(CANTEEN) D SV^PRCPSFSV(PRCP("I"),"A"_ORDERNO,"","")
 ;  create log or isms code sheets
 D CODESHTS^PRCPAWC0(PRCP("I"),"A"_ORDERNO)
 ;  print form
 D PRINFORM^PRCPAWR0("A"_ORDERNO)
 Q
 ;
 ;
POSTDATA(PRCPDA,LINEDA,QTY,INVVALUE,SELVALUE)    ;  update posting values for IB
 ;  add qty,invvalue,selvalue to posting data
 I '$D(^PRCS(410,PRCPDA,"IT",LINEDA,0)) Q
 N POSTDATA
 S POSTDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
 S $P(POSTDATA,"^",3)=$P(POSTDATA,"^",3)+QTY
 S $P(POSTDATA,"^",4)=$P(POSTDATA,"^",4)+INVVALUE
 S $P(POSTDATA,"^",5)=$P(POSTDATA,"^",5)+SELVALUE
 S $P(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",3,5)=$P(POSTDATA,"^",3,5)
 Q