PRCPCROC ;WISC/RFJ-operation code case cart link report ; 06/23/2009 2:14 PM
;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
N ALLCARTS,X
K X S X(1)="The Operation Code-Case Cart Link Report will print a list of selected case carts displaying the operation codes linked to the case cart."
D DISPLAY^PRCPUX2(40,79,.X)
D CASECART^PRCPCRU1
I '$O(^TMP($J,"PRCPCARTS",0)),'$D(ALLCARTS) Q
W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q
. S ZTDESC="Operation Code-Case Cart Link Report",ZTRTN="DQ^PRCPCROC"
. S ZTSAVE("PRCP*")="",ZTSAVE("ALLCARTS")="",ZTSAVE("^TMP($J,""PRCPCARTS"",")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ; queue starts here
N %I,CCDATA,CCITEM,CCNAME,DATA,NOW,ONHAND,OPCODE,PAGE,PRCPFLAG,PRCPINNM,PRCPINPT,SCREEN,X,Y
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
I $D(ALLCARTS) S CCITEM=0 F S CCITEM=$O(^PRCP(445.7,CCITEM)) Q:'CCITEM!($G(PRCPFLAG)) D PRINT
;
I '$D(ALLCARTS) S CCITEM=0 F S CCITEM=$O(^TMP($J,"PRCPCARTS",CCITEM)) Q:'CCITEM D PRINT
I '$G(PRCPFLAG) D END^PRCPUREP
Q D ^%ZISC K ^TMP($J,"PRCPCARTS")
Q
;
;
PRINT ; print a case cart operation code link
I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
S CCDATA=$G(^PRCP(445.7,CCITEM,0))
S PRCPINPT=+$P(CCDATA,"^",2),PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
S CCNAME=$$DESCR^PRCPUX1(PRCPINPT,CCITEM)
S ONHAND=$P($G(^PRCP(445,PRCPINPT,1,CCITEM,0)),"^",7)
W !!,$E(CCNAME,1,30),?32,CCITEM,?40,$E(PRCPINNM,1,20),?70,$J(ONHAND,10)
S OPCODE=0 F S OPCODE=$O(^PRCP(445.7,CCITEM,3,OPCODE)) Q:'OPCODE!($G(PRCPFLAG)) S DATA=$G(^(OPCODE,0)) D
. N A
. S A=$$ICPT^PRCPCUT1(OPCODE,$P(CCDATA,U,4)) W !,?5,$P(A,U),?12,$P(A,U,2)
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"OPERATION CODE-CASE CART LINK REPORT",?(80-$L(%)),%
S %="",$P(%,"-",81)=""
W !,"DESCRIPTION",?32,"MI#",?40,"ORDER FROM INV PT",?70,$J("QTY ONHAND",10),!,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCROC 2135 printed Dec 13, 2024@02:13:13 Page 2
PRCPCROC ;WISC/RFJ-operation code case cart link report ; 06/23/2009 2:14 PM
+1 ;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6
+2 ;Per VHA Directive 2004-038, 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 Operation Code-Case Cart Link Report will print a list of selected case carts displaying the operation codes linked to the 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 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTDESC="Operation Code-Case Cart Link Report"
SET ZTRTN="DQ^PRCPCROC"
+11 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
+12 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW %I,CCDATA,CCITEM,CCNAME,DATA,NOW,ONHAND,OPCODE,PAGE,PRCPFLAG,PRCPINNM,PRCPINPT,SCREEN,X,Y
+2 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+3 IF $DATA(ALLCARTS)
SET CCITEM=0
FOR
SET CCITEM=$ORDER(^PRCP(445.7,CCITEM))
if 'CCITEM!($GET(PRCPFLAG))
QUIT
DO PRINT
+4 ;
+5 IF '$DATA(ALLCARTS)
SET CCITEM=0
FOR
SET CCITEM=$ORDER(^TMP($JOB,"PRCPCARTS",CCITEM))
if 'CCITEM
QUIT
DO PRINT
+6 IF '$GET(PRCPFLAG)
DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPCARTS")
+1 QUIT
+2 ;
+3 ;
PRINT ; print a case cart operation code link
+1 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+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)
+5 SET ONHAND=$PIECE($GET(^PRCP(445,PRCPINPT,1,CCITEM,0)),"^",7)
+6 WRITE !!,$EXTRACT(CCNAME,1,30),?32,CCITEM,?40,$EXTRACT(PRCPINNM,1,20),?70,$JUSTIFY(ONHAND,10)
+7 SET OPCODE=0
FOR
SET OPCODE=$ORDER(^PRCP(445.7,CCITEM,3,OPCODE))
if 'OPCODE!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(OPCODE,0))
Begin DoDot:1
+8 NEW A
+9 SET A=$$ICPT^PRCPCUT1(OPCODE,$PIECE(CCDATA,U,4))
WRITE !,?5,$PIECE(A,U),?12,$PIECE(A,U,2)
+10 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:1
+11 QUIT
+12 ;
+13 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"OPERATION CODE-CASE CART LINK REPORT",?(80-$LENGTH(%)),%
+2 SET %=""
SET $PIECE(%,"-",81)=""
+3 WRITE !,"DESCRIPTION",?32,"MI#",?40,"ORDER FROM INV PT",?70,$JUSTIFY("QTY ONHAND",10),!,%
+4 QUIT
