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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAWI1 3802 printed Nov 22, 2024@17:22:57 Page 2
PRCPAWI1 ;WISC/RFJ/DL-adjust inventory level - issue adjustment cont. ;1/28/98 0915
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ISUECONT ; issue book adjustment continuation
+1 NEW CANTEEN,DATA,DRUGACCT,FY,ITEMDA,LINEDA,ORDERNO,PRCPID,PRIMORDR,QTR,TOTALINV,TOTALSAL,X,Y
+2 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
+3 IF DISTRPT
SET PRIMORDR=$$ORDERNO^PRCPUTRX(DISTRPT)
+4 IF $GET(PRIMORDR)
IF $PIECE($GET(^PRCP(445,+DISTRPT,0)),"^",20)="D"
SET X="PSAGIP"
IF $DATA(^%ZOSF("TEST"))
XECUTE ^%ZOSF("TEST")
IF $TEST
SET DRUGACCT=1
WRITE !!?10,">> NOTE: Primary is set up for DRUG ACCOUNTABILITY. <<"
+5 IF $PIECE($GET(^PRC(420,PRCPPSTA,1,PRCPPFCP,0)),"^",12)=4
SET CANTEEN=1
+6 ;
+7 SET (LINEDA,TOTALINV,TOTALSAL)=0
FOR
SET LINEDA=$ORDER(^TMP($JOB,"PRCPAWI0","PROCESS",LINEDA))
if 'LINEDA
QUIT
SET DATA=^(LINEDA)
IF DATA'=""
SET ITEMDA=+$PIECE(DATA,"^",7)
IF ITEMDA
Begin DoDot:1
+8 ; update issue book
+9 DO POSTDATA(PRCPDA,LINEDA,$PIECE(DATA,"^"),$PIECE(DATA,"^",3),$PIECE(DATA,"^",2))
+10 SET TOTALINV=TOTALINV+$PIECE(DATA,"^",3)
SET TOTALSAL=TOTALSAL+$PIECE(DATA,"^",2)
+11 ; update whse
+12 KILL PRCPAWI0
+13 SET PRCPAWI0("QTY")=-$PIECE(DATA,"^")
SET PRCPAWI0("INVVAL")=-$PIECE(DATA,"^",3)
SET PRCPAWI0("SELVAL")=-$PIECE(DATA,"^",2)
SET PRCPAWI0("REF")=VOUCHER
SET PRCPAWI0("2237PO")=TRANNO
+14 SET PRCPAWI0("REASON")="0:"_$SELECT($GET(CANTEEN):"2:",1:"")_$PIECE(DATA,"^",6)
+15 IF OTHERPT
SET PRCPAWI0("OTHERPT")=OTHERPT
+16 DO ITEM^PRCPUUIW(PRCP("I"),ITEMDA,"A",ORDERNO,.PRCPAWI0)
+17 ; set issue book line number in TR
+18 IF $DATA(^PRCP(445.2,+$GET(PRCPID),0))
SET $PIECE(^(0),"^",24)=LINEDA
+19 KILL PRCPAWI0
+20 ; update primary
+21 IF '$GET(PRIMORDR)
QUIT
+22 SET PRCPAWI0("QTY")=$PIECE(DATA,"^")*$PIECE($$GETVEN^PRCPUVEN(OTHERPT,ITEMDA,+$ORDER(^PRC(440,"AC","S",0))_";PRC(440,",1),"^",4)
+23 SET (PRCPAWI0("INVVAL"),PRCPAWI0("SELVAL"))=$PIECE(DATA,"^",2)
SET PRCPAWI0("REF")=VOUCHER
SET PRCPAWI0("REASON")="0:ISSUE adjustment by the WHSE"
SET PRCPAWI0("2237PO")=TRANNO
SET PRCPAWI0("OTHERPT")=PRCP("I")
+24 IF $GET(DRUGACCT)
SET PRCPAWI0("DRUGACCT")=1
+25 DO ITEM^PRCPUUIW(OTHERPT,ITEMDA,"A",PRIMORDR,.PRCPAWI0)
+26 KILL PRCPAWI0
End DoDot:1
+27 ;
+28 IF $GET(DRUGACCT)
DO EX^PSAGIP
+29 ;
+30 SET FY=$EXTRACT(DT,2,3)
SET FY=$EXTRACT(100+$SELECT(+$EXTRACT(DT,4,5)>9:FY+1,1:FY),2,3)
+31 SET QTR=$PIECE("2^2^2^3^3^3^4^4^4^1^1^1","^",+$EXTRACT(DT,4,5))
+32 ;I TOTALINV,'$G(CANTEEN) D ISSUES^PRCSREC2(PRCPWSTA,FY,PRCPWFCP,QTR,-TOTALINV)
+33 ;I TOTALSAL,'$G(CANTEEN) D ISSUES^PRCSREC2(PRCPPSTA,FY,PRCPPFCP,QTR,-TOTALSAL)
+34 ; update 410 for running balance
+35 SET $PIECE(^PRCS(410,PRCPDA,445),"^",3)=$PIECE($GET(^PRCS(410,PRCPDA,445)),"^",3)+TOTALSAL
+36 IF TOTALSAL
IF '$GET(CANTEEN)
Begin DoDot:1
+37 NEW A,B
+38 SET A=^PRCS(410,PRCPDA,0)
SET B=$PIECE($GET(^(3)),"^",11)
SET A=$PIECE($$QTRDATE^PRC0D($PIECE(A,"-",2),$PIECE(A,"-",3)),"^",7)
+39 SET PRCPRBSL=PRCPWSTA_"^"_PRCPWFCP_"^"_"A"_"^"_"^"_DT_"^"_-TOTALSAL_"^"_$PIECE(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
+40 SET $PIECE(PRCPRBSL,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
+41 DO A410^PRC0F(.PRCPXX,PRCPRBSL)
+42 SET PRCPRBBY=PRCPPSTA_"^"_PRCPPFCP_"^"_"A"_"^"_"^"_DT_"^"_TOTALSAL_"^"_$PIECE(^PRCS(410,PRCPDA,4),"^",5)_"-ADJ"
Begin DoDot:2
End DoDot:2
+43 SET $PIECE(PRCPRBBY,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I")
+44 DO A410^PRC0F(.PRCPXX,PRCPRBBY)
+45 KILL PRCPRBSL,PRCPRBBY,PRCPXX
End DoDot:1
+46 ;
+47 ; create fms iv adjustment document
+48 WRITE !
+49 IF '$GET(CANTEEN)
DO IV^PRCPSFIV(PRCP("I"),"A"_ORDERNO,TRANNO,"","")
+50 IF $GET(CANTEEN)
DO SV^PRCPSFSV(PRCP("I"),"A"_ORDERNO,"","")
+51 ; create log or isms code sheets
+52 DO CODESHTS^PRCPAWC0(PRCP("I"),"A"_ORDERNO)
+53 ; print form
+54 DO PRINFORM^PRCPAWR0("A"_ORDERNO)
+55 QUIT
+56 ;
+57 ;
POSTDATA(PRCPDA,LINEDA,QTY,INVVALUE,SELVALUE) ; update posting values for IB
+1 ; add qty,invvalue,selvalue to posting data
+2 IF '$DATA(^PRCS(410,PRCPDA,"IT",LINEDA,0))
QUIT
+3 NEW POSTDATA
+4 SET POSTDATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,445))
+5 SET $PIECE(POSTDATA,"^",3)=$PIECE(POSTDATA,"^",3)+QTY
+6 SET $PIECE(POSTDATA,"^",4)=$PIECE(POSTDATA,"^",4)+INVVALUE
+7 SET $PIECE(POSTDATA,"^",5)=$PIECE(POSTDATA,"^",5)+SELVALUE
+8 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",3,5)=$PIECE(POSTDATA,"^",3,5)
+9 QUIT
