PRCPRTR1 ;WISC/RFJ-transaction register report (print) ;07 Sep 91
;;5.1;IFCAP;**24,142**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
PRINT ;print report from tmp global
N DATA,ITEMDA,MONTH,NOW,NOWDT,NSN,PAGE,PRCPFLAG,SALEUNIT,SCREEN,PRCPDT,HDSW
D NOW^%DTC S (Y,NOWDT)=% D DD^%DT S NOW=Y,PAGE=0
S HDSW=0,U="^",PAGE=0,ITEMDA="",SCREEN=$$SCRPAUSE^PRCPUREP U IO
P1 S ITEMDA=$O(^TMP($J,"PRCPRTRA",ITEMDA)),PRCPDT=0 G 9:ITEMDA=""!($D(PRCPFLAG)) S:'$D(ALLITEMS) PAGE=0
P2 S PRCPDT=$O(^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT)) G P1:PRCPDT=""!$D(PRCPFLAG)
S Y=PRCPDT D DD^%DT S MONTH=Y
I $D(ALLITEMS),PAGE=0 D H
D G 9:$G(PRCPFLAG),P2
. I '$D(ALLITEMS) D H Q:$G(PRCPFLAG)
. S DATA=^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT),NSN=$P(DATA,U),DATA=$P(DATA,U,2,99)
. W !!,$S(NSN=" ":"** NO NSN **",1:NSN)
. W ?19,$P(DATA,"^")
. W ?49,"[#",ITEMDA,"]"
. W ?59,"U/I: ",$P(DATA,"^",2)
. W ! W:PRCP("DPTYPE")="W" ?9,"QTY NON-ISS: ",+$P(DATA,"^",5)
. W ?28,"DUE-IN: ",+$P(DATA,"^",3)
. W ?44,"DUE-OUT: ",+$P(DATA,"^",4)
. W !?23,"ISSUABLE + NONISSUABLE OPEN BALANCE:",$J($P(DATA,"^",6),9),$J($P(DATA,"^",7),12,2)
. I $Y>(IOSL-6) D H Q:$G(PRCPFLAG)
. S DATE=0
. F S DATE=$O(^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT,DATE)) Q:'DATE!($G(PRCPFLAG)) D
. . S TRX=0
. . F S TRX=$O(^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT,DATE,TRX)) Q:'TRX!($G(PRCPFLAG)) D
. . . S D=^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT,DATE,TRX)
. . . S SALEUNIT="" I $P(D,"^",6) S SALEUNIT=$J($P(D,"^",5)/$P(D,"^",6),0,3)
. . . W !,$P(D,"^"),?9,$E(DATE,6,7),?13,$P(D,"^",2),?33,$J($P(D,"^",3),8),$J(SALEUNIT,10),$J($P(D,"^",5),10),$J($P(D,"^",6),7),$J($P(D,"^",4),12)
. . . W:$G(^PRCP(445.2,TRX,1))'="" !,$P(^(1),"^")
. . . I $Y>(IOSL-6) D H Q:$G(PRCPFLAG)
. I $D(PRCPFLAG) Q
. I $Y>(IOSL-5) D H Q:$G(PRCPFLAG)
. I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
. W !?43,"CLOSING BALANCE:",$J($P(DATA,"^",8),9),$J($P(DATA,"^",9),12,2)
. S %=$G(^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT,"BAL"))
. I %'="" W !?28,"*** CURRENT INVENTORY BALANCES:",$J($P(%,"^"),9),$J($P(%,"^",2),12,2)
. I $Y>(IOSL-6) D H
9 I $G(PRCPFLAG) G Q
I $Y>(IOSL-7),'$D(PRCPFLAG) D H Q:$G(PRCPFLAG)
I '$D(PRCPFLAG) W ! F %=1:1:5 W !,$P($T(ABBREV+%),";",3)
I '$D(PRCPFLAG) D END^PRCPUREP
Q D ^%ZISC K ^TMP($J,"PRCPITEMS"),^TMP($J,"PRCPRTRA")
Q
;
H S PAGE=PAGE+1,%=NOW_" PAGE "_PAGE
I SCREEN D:PAGE>1!HDSW P^PRCPUREP Q:$G(PRCPFLAG) W @IOF
I 'SCREEN,(PAGE=1!$D(ALLITEMS)) W @IOF
I 'SCREEN,PAGE>1,'$D(ALLITEMS) S X="",$P(X," ",81)="" W !,X,!,X K X
W !,"TRANSACTION REGISTER FOR ",$E(PRCP("IN"),1,15),?(80-$L(%)),%
W !," FOR THE MONTH OF ",MONTH
I $G(PRCPSUMM) W ?47,"ONLY ITEMS OUT OF BALANCE PRINTED"
W !,"NSN",?19,"DESCRIPTION",?49,"[#MI]"
S %="",$P(%,"-",81)="",HDSW=1
W !,"TRANSID",?9,"DT",?13,"TRANS./P.O."
W:PRCP("DPTYPE")="P" "/to:INV.PT."
W ?38,"U/I",?43,"SELLUNIT",?55,"SELL $",?65,"QTY",?75,"INV $",!,%
I 'SCREEN S $Y=9
Q
;
ABBREV ;;display abbreviations
;;TRANSACTION TYPE (TT) ABBREVIATIONS: U = USAGE
;; R = RECEIVING A = MANUAL ADJUSTMENT
;; D = DISTRIBUTION (REGULAR ISSUES) S = ASSEMBLE SETS
;; C = DISTRIBUTION (CALL-IN) P = PHYSICAL COUNT
;; E = DISTRIBUTION (EMERGENCY) Q = QTY ADJ TO SUPPLY STATION
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRTR1 3366 printed Sep 23, 2025@19:51:41 Page 2
PRCPRTR1 ;WISC/RFJ-transaction register report (print) ;07 Sep 91
+1 ;;5.1;IFCAP;**24,142**;Oct 20, 2000;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PRINT ;print report from tmp global
+1 NEW DATA,ITEMDA,MONTH,NOW,NOWDT,NSN,PAGE,PRCPFLAG,SALEUNIT,SCREEN,PRCPDT,HDSW
+2 DO NOW^%DTC
SET (Y,NOWDT)=%
DO DD^%DT
SET NOW=Y
SET PAGE=0
+3 SET HDSW=0
SET U="^"
SET PAGE=0
SET ITEMDA=""
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
P1 SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRTRA",ITEMDA))
SET PRCPDT=0
if ITEMDA=""!($DATA(PRCPFLAG))
GOTO 9
if '$DATA(ALLITEMS)
SET PAGE=0
P2 SET PRCPDT=$ORDER(^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT))
if PRCPDT=""!$DATA(PRCPFLAG)
GOTO P1
+1 SET Y=PRCPDT
DO DD^%DT
SET MONTH=Y
+2 IF $DATA(ALLITEMS)
IF PAGE=0
DO H
+3 Begin DoDot:1
+4 IF '$DATA(ALLITEMS)
DO H
if $GET(PRCPFLAG)
QUIT
+5 SET DATA=^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT)
SET NSN=$PIECE(DATA,U)
SET DATA=$PIECE(DATA,U,2,99)
+6 WRITE !!,$SELECT(NSN=" ":"** NO NSN **",1:NSN)
+7 WRITE ?19,$PIECE(DATA,"^")
+8 WRITE ?49,"[#",ITEMDA,"]"
+9 WRITE ?59,"U/I: ",$PIECE(DATA,"^",2)
+10 WRITE !
if PRCP("DPTYPE")="W"
WRITE ?9,"QTY NON-ISS: ",+$PIECE(DATA,"^",5)
+11 WRITE ?28,"DUE-IN: ",+$PIECE(DATA,"^",3)
+12 WRITE ?44,"DUE-OUT: ",+$PIECE(DATA,"^",4)
+13 WRITE !?23,"ISSUABLE + NONISSUABLE OPEN BALANCE:",$JUSTIFY($PIECE(DATA,"^",6),9),$JUSTIFY($PIECE(DATA,"^",7),12,2)
+14 IF $Y>(IOSL-6)
DO H
if $GET(PRCPFLAG)
QUIT
+15 SET DATE=0
+16 FOR
SET DATE=$ORDER(^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT,DATE))
if 'DATE!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+17 SET TRX=0
+18 FOR
SET TRX=$ORDER(^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT,DATE,TRX))
if 'TRX!($GET(PRCPFLAG))
QUIT
Begin DoDot:3
+19 SET D=^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT,DATE,TRX)
+20 SET SALEUNIT=""
IF $PIECE(D,"^",6)
SET SALEUNIT=$JUSTIFY($PIECE(D,"^",5)/$PIECE(D,"^",6),0,3)
+21 WRITE !,$PIECE(D,"^"),?9,$EXTRACT(DATE,6,7),?13,$PIECE(D,"^",2),?33,$JUSTIFY($PIECE(D,"^",3),8),$JUSTIFY(SALEUNIT,10),$JUSTIFY($PIECE(D,"^",5),10),$JUSTIFY($PIECE(D,"^",6),7),$JUSTIFY($PIECE(D,"^",4),12)
+22 if $GET(^PRCP(445.2,TRX,1))'=""
WRITE !,$PIECE(^(1),"^")
+23 IF $Y>(IOSL-6)
DO H
if $GET(PRCPFLAG)
QUIT
End DoDot:3
End DoDot:2
+24 IF $DATA(PRCPFLAG)
QUIT
+25 IF $Y>(IOSL-5)
DO H
if $GET(PRCPFLAG)
QUIT
+26 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
+27 WRITE !?43,"CLOSING BALANCE:",$JUSTIFY($PIECE(DATA,"^",8),9),$JUSTIFY($PIECE(DATA,"^",9),12,2)
+28 SET %=$GET(^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT,"BAL"))
+29 IF %'=""
WRITE !?28,"*** CURRENT INVENTORY BALANCES:",$JUSTIFY($PIECE(%,"^"),9),$JUSTIFY($PIECE(%,"^",2),12,2)
+30 IF $Y>(IOSL-6)
DO H
End DoDot:1
if $GET(PRCPFLAG)
GOTO 9
GOTO P2
9 IF $GET(PRCPFLAG)
GOTO Q
+1 IF $Y>(IOSL-7)
IF '$DATA(PRCPFLAG)
DO H
if $GET(PRCPFLAG)
QUIT
+2 IF '$DATA(PRCPFLAG)
WRITE !
FOR %=1:1:5
WRITE !,$PIECE($TEXT(ABBREV+%),";",3)
+3 IF '$DATA(PRCPFLAG)
DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPITEMS"),^TMP($JOB,"PRCPRTRA")
+1 QUIT
+2 ;
H SET PAGE=PAGE+1
SET %=NOW_" PAGE "_PAGE
+1 IF SCREEN
if PAGE>1!HDSW
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
WRITE @IOF
+2 IF 'SCREEN
IF (PAGE=1!$DATA(ALLITEMS))
WRITE @IOF
+3 IF 'SCREEN
IF PAGE>1
IF '$DATA(ALLITEMS)
SET X=""
SET $PIECE(X," ",81)=""
WRITE !,X,!,X
KILL X
+4 WRITE !,"TRANSACTION REGISTER FOR ",$EXTRACT(PRCP("IN"),1,15),?(80-$LENGTH(%)),%
+5 WRITE !," FOR THE MONTH OF ",MONTH
+6 IF $GET(PRCPSUMM)
WRITE ?47,"ONLY ITEMS OUT OF BALANCE PRINTED"
+7 WRITE !,"NSN",?19,"DESCRIPTION",?49,"[#MI]"
+8 SET %=""
SET $PIECE(%,"-",81)=""
SET HDSW=1
+9 WRITE !,"TRANSID",?9,"DT",?13,"TRANS./P.O."
+10 if PRCP("DPTYPE")="P"
WRITE "/to:INV.PT."
+11 WRITE ?38,"U/I",?43,"SELLUNIT",?55,"SELL $",?65,"QTY",?75,"INV $",!,%
+12 IF 'SCREEN
SET $Y=9
+13 QUIT
+14 ;
ABBREV ;;display abbreviations
+1 ;;TRANSACTION TYPE (TT) ABBREVIATIONS: U = USAGE
+2 ;; R = RECEIVING A = MANUAL ADJUSTMENT
+3 ;; D = DISTRIBUTION (REGULAR ISSUES) S = ASSEMBLE SETS
+4 ;; C = DISTRIBUTION (CALL-IN) P = PHYSICAL COUNT
+5 ;; E = DISTRIBUTION (EMERGENCY) Q = QTY ADJ TO SUPPLY STATION
