- PRCPRSTK ;WISC/RFJ/VAC-where is an item stocked ; 2/19/07 12:51pm
- ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;*98 Modified to accommodate On Demand Items.
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- N %,DATA,DATE,DESC,I,INVPT,ITEMDA,NSN,PAGE,PRCPFLAG,SCREEN,TYPE,X,Y
- N ODITEM,ODINVPT
- ITEM S ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","") Q:'ITEMDA
- S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK W !! G ITEM
- . S ZTDESC="Display Where an Item is Stocked",ZTRTN="DQ^PRCPRSTK"
- . S ZTSAVE("PRCP*")="",ZTSAVE("ITEMDA")="",ZTSAVE("ZTREQ")="@"
- W !!,"<*> please wait <*>"
- DQ ;queue comes here
- K ^TMP($J,"PRCPRSTK"),PRCPFLAG S INVPT=0 F S INVPT=$O(^PRCP(445,"AE",ITEMDA,INVPT)) Q:'INVPT S %=$G(^PRCP(445,INVPT,0)) I %'="" S I=$P(%,"^"),TYPE=$P(%,"^",3) S:I="" I="??" S %=$G(^PRCP(445,INVPT,1,ITEMDA,0)) I %'="" D
- . S TYPE=$S(TYPE="W":"WAREHOUSE",TYPE="P":"PRIMARY",TYPE="S":"SECONDARY",1:" "),^TMP($J,"PRCPRSTK",TYPE,I)=+$P(%,"^",7)_"^"_$J($$UNITVAL^PRCPUX1($P(%,"^",14),$P(%,"^",5)," / "),12)_"^"_INVPT
- D NOW^%DTC S Y=% D DD^%DT S DATE=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP,NSN=$$NSN^PRCPUX1(ITEMDA),DESC=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) U IO D H
- S TYPE="" F S TYPE=$O(^TMP($J,"PRCPRSTK",TYPE)) Q:TYPE="" S I="" F S I=$O(^TMP($J,"PRCPRSTK",TYPE,I)) Q:I="" S DATA=^(I) D
- . S ODINVPT=$P(DATA,"^",3),ODITEM=$$ODITEM^PRCPUX2(ODINVPT,ITEMDA)
- . I ODITEM="W" S ODITEM=""
- . I ODITEM="Y" S ODITEM="D"
- . W !,$E(TYPE,1,4),?12,I,?48,ODITEM,?50,$J($P(DATA,"^"),10),?66,$P(DATA,"^",2)
- . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP S:$D(PRCPFLAG) (I,TYPE)="zzzzzz" Q:$D(PRCPFLAG) D H
- I '$D(PRCPFLAG) D END^PRCPUREP
- D ^%ZISC K ^TMP($J,"PRCPRSTK")
- I '$D(ZTQUEUED) W !! G ITEM
- Q
- ;
- H S %=DATE_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
- W $C(13),"DISPLAY WHERE AN ITEM IS STOCKED",?(80-$L(%)),%,!?4,"PRINTED BY INVENTORY POINT: ",PRCP("IN")
- W !?4,"NSN: ",NSN,?30,$E(DESC,1,30),?62,"[#",ITEMDA,"]"
- W !,?48,"O"
- W ?55,"QTY",?72,"UNIT PER"
- W !,"TYPE",?12,"SITE-DISTRIBUTION POINT"
- W ?48,"D"
- W ?53,"ON-HAND",?73,"ISSUE"
- S %="",$P(%,"-",81)="" W !,% Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRSTK 2198 printed Feb 18, 2025@23:41:57 Page 2
- PRCPRSTK ;WISC/RFJ/VAC-where is an item stocked ; 2/19/07 12:51pm
- +1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;*98 Modified to accommodate On Demand Items.
- +4 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +5 NEW %,DATA,DATE,DESC,I,INVPT,ITEMDA,NSN,PAGE,PRCPFLAG,SCREEN,TYPE,X,Y
- +6 NEW ODITEM,ODINVPT
- ITEM SET ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","")
- if 'ITEMDA
- QUIT
- +1 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +2 SET ZTDESC="Display Where an Item is Stocked"
- SET ZTRTN="DQ^PRCPRSTK"
- +3 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("ITEMDA")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- WRITE !!
- GOTO ITEM
- +4 WRITE !!,"<*> please wait <*>"
- DQ ;queue comes here
- +1 KILL ^TMP($JOB,"PRCPRSTK"),PRCPFLAG
- SET INVPT=0
- FOR
- SET INVPT=$ORDER(^PRCP(445,"AE",ITEMDA,INVPT))
- if 'INVPT
- QUIT
- SET %=$GET(^PRCP(445,INVPT,0))
- IF %'=""
- SET I=$PIECE(%,"^")
- SET TYPE=$PIECE(%,"^",3)
- if I=""
- SET I="??"
- SET %=$GET(^PRCP(445,INVPT,1,ITEMDA,0))
- IF %'=""
- Begin DoDot:1
- +2 SET TYPE=$SELECT(TYPE="W":"WAREHOUSE",TYPE="P":"PRIMARY",TYPE="S":"SECONDARY",1:" ")
- SET ^TMP($JOB,"PRCPRSTK",TYPE,I)=+$PIECE(%,"^",7)_"^"_$JUSTIFY($$UNITVAL^PRCPUX1($PIECE(%,"^",14),$PIECE(%,"^",5)," / "),12)_"^"_INVPT
- End DoDot:1
- +3 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET DATE=Y
- SET PAGE=1
- SET SCREEN=$$SCRPAUSE^PRCPUREP
- SET NSN=$$NSN^PRCPUX1(ITEMDA)
- SET DESC=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
- USE IO
- DO H
- +4 SET TYPE=""
- FOR
- SET TYPE=$ORDER(^TMP($JOB,"PRCPRSTK",TYPE))
- if TYPE=""
- QUIT
- SET I=""
- FOR
- SET I=$ORDER(^TMP($JOB,"PRCPRSTK",TYPE,I))
- if I=""
- QUIT
- SET DATA=^(I)
- Begin DoDot:1
- +5 SET ODINVPT=$PIECE(DATA,"^",3)
- SET ODITEM=$$ODITEM^PRCPUX2(ODINVPT,ITEMDA)
- +6 IF ODITEM="W"
- SET ODITEM=""
- +7 IF ODITEM="Y"
- SET ODITEM="D"
- +8 WRITE !,$EXTRACT(TYPE,1,4),?12,I,?48,ODITEM,?50,$JUSTIFY($PIECE(DATA,"^"),10),?66,$PIECE(DATA,"^",2)
- +9 IF $Y>(IOSL-4)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- SET (I,TYPE)="zzzzzz"
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- End DoDot:1
- +10 IF '$DATA(PRCPFLAG)
- DO END^PRCPUREP
- +11 DO ^%ZISC
- KILL ^TMP($JOB,"PRCPRSTK")
- +12 IF '$DATA(ZTQUEUED)
- WRITE !!
- GOTO ITEM
- +13 QUIT
- +14 ;
- H SET %=DATE_" PAGE "_PAGE
- SET PAGE=PAGE+1
- IF PAGE'=2!(SCREEN)
- WRITE @IOF
- +1 WRITE $CHAR(13),"DISPLAY WHERE AN ITEM IS STOCKED",?(80-$LENGTH(%)),%,!?4,"PRINTED BY INVENTORY POINT: ",PRCP("IN")
- +2 WRITE !?4,"NSN: ",NSN,?30,$EXTRACT(DESC,1,30),?62,"[#",ITEMDA,"]"
- +3 WRITE !,?48,"O"
- +4 WRITE ?55,"QTY",?72,"UNIT PER"
- +5 WRITE !,"TYPE",?12,"SITE-DISTRIBUTION POINT"
- +6 WRITE ?48,"D"
- +7 WRITE ?53,"ON-HAND",?73,"ISSUE"
- +8 SET %=""
- SET $PIECE(%,"-",81)=""
- WRITE !,%
- QUIT