PRCPRSS1 ;WOIFO/DAP-stock status report for primaries and secondaries; 10/16/06 2:17pm
V ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
PRINT ; print report
N DAYS,MONTH,NOW,PAGE,PRCPFLAG,SCREEN,TOTCLOS,TOTISS,TOTN,TOTOPEN,TOTVAL,ITEMCTA,X,Y
S Y=DATESTRT D DD^%DT S MONTH=Y
S DAYS=$P("31^28^31^30^31^30^31^31^30^31^30^31","^",+$E(DATESTRT,4,5))
I DAYS=28 S %=(17+$E(DATESTRT))_$E(DATESTRT,2,3),DAYS=$S(%#400=0:29,(%#4=0&(%#100'=0)):29,1:28)
;
;*98 Added looping logic to go through print cycle for each type of
;item report (Standard/ODI/All)
;
N P,PRCPTP,PRCPTP2,NODE1
S PAGE=1
F P=1:1:3 S NODE1=P D
. I $G(PRCPFLAG) Q
. I P=1 S PRCPTP="STANDARD",PRCPTP2="STD"
. I P=2 S PRCPTP="ON-DEMAND",PRCPTP2="OD"
. I P=3 S PRCPTP="ALL",PRCPTP2=PRCPTP
. D REP^PRCPRSS1
. Q
;
D Q^PRCPRSS1
Q
;
REP ;*98 Added header to display type of reporting, moved header logic
;from earlier in routine to support looping structure
;
I P>1 D LC
I $G(PRCPFLAG) Q
S SCREEN=$$SCRPAUSE^PRCPUREP D NOW^%DTC S Y=% D DD^%DT S NOW=Y U IO I P=1 D HEAD
;
W !,"INVENTORY ("_PRCPTP_" ITEMS)"
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
;
W !,"OPEN BALANCE",?14 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,NODE1,"OPEN",ACCT)),"^",2) S OPEN(ACCT)=%,TOTOPEN=TOTOPEN+% W $$SHOWVALU(%)
W $$SHOWVALU(TOTOPEN)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !!,"RECEIPTS",?14 S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"REC",ACCT)),TOTAL=TOTAL+%,OPEN(ACCT)=$G(OPEN(ACCT))+% W $$SHOWVALU(%)
W $$SHOWVALU(TOTAL)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
;*98 Modified report to replace "ISSUES" with "USAGE"
W !,"USAGE",?14 S TOTISS=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"ISS",ACCT)),TOTISS=TOTISS+%,OPEN(ACCT)=$G(OPEN(ACCT))+% W $$SHOWVALU(%)
W $$SHOWVALU(TOTISS)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !,"ADJUSTMENTS",?14 S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"ADJ",ACCT)),TOTAL=TOTAL+%,OPEN(ACCT)=$G(OPEN(ACCT))+% W $$SHOWVALU(%)
W $$SHOWVALU(TOTAL)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
S %="",$P(%,"=",80)=""
W !,%,!,"CLOSE BALANCE",?14 S TOTCLOS=0 F ACCT=1,2,3,6,8 S %=$G(OPEN(ACCT)),TOTCLOS=TOTCLOS+% W $$SHOWVALU(%)
W $$SHOWVALU(TOTCLOS)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !!!,"# RECEIPTS",?13 S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"RECN",ACCT)),TOTAL=TOTAL+%,TOTN(ACCT)=% W $J(%,11,0)
W $J(TOTAL,11,0)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
;*98 Modified report to replace "ISSUES" with "USAGES"
W !,"# USAGE",?13 S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"ISSN",ACCT)),TOTAL=TOTAL+%,TOTN(ACCT)=$G(TOTN(ACCT))+% W $J(%,11,0)
W $J(TOTAL,11,0)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !,"# ADJUSTMENTS",?13 S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"ADJN",ACCT)),TOTAL=TOTAL+%,TOTN(ACCT)=$G(TOTN(ACCT))+% W $J(%,11,0)
W $J(TOTAL,11,0)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
S %="",$P(%,"=",80)=""
W !,%,!,"# TOTAL",?13 S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(TOTN(ACCT)),TOTAL=TOTAL+% W $J(%,11,0)
W $J(TOTAL,11,0)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !!,"TURNOVER",?13 F ACCT=1,2,3,6,8 S %=($G(^TMP($J,NODE1,"ISS",ACCT))*365)/DAYS,%=$S('$G(OPEN(ACCT)):"X",1:-%/OPEN(ACCT)) W $J(%,11,2)
S %=(TOTISS*365)/DAYS,%=$S('TOTCLOS:"X",1:-%/TOTCLOS) W $J(%,11,2)
;*98 Added indicator of type of report (Standard/ODI/All)
W !,"("_PRCPTP_" ITEMS)"
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
;
;*98 Added indicator of type of report (Standard/ODI/All)
W !!?28,"*** CURRENT DATA ("_PRCPTP_" ITEMS) ***"
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
;
;*98 Rearranged report placement of sections and added indicator of
;type of report (Standard/ODI/All)
;
S Y=$E(DATEINAC,1,5)_"01" D DD^%DT
W !!?2,"INACTIVE ITEMS ("_PRCPTP_" ITEMS) FROM ",Y," TO ",$P(NOW,"@"),!,"# INACTIVE",?13
S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"INACTN",ACCT)),TOTAL=TOTAL+% W $J(%,11,0)
W $J(TOTAL,11,0)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !,"$ INACTIVE",?14 S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"INACT",ACCT)),TOTAL=TOTAL+% W $$SHOWVALU(%)
W $$SHOWVALU(TOTAL)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !,"% INACTIVE",?13 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"VALUE",ACCT)),%=$S('%:0,1:$G(^TMP($J,NODE1,"INACT",ACCT))/%) W $J(%,11,2)
;
;*98 Moved TOTVAL logic to support reordered processing
S TOTVAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"VALUE",ACCT)),TOTVAL=TOTVAL+%
;
S %=$S('TOTVAL:0,1:TOTAL/TOTVAL) W $J(%,11,2)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
S Y=$E(DATELONG,1,5)_"01" D DD^%DT
W !!?2,"LONG SUPPLY ("_PRCPTP_" ITEMS) AVG. FROM ",Y," TO ",$P(NOW,"@"),!?2,"(>90 DAYS)",!,"# LONG SUPPLY",?13
S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"LONGN",ACCT)),TOTAL=TOTAL+% W $J(%,11,0)
W $J(TOTAL,11,0)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !,"$ LONG SUPPLY",?14 S TOTAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"LONG",ACCT)),TOTAL=TOTAL+% W $$SHOWVALU(%)
W $$SHOWVALU(TOTAL)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !,"% LONG SUPPLY",?13 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"VALUE",ACCT)),%=$S('%:0,1:$G(^TMP($J,NODE1,"LONG",ACCT))/%) W $J(%,11,2)
S %=$S('TOTVAL:0,1:TOTAL/TOTVAL) W $J(%,11,2)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
;
;*98 Modified section to display a new section header, item type count,
;and display "$ONHAND" by specific type (Standard/ODI/All)
;
W !!,"# "_PRCPTP2_" ITEMS",?13 S ITEMCTA=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"CNT",ACCT)),ITEMCTA=ITEMCTA+% W $J(%,11,0)
W $J(ITEMCTA,11,0)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
;
W !!,"INVENTORY VALUE"
W !,"$ "_PRCPTP,?14 S TOTVAL=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"VALUE",ACCT)),TOTVAL=TOTVAL+% W $$SHOWVALU(%)
W $$SHOWVALU(TOTVAL)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !,"$ DUEINS",?14 S X=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"DUEIN",ACCT)),X=X+% W $$SHOWVALU(%)
W $$SHOWVALU(X)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
W !,"$ DUEOUTS",?14 S X=0 F ACCT=1,2,3,6,8 S %=$G(^TMP($J,NODE1,"DUEOUT",ACCT)),X=X+% W $$SHOWVALU(%)
W $$SHOWVALU(X)
I $Y>(IOSL-7) D LC G:$G(PRCPFLAG) Q
;
;*98 Modified report to not show the section addressing nonissuable
;items for primary and secondary inventory points
Q
;
;
Q ;Tag ends printing and exits routine
D END^PRCPUREP
D ^%ZISC Q
;
;
SHOWVALU(V1) ;show value
N % S %="+" S:+V1=0 %=" " I V1<0 S V1=-V1,%="-"
Q $J(V1,10,2)_%
;
LC ;*98 Moved line control logic into subroutines
I SCREEN W ! D P^PRCPUREP I $D(PRCPFLAG) Q
;
HEAD ;heading
N PRCPT
S %=NOW_" PAGE: "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W !,"STOCK STATUS REPORT FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
;*98 Added type of reporting (Standard/ODI/All) to header
S PRCPT=PRCPTP_" ITEMS"
W !?5,"TRANSACTIONS FOR THE MONTH-YEAR: ",MONTH,?(80-$L(PRCPT)),PRCPT
;
W !,"SUMMARY",?14,$J("ACCT 1",11),$J("ACCT 2",11),$J("ACCT 3",11),$J("ACCT 6",11),$J("ACCT 8",11),$J("TOTAL",11)
S %="",$P(%,"-",81)="" W !,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRSS1 6994 printed Sep 23, 2025@19:51:36 Page 2
V ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
PRINT ; print report
+1 NEW DAYS,MONTH,NOW,PAGE,PRCPFLAG,SCREEN,TOTCLOS,TOTISS,TOTN,TOTOPEN,TOTVAL,ITEMCTA,X,Y
+2 SET Y=DATESTRT
DO DD^%DT
SET MONTH=Y
+3 SET DAYS=$PIECE("31^28^31^30^31^30^31^31^30^31^30^31","^",+$EXTRACT(DATESTRT,4,5))
+4 IF DAYS=28
SET %=(17+$EXTRACT(DATESTRT))_$EXTRACT(DATESTRT,2,3)
SET DAYS=$SELECT(%#400=0:29,(%#4=0&(%#100'=0)):29,1:28)
+5 ;
+6 ;*98 Added looping logic to go through print cycle for each type of
+7 ;item report (Standard/ODI/All)
+8 ;
+9 NEW P,PRCPTP,PRCPTP2,NODE1
+10 SET PAGE=1
+11 FOR P=1:1:3
SET NODE1=P
Begin DoDot:1
+12 IF $GET(PRCPFLAG)
QUIT
+13 IF P=1
SET PRCPTP="STANDARD"
SET PRCPTP2="STD"
+14 IF P=2
SET PRCPTP="ON-DEMAND"
SET PRCPTP2="OD"
+15 IF P=3
SET PRCPTP="ALL"
SET PRCPTP2=PRCPTP
+16 DO REP^PRCPRSS1
+17 QUIT
End DoDot:1
+18 ;
+19 DO Q^PRCPRSS1
+20 QUIT
+21 ;
REP ;*98 Added header to display type of reporting, moved header logic
+1 ;from earlier in routine to support looping structure
+2 ;
+3 IF P>1
DO LC
+4 IF $GET(PRCPFLAG)
QUIT
+5 SET SCREEN=$$SCRPAUSE^PRCPUREP
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
USE IO
IF P=1
DO HEAD
+6 ;
+7 WRITE !,"INVENTORY ("_PRCPTP_" ITEMS)"
+8 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+9 ;
+10 WRITE !,"OPEN BALANCE",?14
SET TOTOPEN=0
FOR ACCT=1,2,3,6,8
SET %=$PIECE($GET(^TMP($JOB,NODE1,"OPEN",ACCT)),"^",2)
SET OPEN(ACCT)=%
SET TOTOPEN=TOTOPEN+%
WRITE $$SHOWVALU(%)
+11 WRITE $$SHOWVALU(TOTOPEN)
+12 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+13 WRITE !!,"RECEIPTS",?14
SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"REC",ACCT))
SET TOTAL=TOTAL+%
SET OPEN(ACCT)=$GET(OPEN(ACCT))+%
WRITE $$SHOWVALU(%)
+14 WRITE $$SHOWVALU(TOTAL)
+15 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+16 ;*98 Modified report to replace "ISSUES" with "USAGE"
+17 WRITE !,"USAGE",?14
SET TOTISS=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"ISS",ACCT))
SET TOTISS=TOTISS+%
SET OPEN(ACCT)=$GET(OPEN(ACCT))+%
WRITE $$SHOWVALU(%)
+18 WRITE $$SHOWVALU(TOTISS)
+19 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+20 WRITE !,"ADJUSTMENTS",?14
SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"ADJ",ACCT))
SET TOTAL=TOTAL+%
SET OPEN(ACCT)=$GET(OPEN(ACCT))+%
WRITE $$SHOWVALU(%)
+21 WRITE $$SHOWVALU(TOTAL)
+22 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+23 SET %=""
SET $PIECE(%,"=",80)=""
+24 WRITE !,%,!,"CLOSE BALANCE",?14
SET TOTCLOS=0
FOR ACCT=1,2,3,6,8
SET %=$GET(OPEN(ACCT))
SET TOTCLOS=TOTCLOS+%
WRITE $$SHOWVALU(%)
+25 WRITE $$SHOWVALU(TOTCLOS)
+26 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+27 WRITE !!!,"# RECEIPTS",?13
SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"RECN",ACCT))
SET TOTAL=TOTAL+%
SET TOTN(ACCT)=%
WRITE $JUSTIFY(%,11,0)
+28 WRITE $JUSTIFY(TOTAL,11,0)
+29 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+30 ;*98 Modified report to replace "ISSUES" with "USAGES"
+31 WRITE !,"# USAGE",?13
SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"ISSN",ACCT))
SET TOTAL=TOTAL+%
SET TOTN(ACCT)=$GET(TOTN(ACCT))+%
WRITE $JUSTIFY(%,11,0)
+32 WRITE $JUSTIFY(TOTAL,11,0)
+33 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+34 WRITE !,"# ADJUSTMENTS",?13
SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"ADJN",ACCT))
SET TOTAL=TOTAL+%
SET TOTN(ACCT)=$GET(TOTN(ACCT))+%
WRITE $JUSTIFY(%,11,0)
+35 WRITE $JUSTIFY(TOTAL,11,0)
+36 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+37 SET %=""
SET $PIECE(%,"=",80)=""
+38 WRITE !,%,!,"# TOTAL",?13
SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(TOTN(ACCT))
SET TOTAL=TOTAL+%
WRITE $JUSTIFY(%,11,0)
+39 WRITE $JUSTIFY(TOTAL,11,0)
+40 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+41 WRITE !!,"TURNOVER",?13
FOR ACCT=1,2,3,6,8
SET %=($GET(^TMP($JOB,NODE1,"ISS",ACCT))*365)/DAYS
SET %=$SELECT('$GET(OPEN(ACCT)):"X",1:-%/OPEN(ACCT))
WRITE $JUSTIFY(%,11,2)
+42 SET %=(TOTISS*365)/DAYS
SET %=$SELECT('TOTCLOS:"X",1:-%/TOTCLOS)
WRITE $JUSTIFY(%,11,2)
+43 ;*98 Added indicator of type of report (Standard/ODI/All)
+44 WRITE !,"("_PRCPTP_" ITEMS)"
+45 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+46 ;
+47 ;*98 Added indicator of type of report (Standard/ODI/All)
+48 WRITE !!?28,"*** CURRENT DATA ("_PRCPTP_" ITEMS) ***"
+49 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+50 ;
+51 ;*98 Rearranged report placement of sections and added indicator of
+52 ;type of report (Standard/ODI/All)
+53 ;
+54 SET Y=$EXTRACT(DATEINAC,1,5)_"01"
DO DD^%DT
+55 WRITE !!?2,"INACTIVE ITEMS ("_PRCPTP_" ITEMS) FROM ",Y," TO ",$PIECE(NOW,"@"),!,"# INACTIVE",?13
+56 SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"INACTN",ACCT))
SET TOTAL=TOTAL+%
WRITE $JUSTIFY(%,11,0)
+57 WRITE $JUSTIFY(TOTAL,11,0)
+58 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+59 WRITE !,"$ INACTIVE",?14
SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"INACT",ACCT))
SET TOTAL=TOTAL+%
WRITE $$SHOWVALU(%)
+60 WRITE $$SHOWVALU(TOTAL)
+61 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+62 WRITE !,"% INACTIVE",?13
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"VALUE",ACCT))
SET %=$SELECT('%:0,1:$GET(^TMP($JOB,NODE1,"INACT",ACCT))/%)
WRITE $JUSTIFY(%,11,2)
+63 ;
+64 ;*98 Moved TOTVAL logic to support reordered processing
+65 SET TOTVAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"VALUE",ACCT))
SET TOTVAL=TOTVAL+%
+66 ;
+67 SET %=$SELECT('TOTVAL:0,1:TOTAL/TOTVAL)
WRITE $JUSTIFY(%,11,2)
+68 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+69 SET Y=$EXTRACT(DATELONG,1,5)_"01"
DO DD^%DT
+70 WRITE !!?2,"LONG SUPPLY ("_PRCPTP_" ITEMS) AVG. FROM ",Y," TO ",$PIECE(NOW,"@"),!?2,"(>90 DAYS)",!,"# LONG SUPPLY",?13
+71 SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"LONGN",ACCT))
SET TOTAL=TOTAL+%
WRITE $JUSTIFY(%,11,0)
+72 WRITE $JUSTIFY(TOTAL,11,0)
+73 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+74 WRITE !,"$ LONG SUPPLY",?14
SET TOTAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"LONG",ACCT))
SET TOTAL=TOTAL+%
WRITE $$SHOWVALU(%)
+75 WRITE $$SHOWVALU(TOTAL)
+76 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+77 WRITE !,"% LONG SUPPLY",?13
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"VALUE",ACCT))
SET %=$SELECT('%:0,1:$GET(^TMP($JOB,NODE1,"LONG",ACCT))/%)
WRITE $JUSTIFY(%,11,2)
+78 SET %=$SELECT('TOTVAL:0,1:TOTAL/TOTVAL)
WRITE $JUSTIFY(%,11,2)
+79 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+80 ;
+81 ;*98 Modified section to display a new section header, item type count,
+82 ;and display "$ONHAND" by specific type (Standard/ODI/All)
+83 ;
+84 WRITE !!,"# "_PRCPTP2_" ITEMS",?13
SET ITEMCTA=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"CNT",ACCT))
SET ITEMCTA=ITEMCTA+%
WRITE $JUSTIFY(%,11,0)
+85 WRITE $JUSTIFY(ITEMCTA,11,0)
+86 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+87 ;
+88 WRITE !!,"INVENTORY VALUE"
+89 WRITE !,"$ "_PRCPTP,?14
SET TOTVAL=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"VALUE",ACCT))
SET TOTVAL=TOTVAL+%
WRITE $$SHOWVALU(%)
+90 WRITE $$SHOWVALU(TOTVAL)
+91 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+92 WRITE !,"$ DUEINS",?14
SET X=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"DUEIN",ACCT))
SET X=X+%
WRITE $$SHOWVALU(%)
+93 WRITE $$SHOWVALU(X)
+94 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+95 WRITE !,"$ DUEOUTS",?14
SET X=0
FOR ACCT=1,2,3,6,8
SET %=$GET(^TMP($JOB,NODE1,"DUEOUT",ACCT))
SET X=X+%
WRITE $$SHOWVALU(%)
+96 WRITE $$SHOWVALU(X)
+97 IF $Y>(IOSL-7)
DO LC
if $GET(PRCPFLAG)
GOTO Q
+98 ;
+99 ;*98 Modified report to not show the section addressing nonissuable
+100 ;items for primary and secondary inventory points
+101 QUIT
+102 ;
+103 ;
Q ;Tag ends printing and exits routine
+1 DO END^PRCPUREP
+2 DO ^%ZISC
QUIT
+3 ;
+4 ;
SHOWVALU(V1) ;show value
+1 NEW %
SET %="+"
if +V1=0
SET %=" "
IF V1<0
SET V1=-V1
SET %="-"
+2 QUIT $JUSTIFY(V1,10,2)_%
+3 ;
LC ;*98 Moved line control logic into subroutines
+1 IF SCREEN
WRITE !
DO P^PRCPUREP
IF $DATA(PRCPFLAG)
QUIT
+2 ;
HEAD ;heading
+1 NEW PRCPT
+2 SET %=NOW_" PAGE: "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+3 WRITE !,"STOCK STATUS REPORT FOR: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
+4 ;*98 Added type of reporting (Standard/ODI/All) to header
+5 SET PRCPT=PRCPTP_" ITEMS"
+6 WRITE !?5,"TRANSACTIONS FOR THE MONTH-YEAR: ",MONTH,?(80-$LENGTH(PRCPT)),PRCPT
+7 ;
+8 WRITE !,"SUMMARY",?14,$JUSTIFY("ACCT 1",11),$JUSTIFY("ACCT 2",11),$JUSTIFY("ACCT 3",11),$JUSTIFY("ACCT 6",11),$JUSTIFY("ACCT 8",11),$JUSTIFY("TOTAL",11)
+9 SET %=""
SET $PIECE(%,"-",81)=""
WRITE !,%
+10 QUIT
