PRCPCRDC ;WISC/RFJ-case cart definition ;01 Sep 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
N ALLCARTS,X
K X S X(1)="The Definition Case Cart Report will print a list of selected case carts displaying the items and quantities needed to assemble a case cart."
D DISPLAY^PRCPUX2(40,79,.X)
D CASECART^PRCPCRU1
I '$O(^TMP($J,"PRCPCARTS",0)),'$D(ALLCARTS) Q
I $D(ALLCARTS) W !!,"NOTE -- This option will use a lot of paper!"
W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q
. S ZTDESC="Case Cart Definition Report",ZTRTN="DQ^PRCPCRDC"
. S ZTSAVE("PRCP*")="",ZTSAVE("ALLCARTS")="",ZTSAVE("^TMP($J,""PRCPCARTS"",")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ; queue starts here
N CCITEM,PRCPFLAG,SCREEN,X,Y
S SCREEN=$$SCRPAUSE^PRCPUREP
I $D(ALLCARTS) S CCITEM=0 F S CCITEM=$O(^PRCP(445.7,CCITEM)) Q:'CCITEM!($G(PRCPFLAG)) D
. D PRINT I $G(PRCPFLAG) Q
. I SCREEN,$O(^PRCP(445.7,CCITEM)) D P^PRCPUREP
;
I '$D(ALLCARTS) S CCITEM=0 F S CCITEM=$O(^TMP($J,"PRCPCARTS",CCITEM)) Q:'CCITEM D PRINT
Q D ^%ZISC K ^TMP($J,"PRCPCARTS")
Q
;
;
PRINT ; print a case cart definition
N %,%I,CATALOG,CCDATA,CCDATE,CCLOC,CCNAME,CCUSER,DATA,EDITDATE,EDITUSER,ITEMDA,LOCATION,NOW,ONHAND,PAGE,PRCPINNM,PRCPINPT,REUSABLE,VENDOR
S CCDATA=$G(^PRCP(445.7,CCITEM,0))
S PRCPINPT=+$P(CCDATA,"^",2),PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
S CCNAME=$$DESCR^PRCPUX1(PRCPINPT,CCITEM),CCUSER=$$USER^PRCPUREP($P(CCDATA,"^",3)),Y=$P(CCDATA,"^",4) D DD^%DT S CCDATE=Y,EDITUSER=$$USER^PRCPUREP($P(CCDATA,"^",5)),Y=$P(CCDATA,"^",6) D DD^%DT S EDITDATE=Y
S CCLOC=$$STORAGE^PRCPESTO(PRCPINPT,CCITEM),ONHAND=$G(^PRCP(445,PRCPINPT,1,CCITEM,0)),ONHAND=$S(ONHAND="":"NOT STORED IN INVENTORY POINT",1:+$P(ONHAND,"^",7))
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1 U IO D H
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.7,CCITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) S DATA=$G(^(ITEMDA,0)) D
. S VENDOR=$$MANDSRCE^PRCPU441(ITEMDA),CATALOG=$P($G(^PRC(441,ITEMDA,2,+VENDOR,0)),"^",4) I $E(CATALOG,16)'="" S CATALOG=$E(CATALOG,1,15)_"+"
. S LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
. S REUSABLE=$$REUSABLE^PRCPU441(ITEMDA),REUSABLE=$S(REUSABLE:"R",1:"D")
. W !,$J(+$P(DATA,"^",2),7),?10,$E($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,20),?31,ITEMDA,?38,REUSABLE,?40,VENDOR,?48,CATALOG,?67,$E(LOCATION,1,12)
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
I $G(PRCPFLAG) Q
I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
W !!,"SPECIAL INSTRUCTIONS/REMARKS:"
S X=0 F S X=$O(^PRCP(445.7,CCITEM,2,X)) Q:'X!($G(PRCPFLAG)) S DATA=$G(^(X,0)) D
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. W !,DATA
D END^PRCPUREP
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"DEFINITION OF CASE CART REPORT FOR: ",$E(PRCPINNM,1,20),?(80-$L(%)),%
W !?9,"NAME: ",CCNAME," (#",CCITEM,") ",?46,"LOCATION: ",CCLOC
W !?15,"CURRENT QUANTITY ASSEMBLED: ",ONHAND
W !?3,"CREATED BY: ",CCUSER,?50,"DATE: ",CCDATE
W !?1,"LAST EDIT BY: ",EDITUSER,?50,"DATE: ",EDITDATE
S %="",$P(%,"-",81)=""
W !,$J("QTY",7),?10,"DESCRIPTION",?31,"MI#",?37,"RD",?40,"VEND#",?48,"CATALOG#",?67,"LOCATION",!,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCRDC 3326 printed Sep 23, 2025@19:49:14 Page 2
PRCPCRDC ;WISC/RFJ-case cart definition ;01 Sep 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 NEW ALLCARTS,X
+5 KILL X
SET X(1)="The Definition Case Cart Report will print a list of selected case carts displaying the items and quantities needed to assemble a case cart."
+6 DO DISPLAY^PRCPUX2(40,79,.X)
+7 DO CASECART^PRCPCRU1
+8 IF '$ORDER(^TMP($JOB,"PRCPCARTS",0))
IF '$DATA(ALLCARTS)
QUIT
+9 IF $DATA(ALLCARTS)
WRITE !!,"NOTE -- This option will use a lot of paper!"
+10 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+11 SET ZTDESC="Case Cart Definition Report"
SET ZTRTN="DQ^PRCPCRDC"
+12 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("ALLCARTS")=""
SET ZTSAVE("^TMP($J,""PRCPCARTS"",")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO Q
QUIT
+13 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW CCITEM,PRCPFLAG,SCREEN,X,Y
+2 SET SCREEN=$$SCRPAUSE^PRCPUREP
+3 IF $DATA(ALLCARTS)
SET CCITEM=0
FOR
SET CCITEM=$ORDER(^PRCP(445.7,CCITEM))
if 'CCITEM!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+4 DO PRINT
IF $GET(PRCPFLAG)
QUIT
+5 IF SCREEN
IF $ORDER(^PRCP(445.7,CCITEM))
DO P^PRCPUREP
End DoDot:1
+6 ;
+7 IF '$DATA(ALLCARTS)
SET CCITEM=0
FOR
SET CCITEM=$ORDER(^TMP($JOB,"PRCPCARTS",CCITEM))
if 'CCITEM
QUIT
DO PRINT
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPCARTS")
+1 QUIT
+2 ;
+3 ;
PRINT ; print a case cart definition
+1 NEW %,%I,CATALOG,CCDATA,CCDATE,CCLOC,CCNAME,CCUSER,DATA,EDITDATE,EDITUSER,ITEMDA,LOCATION,NOW,ONHAND,PAGE,PRCPINNM,PRCPINPT,REUSABLE,VENDOR
+2 SET CCDATA=$GET(^PRCP(445.7,CCITEM,0))
+3 SET PRCPINPT=+$PIECE(CCDATA,"^",2)
SET PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
+4 SET CCNAME=$$DESCR^PRCPUX1(PRCPINPT,CCITEM)
SET CCUSER=$$USER^PRCPUREP($PIECE(CCDATA,"^",3))
SET Y=$PIECE(CCDATA,"^",4)
DO DD^%DT
SET CCDATE=Y
SET EDITUSER=$$USER^PRCPUREP($PIECE(CCDATA,"^",5))
SET Y=$PIECE(CCDATA,"^",6)
DO DD^%DT
SET EDITDATE=Y
+5 SET CCLOC=$$STORAGE^PRCPESTO(PRCPINPT,CCITEM)
SET ONHAND=$GET(^PRCP(445,PRCPINPT,1,CCITEM,0))
SET ONHAND=$SELECT(ONHAND="":"NOT STORED IN INVENTORY POINT",1:+$PIECE(ONHAND,"^",7))
+6 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
USE IO
DO H
+7 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445.7,CCITEM,1,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(ITEMDA,0))
Begin DoDot:1
+8 SET VENDOR=$$MANDSRCE^PRCPU441(ITEMDA)
SET CATALOG=$PIECE($GET(^PRC(441,ITEMDA,2,+VENDOR,0)),"^",4)
IF $EXTRACT(CATALOG,16)'=""
SET CATALOG=$EXTRACT(CATALOG,1,15)_"+"
+9 SET LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
+10 SET REUSABLE=$$REUSABLE^PRCPU441(ITEMDA)
SET REUSABLE=$SELECT(REUSABLE:"R",1:"D")
+11 WRITE !,$JUSTIFY(+$PIECE(DATA,"^",2),7),?10,$EXTRACT($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,20),?31,ITEMDA,?38,REUSABLE,?40,VENDOR,?48,CATALOG,?67,$EXTRACT(LOCATION,1,12)
+12 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:1
+13 IF $GET(PRCPFLAG)
QUIT
+14 IF $Y>(IOSL-7)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+15 WRITE !!,"SPECIAL INSTRUCTIONS/REMARKS:"
+16 SET X=0
FOR
SET X=$ORDER(^PRCP(445.7,CCITEM,2,X))
if 'X!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(X,0))
Begin DoDot:1
+17 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+18 WRITE !,DATA
End DoDot:1
+19 DO END^PRCPUREP
+20 QUIT
+21 ;
+22 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"DEFINITION OF CASE CART REPORT FOR: ",$EXTRACT(PRCPINNM,1,20),?(80-$LENGTH(%)),%
+2 WRITE !?9,"NAME: ",CCNAME," (#",CCITEM,") ",?46,"LOCATION: ",CCLOC
+3 WRITE !?15,"CURRENT QUANTITY ASSEMBLED: ",ONHAND
+4 WRITE !?3,"CREATED BY: ",CCUSER,?50,"DATE: ",CCDATE
+5 WRITE !?1,"LAST EDIT BY: ",EDITUSER,?50,"DATE: ",EDITDATE
+6 SET %=""
SET $PIECE(%,"-",81)=""
+7 WRITE !,$JUSTIFY("QTY",7),?10,"DESCRIPTION",?31,"MI#",?37,"RD",?40,"VEND#",?48,"CATALOG#",?67,"LOCATION",!,%
+8 QUIT
