- 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 Jan 18, 2025@03:14:24 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