PRCPRDI2 ;WISC/RFJ-print calculated due-ins ;30 Aug 91
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
PRINT ; called from prcprdi1 to print calculated due-ins
N %,%H,%I,D,DATA,DATE,DUEIN,ITEMDA,NSN,PAGE,PRCPFLAG,QTY,SCREEN,TRANDA,TRANNO,X,Y
D NOW^%DTC S Y=% D DD^%DT S DATE=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP,ITEMDA=0 U IO D H
; sort by nsn
K ^TMP($J,"PRCPRDI2")
F S ITEMDA=$O(^TMP($J,"PRCPRDI1-DI",ITEMDA)) Q:'ITEMDA S NSN=$$NSN^PRCPUX1(ITEMDA) S:NSN="" NSN=" " S ^TMP($J,"PRCPRDI2",NSN,ITEMDA)=""
;
S NSN="" F S NSN=$O(^TMP($J,"PRCPRDI2",NSN)) Q:NSN=""!($D(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRDI2",NSN,ITEMDA)) Q:'ITEMDA!($D(PRCPFLAG)) D
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. S D=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
. W !!,NSN,?20,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,20),?42,"[#",ITEMDA,"]",?49,$J($$UNITVAL^PRCPUX1($P(D,"^",14),$P(D,"^",5)," per "),13),?70,$J($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),10)
. D H1
. S (TRANDA,DUEIN)=0 F S TRANDA=$O(^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)) Q:'TRANDA!($D(PRCPFLAG)) S DATA=^(TRANDA) D
. . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H,H1
. . S TRANNO=$P($G(^PRCS(410,TRANDA,0)),"^"),DUEIN=DUEIN+$P(DATA,"^",2)
. . W !?10,TRANNO,?30,$P($P($G(^PRC(442,+$P(DATA,"^",6),0)),"^"),"-",2),?37,$J($$UNITVAL^PRCPUX1($P(DATA,"^",4),$P(DATA,"^",3)," per "),13),?56,$J($P(DATA,"^",5),6),$J($P(DATA,"^",2),10)
. . I '$D(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0)) W ?77,"ADD" Q
. . I $P(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0),"^",2)'=$P(DATA,"^",2) W ?77,"UPD"
. ;
. W !?33,"CALCULATED TOTAL DUE-IN QTY: ",$J(DUEIN,10) I $$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)'=DUEIN W " <-----*"
;
I $D(PRCPFLAG),$G(PRCPFUPD) U IO(0) W !,"DUE-INS AND OUTSTANDING TRANSACTIONS WILL NOT BE UPDATED UNTIL ENTIRE REPORT",!,"IS PRINTED."
I '$D(PRCPFLAG),$G(PRCPFUPD) D UPDATE W !!,"DUE-INS AND OUTSTANDING TRANSACTIONS HAVE BEEN UPDATED."
I '$D(PRCPFLAG) D END^PRCPUREP
D ^%ZISC K ^TMP($J,"PRCPRDI2")
Q
;
;
H S %=DATE_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"CALCULATED DUE-INS REPORT FOR: ",PRCP("IN"),?(80-$L(%)),%,!,"NSN",?20,"DESCRIPTION",?42,"[#MI]",?51,"UNIT per ISS",?70,"DUE-IN QTY",! S %="",$P(%,"-",81)="" W %
Q
;
;
H1 W !?10,"TRANSACTION",?30,"PO #",?39,"UNIT per REC",?53,"CONV FACT",?66,"DUE-IN"
Q
;
;
UPDATE ; update due-ins and outstanding transactions
N %,DATA,ITEMDA,TRANDA
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA D
. L +^PRCP(445,PRCP("I"),1,ITEMDA)
. ; get rid of old transactions
. S TRANDA=0 F S TRANDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA)) Q:'TRANDA I $D(^TMP($J,"PRCPRDI1-CK",TRANDA)),'$D(^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)) D KILLTRAN^PRCPUTRA(PRCP("I"),ITEMDA,TRANDA)
. ; add new transactions
. S TRANDA=0 F S TRANDA=$O(^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)) Q:'TRANDA S DATA=^(TRANDA) D
. . I '$D(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0)) D ADDTRAN^PRCPUTRA(PRCP("I"),ITEMDA,TRANDA,$P(DATA,"^",2,5))
. . S %=^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0),$P(%,"^",2)=$P(DATA,"^",2)
. . I $P(DATA,"^",3) S $P(%,"^",3)=$P(DATA,"^",3)
. . I $P(DATA,"^",4) S $P(%,"^",4)=$P(DATA,"^",4)
. . I $P(DATA,"^",5) S $P(%,"^",5)=$P(DATA,"^",5)
. . S ^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0)=%
. ; recalc total quantity due-in
. S QTY=0
. S TRANDA=0 F S TRANDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA)) Q:'TRANDA S QTY=QTY+$P($G(^(TRANDA,0)),"^",2)
. I QTY<0 S QTY=0
. D SETIN^PRCPUDUE(PRCP("I"),ITEMDA,QTY-$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA))
. L -^PRCP(445,PRCP("I"),1,ITEMDA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRDI2 3792 printed Dec 13, 2024@02:14:47 Page 2
PRCPRDI2 ;WISC/RFJ-print calculated due-ins ;30 Aug 91
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PRINT ; called from prcprdi1 to print calculated due-ins
+1 NEW %,%H,%I,D,DATA,DATE,DUEIN,ITEMDA,NSN,PAGE,PRCPFLAG,QTY,SCREEN,TRANDA,TRANNO,X,Y
+2 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET DATE=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
SET ITEMDA=0
USE IO
DO H
+3 ; sort by nsn
+4 KILL ^TMP($JOB,"PRCPRDI2")
+5 FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRDI1-DI",ITEMDA))
if 'ITEMDA
QUIT
SET NSN=$$NSN^PRCPUX1(ITEMDA)
if NSN=""
SET NSN=" "
SET ^TMP($JOB,"PRCPRDI2",NSN,ITEMDA)=""
+6 ;
+7 SET NSN=""
FOR
SET NSN=$ORDER(^TMP($JOB,"PRCPRDI2",NSN))
if NSN=""!($DATA(PRCPFLAG))
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRDI2",NSN,ITEMDA))
if 'ITEMDA!($DATA(PRCPFLAG))
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+9 SET D=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
+10 WRITE !!,NSN,?20,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,20),?42,"[#",ITEMDA,"]",?49,$JUSTIFY($$UNITVAL^PRCPUX1($PIECE(D,"^",14),$PIECE(D,"^",5)," per "),13),?70,$JUSTIFY($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),10)
+11 DO H1
+12 SET (TRANDA,DUEIN)=0
FOR
SET TRANDA=$ORDER(^TMP($JOB,"PRCPRDI1-DI",ITEMDA,TRANDA))
if 'TRANDA!($DATA(PRCPFLAG))
QUIT
SET DATA=^(TRANDA)
Begin DoDot:2
+13 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
DO H1
+14 SET TRANNO=$PIECE($GET(^PRCS(410,TRANDA,0)),"^")
SET DUEIN=DUEIN+$PIECE(DATA,"^",2)
+15 WRITE !?10,TRANNO,?30,$PIECE($PIECE($GET(^PRC(442,+$PIECE(DATA,"^",6),0)),"^"),"-",2),?37,$JUSTIFY($$UNITVAL^PRCPUX1($PIECE(DATA,"^",4),$PIECE(DATA,"^",3)," per "),13),?56,$JUSTIFY($PIECE(DATA,"^",5),6),$JUSTIFY($PIECE(DATA,
"^",2),10)
+16 IF '$DATA(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0))
WRITE ?77,"ADD"
QUIT
+17 IF $PIECE(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0),"^",2)'=$PIECE(DATA,"^",2)
WRITE ?77,"UPD"
End DoDot:2
+18 ;
+19 WRITE !?33,"CALCULATED TOTAL DUE-IN QTY: ",$JUSTIFY(DUEIN,10)
IF $$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)'=DUEIN
WRITE " <-----*"
End DoDot:1
+20 ;
+21 IF $DATA(PRCPFLAG)
IF $GET(PRCPFUPD)
USE IO(0)
WRITE !,"DUE-INS AND OUTSTANDING TRANSACTIONS WILL NOT BE UPDATED UNTIL ENTIRE REPORT",!,"IS PRINTED."
+22 IF '$DATA(PRCPFLAG)
IF $GET(PRCPFUPD)
DO UPDATE
WRITE !!,"DUE-INS AND OUTSTANDING TRANSACTIONS HAVE BEEN UPDATED."
+23 IF '$DATA(PRCPFLAG)
DO END^PRCPUREP
+24 DO ^%ZISC
KILL ^TMP($JOB,"PRCPRDI2")
+25 QUIT
+26 ;
+27 ;
H SET %=DATE_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"CALCULATED DUE-INS REPORT FOR: ",PRCP("IN"),?(80-$LENGTH(%)),%,!,"NSN",?20,"DESCRIPTION",?42,"[#MI]",?51,"UNIT per ISS",?70,"DUE-IN QTY",!
SET %=""
SET $PIECE(%,"-",81)=""
WRITE %
+2 QUIT
+3 ;
+4 ;
H1 WRITE !?10,"TRANSACTION",?30,"PO #",?39,"UNIT per REC",?53,"CONV FACT",?66,"DUE-IN"
+1 QUIT
+2 ;
+3 ;
UPDATE ; update due-ins and outstanding transactions
+1 NEW %,DATA,ITEMDA,TRANDA
+2 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
Begin DoDot:1
+3 LOCK +^PRCP(445,PRCP("I"),1,ITEMDA)
+4 ; get rid of old transactions
+5 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA))
if 'TRANDA
QUIT
IF $DATA(^TMP($JOB,"PRCPRDI1-CK",TRANDA))
IF '$DATA(^TMP($JOB,"PRCPRDI1-DI",ITEMDA,TRANDA))
DO KILLTRAN^PRCPUTRA(PRCP("I"),ITEMDA,TRANDA)
+6 ; add new transactions
+7 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^TMP($JOB,"PRCPRDI1-DI",ITEMDA,TRANDA))
if 'TRANDA
QUIT
SET DATA=^(TRANDA)
Begin DoDot:2
+8 IF '$DATA(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0))
DO ADDTRAN^PRCPUTRA(PRCP("I"),ITEMDA,TRANDA,$PIECE(DATA,"^",2,5))
+9 SET %=^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0)
SET $PIECE(%,"^",2)=$PIECE(DATA,"^",2)
+10 IF $PIECE(DATA,"^",3)
SET $PIECE(%,"^",3)=$PIECE(DATA,"^",3)
+11 IF $PIECE(DATA,"^",4)
SET $PIECE(%,"^",4)=$PIECE(DATA,"^",4)
+12 IF $PIECE(DATA,"^",5)
SET $PIECE(%,"^",5)=$PIECE(DATA,"^",5)
+13 SET ^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA,0)=%
End DoDot:2
+14 ; recalc total quantity due-in
+15 SET QTY=0
+16 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,7,TRANDA))
if 'TRANDA
QUIT
SET QTY=QTY+$PIECE($GET(^(TRANDA,0)),"^",2)
+17 IF QTY<0
SET QTY=0
+18 DO SETIN^PRCPUDUE(PRCP("I"),ITEMDA,QTY-$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA))
+19 LOCK -^PRCP(445,PRCP("I"),1,ITEMDA)
End DoDot:1
+20 QUIT
