PRCPRAVP ;WISC/RFJ-availability list report (primary) ;18 May 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
PRIMARY ; availability list for primary (called from prcpravl)
N GROUPALL,PRCPSUMM
K X S X(1)="The Availability Listing will display the current quantity and value of the inventory point items. The report will sort Primary or Secondary inventory items by Group Category and Description." D DISPLAY^PRCPUX2(40,79,.X)
S PRCPSUMM=$$SUMMARY^PRCPURS0 I PRCPSUMM<0 Q
I PRCPSUMM S GROUPALL=1 G DEVICE
K X S X(1)="Select the Group Categories to display" W ! D DISPLAY^PRCPUX2(2,40,.X)
D GROUPSEL^PRCPURS1(PRCP("I"))
I '$G(GROUPALL),'$O(^TMP($J,"PRCPURS1","YES",0)) W !,"*** NO GROUP CATEGORIES SELECTED !" D Q Q
W !,"NOTE: The report will",$S('$G(GROUPALL):" NOT",1:"")," include items not stored in a group category."
DEVICE W ! S %ZIS="Q" D ^%ZIS G:POP Q I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q
. S ZTDESC="Primary Availability Listing",ZTRTN="DQ^PRCPRAVP"
. S ZTSAVE("PRCP*")="",ZTSAVE("GROUPALL")="",ZTSAVE("^TMP($J,""PRCPURS1"",")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ; queue starts here
N %I,DESCR,DESCRIP,GROUP,GROUPNM,ITEMDA,ITEMDATA,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL,TOTINV,X,Y
K ^TMP($J,"PRCPRAVP"),^TMP($J,"PRCPRAVP TOT")
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S ITEMDATA=$G(^(ITEMDA,0)) D
. S GROUP=+$P(ITEMDATA,"^",21)
. I 'GROUP,'$G(GROUPALL) Q
. I $G(GROUPALL),$D(^TMP($J,"PRCPURS1","NO",GROUP)) Q
. I '$G(GROUPALL),'$D(^TMP($J,"PRCPURS1","YES",GROUP)) Q
. S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
. I GROUPNM'="" S GROUPNM=$E(GROUPNM,1,20)_" (#"_GROUP_")"
. S:GROUPNM="" GROUPNM=" "
. S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
. S ^TMP($J,"PRCPRAVP",GROUPNM,$E(DESCR,1,15),ITEMDA)=DESCR
; print report
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
S GROUPNM="" F S GROUPNM=$O(^TMP($J,"PRCPRAVP",GROUPNM)) Q:GROUPNM=""!($G(PRCPFLAG)) D
. I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. W:'PRCPSUMM !!?5,"GROUP NAME: ",$S(GROUPNM=" ":"<<ITEMS NOT STORED IN A GROUP CATEGORY>>",1:GROUPNM)
. S DESCR="" F S DESCR=$O(^TMP($J,"PRCPRAVP",GROUPNM,DESCR)) Q:DESCR=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRAVP",GROUPNM,DESCR,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. . S DESCRIP=^TMP($J,"PRCPRAVP",GROUPNM,DESCR,ITEMDA)
. . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
. . S NSN=$$NSN^PRCPUX1(ITEMDA) S:NSN="" NSN="<<NO NSN>>"
. . W:'PRCPSUMM !!,$TR(NSN,"-"),?15,$E(DESCRIP,1,38),?54,"[",ITEMDA,"]",?63,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8),?79,$S($P(ITEMDATA,"^",26)="Y":"*",1:"")
. . W:'PRCPSUMM !,$J("ONHAND",16),$J("DUEIN",8),$J("DUEOUT",8),$J("REORDPT",8),$J("ISSMUL",8),$J("AVGCOST",10),$J("TOTVALUE",22)
. . W:'PRCPSUMM !,$J(+$P(ITEMDATA,"^",7),16),$J($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),8),$J($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA),8),$J(+$P(ITEMDATA,"^",10),8)
. . W:'PRCPSUMM $J($P(ITEMDATA,"^",25),8),$J($P(ITEMDATA,"^",22),10,3)
. . I +$J($P(ITEMDATA,"^",7)*$P(ITEMDATA,"^",22),0,2)'=+$P(ITEMDATA,"^",27) W:'PRCPSUMM " <=/=>"
. . W:'PRCPSUMM ?64,$J($P(ITEMDATA,"^",27),15,2)
. . S ^TMP($J,"PRCPRAVP TOT",GROUPNM)=$G(^TMP($J,"PRCPRAVP TOT",GROUPNM))+$P(ITEMDATA,"^",27)
. . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
I $G(PRCPFLAG) D Q Q
I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
W !!?2,"TOTALS :",?40,"INVENTORY VALUE",!?2,"--------",?40,"---------------"
S TOTINV=0,GROUPNM="" F S GROUPNM=$O(^TMP($J,"PRCPRAVP TOT",GROUPNM)) Q:GROUPNM=""!($G(PRCPFLAG)) S TOTAL=^(GROUPNM) D
. W !?2,"GROUP ",$S(GROUPNM=" ":"<<NONE>>",1:GROUPNM),?40,":",$J(TOTAL,14,2)
. S TOTINV=TOTINV+TOTAL
. I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
W !?2,"--------",?40,"---------------"
W !?2,"TOTALS :",?40,$J(TOTINV,15,2)
D END^PRCPUREP
Q D ^%ZISC K ^TMP($J,"PRCPRAVP"),^TMP($J,"PRCPRAVP TOT"),^TMP($J,"PRCPRURS1")
Q
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"AVAILABILITY LISTING FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
S %="",$P(%,"-",81)=""
I PRCPSUMM W !?1,"*** ONLY SUMMARY OF ITEMS PRINTED ***",!,% Q
W !,"DESCR",?15,"DESCRIPTION",?40,"MI",$J("UNIT/IS",14),?77,"KWZ",!,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRAVP 4555 printed Sep 23, 2025@19:50:40 Page 2
PRCPRAVP ;WISC/RFJ-availability list report (primary) ;18 May 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PRIMARY ; availability list for primary (called from prcpravl)
+1 NEW GROUPALL,PRCPSUMM
+2 KILL X
SET X(1)="The Availability Listing will display the current quantity and value of the inventory point items. The report will sort Primary or Secondary inventory items by Group Category and Description."
DO DISPLAY^PRCPUX2(40,79,.X)
+3 SET PRCPSUMM=$$SUMMARY^PRCPURS0
IF PRCPSUMM<0
QUIT
+4 IF PRCPSUMM
SET GROUPALL=1
GOTO DEVICE
+5 KILL X
SET X(1)="Select the Group Categories to display"
WRITE !
DO DISPLAY^PRCPUX2(2,40,.X)
+6 DO GROUPSEL^PRCPURS1(PRCP("I"))
+7 IF '$GET(GROUPALL)
IF '$ORDER(^TMP($JOB,"PRCPURS1","YES",0))
WRITE !,"*** NO GROUP CATEGORIES SELECTED !"
DO Q
QUIT
+8 WRITE !,"NOTE: The report will",$SELECT('$GET(GROUPALL):" NOT",1:"")," include items not stored in a group category."
DEVICE WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO Q
IF $DATA(IO("Q"))
Begin DoDot:1
+1 SET ZTDESC="Primary Availability Listing"
SET ZTRTN="DQ^PRCPRAVP"
+2 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("GROUPALL")=""
SET ZTSAVE("^TMP($J,""PRCPURS1"",")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO Q
QUIT
+3 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW %I,DESCR,DESCRIP,GROUP,GROUPNM,ITEMDA,ITEMDATA,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL,TOTINV,X,Y
+2 KILL ^TMP($JOB,"PRCPRAVP"),^TMP($JOB,"PRCPRAVP TOT")
+3 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
SET ITEMDATA=$GET(^(ITEMDA,0))
Begin DoDot:1
+4 SET GROUP=+$PIECE(ITEMDATA,"^",21)
+5 IF 'GROUP
IF '$GET(GROUPALL)
QUIT
+6 IF $GET(GROUPALL)
IF $DATA(^TMP($JOB,"PRCPURS1","NO",GROUP))
QUIT
+7 IF '$GET(GROUPALL)
IF '$DATA(^TMP($JOB,"PRCPURS1","YES",GROUP))
QUIT
+8 SET GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
+9 IF GROUPNM'=""
SET GROUPNM=$EXTRACT(GROUPNM,1,20)_" (#"_GROUP_")"
+10 if GROUPNM=""
SET GROUPNM=" "
+11 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
if DESCR=""
SET DESCR=" "
+12 SET ^TMP($JOB,"PRCPRAVP",GROUPNM,$EXTRACT(DESCR,1,15),ITEMDA)=DESCR
End DoDot:1
+13 ; print report
+14 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+15 SET GROUPNM=""
FOR
SET GROUPNM=$ORDER(^TMP($JOB,"PRCPRAVP",GROUPNM))
if GROUPNM=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+16 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+17 if 'PRCPSUMM
WRITE !!?5,"GROUP NAME: ",$SELECT(GROUPNM=" ":"<<ITEMS NOT STORED IN A GROUP CATEGORY>>",1:GROUPNM)
+18 SET DESCR=""
FOR
SET DESCR=$ORDER(^TMP($JOB,"PRCPRAVP",GROUPNM,DESCR))
if DESCR=""!($GET(PRCPFLAG))
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRAVP",GROUPNM,DESCR,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+19 SET DESCRIP=^TMP($JOB,"PRCPRAVP",GROUPNM,DESCR,ITEMDA)
+20 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
+21 SET NSN=$$NSN^PRCPUX1(ITEMDA)
if NSN=""
SET NSN="<<NO NSN>>"
+22 if 'PRCPSUMM
WRITE !!,$TRANSLATE(NSN,"-"),?15,$EXTRACT(DESCRIP,1,38),?54,"[",ITEMDA,"]",?63,$JUSTIFY($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8),?79,$SELECT($PIECE(ITEMDATA,"^",26)="Y":"*",1:"")
+23 if 'PRCPSUMM
WRITE !,$JUSTIFY("ONHAND",16),$JUSTIFY("DUEIN",8),$JUSTIFY("DUEOUT",8),$JUSTIFY("REORDPT",8),$JUSTIFY("ISSMUL",8),$JUSTIFY("AVGCOST",10),$JUSTIFY("TOTVALUE",22)
+24 if 'PRCPSUMM
WRITE !,$JUSTIFY(+$PIECE(ITEMDATA,"^",7),16),$JUSTIFY($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),8),$JUSTIFY($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA),8),$JUSTIFY(+$PIECE(ITEMDATA,"^",10),8)
+25 if 'PRCPSUMM
WRITE $JUSTIFY($PIECE(ITEMDATA,"^",25),8),$JUSTIFY($PIECE(ITEMDATA,"^",22),10,3)
+26 IF +$JUSTIFY($PIECE(ITEMDATA,"^",7)*$PIECE(ITEMDATA,"^",22),0,2)'=+$PIECE(ITEMDATA,"^",27)
if 'PRCPSUMM
WRITE " <=/=>"
+27 if 'PRCPSUMM
WRITE ?64,$JUSTIFY($PIECE(ITEMDATA,"^",27),15,2)
+28 SET ^TMP($JOB,"PRCPRAVP TOT",GROUPNM)=$GET(^TMP($JOB,"PRCPRAVP TOT",GROUPNM))+$PIECE(ITEMDATA,"^",27)
+29 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:2
+30 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
End DoDot:1
+31 IF $GET(PRCPFLAG)
DO Q
QUIT
+32 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+33 WRITE !!?2,"TOTALS :",?40,"INVENTORY VALUE",!?2,"--------",?40,"---------------"
+34 SET TOTINV=0
SET GROUPNM=""
FOR
SET GROUPNM=$ORDER(^TMP($JOB,"PRCPRAVP TOT",GROUPNM))
if GROUPNM=""!($GET(PRCPFLAG))
QUIT
SET TOTAL=^(GROUPNM)
Begin DoDot:1
+35 WRITE !?2,"GROUP ",$SELECT(GROUPNM=" ":"<<NONE>>",1:GROUPNM),?40,":",$JUSTIFY(TOTAL,14,2)
+36 SET TOTINV=TOTINV+TOTAL
+37 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:1
+38 WRITE !?2,"--------",?40,"---------------"
+39 WRITE !?2,"TOTALS :",?40,$JUSTIFY(TOTINV,15,2)
+40 DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPRAVP"),^TMP($JOB,"PRCPRAVP TOT"),^TMP($JOB,"PRCPRURS1")
+1 QUIT
+2 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"AVAILABILITY LISTING FOR: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
+2 SET %=""
SET $PIECE(%,"-",81)=""
+3 IF PRCPSUMM
WRITE !?1,"*** ONLY SUMMARY OF ITEMS PRINTED ***",!,%
QUIT
+4 WRITE !,"DESCR",?15,"DESCRIPTION",?40,"MI",$JUSTIFY("UNIT/IS",14),?77,"KWZ",!,%
+5 QUIT
