PRCPRIT1 ;WISC/RFJ/VAC-display item (print) ; 10/27/06 2:01pm
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
;Routine modified to show "D" for On-Demand Item and to correct
; column #IM heading
Q
;
;
DQ ;queue comes here
N %I,D,D0,ITEMDATA,PRCPDA,DATA,DATE,INVNAME,NOW,PAGE,PRCPFLAG,SCREEN,UNIT,X,Y,ODI,X1,X2,MASTDATA
D NOW^%DTC S Y=%,DATE=$E(%,1,7) D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP,INVNAME=$$INVNAME^PRCPUX1(INVPT) U IO D H
S MASTDATA=$G(^PRC(441,ITEMDA,0)),ITEMDATA=$G(^PRCP(445,INVPT,1,ITEMDA,0))
W !,$P(MASTDATA,"^",5),?19,$E($$DESCR^PRCPUX1(INVPT,ITEMDA),1,28),?49,"[#",ITEMDA,"]",?59,$E($$GROUPNM^PRCPEGRP(+$P(ITEMDATA,"^",21)),1,20)
; Insert logic to print ODI flag of "D"
I ODIFLAG="P" D
.W !,?8,"ON-DEMAND: "
.S ODI=""
.S ODI=$$ODITEM^PRCPUX2(INVPT,ITEMDA)
.I ODI="Y" W "D"
.W ?36,"BOC: ",$E($P($G(^PRCD(420.2,+$P(MASTDATA,"^",10),0)),"^"),1,39)
I ODIFLAG="W" D
.W ?14,"BOC: ",$E($P($G(^PRCD(420.2,+$P(MASTDATA,"^",10),0)),"^"),1,39)
S UNIT=$$UNIT^PRCPUX1(INVPT,ITEMDA," per ") W !?3,"UNIT per ISSUE: ",UNIT
W !?6,"QTY ON HAND: ",+$P(ITEMDATA,"^",7),?33,"DUE-IN: ",$$GETIN^PRCPUDUE(INVPT,ITEMDA),?60,"DUE-OUT: ",$$GETOUT^PRCPUDUE(INVPT,ITEMDA),!?6,"QTY NON-ISS: ",+$P(ITEMDATA,"^",19)
I $P(ITEMDATA,"^",26)="Y" W !?19,"** DELETE ITEM WHEN QTY ON HAND REACHES ZERO **"
W !?6,"TOTAL VALUE: ",$P(ITEMDATA,"^",27)
W !?5,"NORM STL LVL: ",$P(ITEMDATA,"^",9),?29,"REORDER PT: ",$P(ITEMDATA,"^",10),?55,"INT ORDER PT: ",$P(ITEMDATA,"^",4)
W !?4,"EMERGENCY LVL: ",$P(ITEMDATA,"^",11),?29,"ISSUE MULT: ",$P(ITEMDATA,"^",25),?54,"MIN ISSUE QTY: ",$P(ITEMDATA,"^",17)
I $P(ITEMDATA,"^",23) S Y=$P(ITEMDATA,"^",24) D DD^%DT W !?5,"TEMP STK LVL: ",$P(ITEMDATA,"^",23),?29,"UNTIL DATE: ",Y
S Y=$P(ITEMDATA,"^",3) D DD^%DT W !?8,"LAST COST: ",$P(ITEMDATA,"^",15),?29,"LAST REC'D: ",Y,?55,"AVERAGE COST: ",$P(ITEMDATA,"^",22)
W !?1,"MAIN STORAGE LOC: ",$$STORELOC^PRCPESTO(+$P(ITEMDATA,"^",6))
I $O(^PRCP(445,INVPT,1,ITEMDA,5,0)) D
. D HS S PRCPDA=0 F S PRCPDA=$O(^PRCP(445,INVPT,1,ITEMDA,5,PRCPDA)) Q:'PRCPDA!($G(PRCPFLAG)) S DATA=$G(^(PRCPDA,0)) D
. . W ! I $P(ITEMDATA,"^",12)=$P(DATA,"^") W ?3,"m"
. . S Y=$P(DATA,"^"),Y=$S(Y["PRC(440":$P($G(^PRC(440,+Y,0)),"^"),1:$P($G(^PRCP(445,+Y,0)),"^")) S:'+$P(DATA,"^",4) $P(DATA,"^",4)=1
. . W ?5,$E(Y,1,27),?37,"[#",+DATA,"]",?45,$J($P(DATA,"^",4),9),?68,$J($$UNITVAL^PRCPUX1($P(DATA,"^",3),$P(DATA,"^",2)," per "),11)
. . I $Y>(IOSL-5),$O(^PRCP(445,INVPT,1,ITEMDA,5,PRCPDA)) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H,HS
I $G(PRCPFLAG) D Q Q
I $O(^PRCP(445,INVPT,1,ITEMDA,7,0)) D
. I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
. D HO S PRCPDA=0 F S PRCPDA=$O(^PRCP(445,INVPT,1,ITEMDA,7,PRCPDA)) Q:'PRCPDA!($G(PRCPFLAG)) S DATA=$G(^(PRCPDA,0)) D
. . S:'+$P(DATA,"^",5) $P(DATA,"^",5)=1
. . W !?1,$P($G(^PRCS(410,PRCPDA,0)),"^"),?21,$J(+$P(DATA,"^",2),7),?32,$J(UNIT,11),?50,$J($P(DATA,"^",5),5),?57,$J($P(DATA,"^",2)/$P(DATA,"^",5),7),?68,$J($$UNITVAL^PRCPUX1($P(DATA,"^",4),$P(DATA,"^",3)," per "),11)
. . S D0=PRCPDA D STATUS^PRCSES W !?10,"REQUEST STATUS: ",X
. . I $Y>(IOSL-5),$O(^PRCP(445,INVPT,1,ITEMDA,7,PRCPDA)) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H,HO
I $G(PRCPFLAG) D Q Q
S X1=$E(DATE,1,5)_"01",X2=-180 D C^%DTC S X=$E(X,1,5)
I $O(^PRCP(445,INVPT,1,ITEMDA,2,X)) D
. I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
. D HU S PRCPDA=X F S PRCPDA=$O(^PRCP(445,INVPT,1,ITEMDA,2,PRCPDA)) Q:'PRCPDA!($G(PRCPFLAG)) S DATA=$G(^(PRCPDA,0)) D
. . W !?9,$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(PRCPDA,4,5))," ",17+$E(PRCPDA),$E(PRCPDA,2,3),?29,$J($P(DATA,"^",2),15),?47,$J($P(DATA,"^",3),17,3)
. . I $Y>(IOSL-5),$O(^PRCP(445,INVPT,1,ITEMDA,2,PRCPDA)) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H,HU
I $G(PRCPFLAG) D Q Q
I $O(^PRCP(445,INVPT,1,ITEMDA,3,X_"01")) D
. I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
. D HR S PRCPDA=X_"01" F S PRCPDA=$O(^PRCP(445,INVPT,1,ITEMDA,3,PRCPDA)) Q:'PRCPDA!($G(PRCPFLAG)) S DATA=$G(^(PRCPDA,0)) D
. . W !?9,$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(PRCPDA,4,5))," ",$E(PRCPDA,6,7),", ",17+$E(PRCPDA),$E(PRCPDA,2,3),?29,$J($P(DATA,"^",2),13)
. . I $Y>(IOSL-5),$O(^PRCP(445,INVPT,1,ITEMDA,3,PRCPDA)) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H,HR
I '$G(PRCPFLAG) D END^PRCPUREP
Q D ^%ZISC Q
;
;
H S %=NOW_" PAGE: "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"DISPLAY ITEM REPORT FOR ",INVNAME,?(80-$L(%)),%
S %="",$P(%,"-",81)="" W !,"NSN",?19,"DESCRIPTION",?49,"[IM#]",?59,"GROUP : DESCRIPTION",!,%
Q
;
;
HS ;header for procurement sources
W !?15,"-----POSSIBLE SOURCES (m=MANDATORY SOURCE)-----",!?5,"VENDOR",?37,"[#V]",?45,"CONV FACT",?68,"UNIT per REC"
Q
;
;
HO ;header for outstanding transactions
W !?22,"-----OUTSTANDING TRANSACTIONS-----",!?1,"TRANSACTION NO. QTY ORD in UNIT per ISS CONV FACT QTY REC in UNIT per REC"
Q
;
;
HU ;header for usage
W !?24,"-----USAGE/ISSUES HISTORY-----",!?9,"DATE USED/ISSUED QTY USED/ISSUED COST USED/ISSUED"
Q
;
;
HR ;header for receipts
W !?26,"-----RECEIPTS HISTORY-----",!?9,"DATE RECEIVED QTY RECEIVED"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRIT1 5320 printed Nov 22, 2024@17:25:10 Page 2
PRCPRIT1 ;WISC/RFJ/VAC-display item (print) ; 10/27/06 2:01pm
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Routine modified to show "D" for On-Demand Item and to correct
+4 ; column #IM heading
+5 QUIT
+6 ;
+7 ;
DQ ;queue comes here
+1 NEW %I,D,D0,ITEMDATA,PRCPDA,DATA,DATE,INVNAME,NOW,PAGE,PRCPFLAG,SCREEN,UNIT,X,Y,ODI,X1,X2,MASTDATA
+2 DO NOW^%DTC
SET Y=%
SET DATE=$EXTRACT(%,1,7)
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
SET INVNAME=$$INVNAME^PRCPUX1(INVPT)
USE IO
DO H
+3 SET MASTDATA=$GET(^PRC(441,ITEMDA,0))
SET ITEMDATA=$GET(^PRCP(445,INVPT,1,ITEMDA,0))
+4 WRITE !,$PIECE(MASTDATA,"^",5),?19,$EXTRACT($$DESCR^PRCPUX1(INVPT,ITEMDA),1,28),?49,"[#",ITEMDA,"]",?59,$EXTRACT($$GROUPNM^PRCPEGRP(+$PIECE(ITEMDATA,"^",21)),1,20)
+5 ; Insert logic to print ODI flag of "D"
+6 IF ODIFLAG="P"
Begin DoDot:1
+7 WRITE !,?8,"ON-DEMAND: "
+8 SET ODI=""
+9 SET ODI=$$ODITEM^PRCPUX2(INVPT,ITEMDA)
+10 IF ODI="Y"
WRITE "D"
+11 WRITE ?36,"BOC: ",$EXTRACT($PIECE($GET(^PRCD(420.2,+$PIECE(MASTDATA,"^",10),0)),"^"),1,39)
End DoDot:1
+12 IF ODIFLAG="W"
Begin DoDot:1
+13 WRITE ?14,"BOC: ",$EXTRACT($PIECE($GET(^PRCD(420.2,+$PIECE(MASTDATA,"^",10),0)),"^"),1,39)
End DoDot:1
+14 SET UNIT=$$UNIT^PRCPUX1(INVPT,ITEMDA," per ")
WRITE !?3,"UNIT per ISSUE: ",UNIT
+15 WRITE !?6,"QTY ON HAND: ",+$PIECE(ITEMDATA,"^",7),?33,"DUE-IN: ",$$GETIN^PRCPUDUE(INVPT,ITEMDA),?60,"DUE-OUT: ",$$GETOUT^PRCPUDUE(INVPT,ITEMDA),!?6,"QTY NON-ISS: ",+$PIECE(ITEMDATA,"^",19)
+16 IF $PIECE(ITEMDATA,"^",26)="Y"
WRITE !?19,"** DELETE ITEM WHEN QTY ON HAND REACHES ZERO **"
+17 WRITE !?6,"TOTAL VALUE: ",$PIECE(ITEMDATA,"^",27)
+18 WRITE !?5,"NORM STL LVL: ",$PIECE(ITEMDATA,"^",9),?29,"REORDER PT: ",$PIECE(ITEMDATA,"^",10),?55,"INT ORDER PT: ",$PIECE(ITEMDATA,"^",4)
+19 WRITE !?4,"EMERGENCY LVL: ",$PIECE(ITEMDATA,"^",11),?29,"ISSUE MULT: ",$PIECE(ITEMDATA,"^",25),?54,"MIN ISSUE QTY: ",$PIECE(ITEMDATA,"^",17)
+20 IF $PIECE(ITEMDATA,"^",23)
SET Y=$PIECE(ITEMDATA,"^",24)
DO DD^%DT
WRITE !?5,"TEMP STK LVL: ",$PIECE(ITEMDATA,"^",23),?29,"UNTIL DATE: ",Y
+21 SET Y=$PIECE(ITEMDATA,"^",3)
DO DD^%DT
WRITE !?8,"LAST COST: ",$PIECE(ITEMDATA,"^",15),?29,"LAST REC'D: ",Y,?55,"AVERAGE COST: ",$PIECE(ITEMDATA,"^",22)
+22 WRITE !?1,"MAIN STORAGE LOC: ",$$STORELOC^PRCPESTO(+$PIECE(ITEMDATA,"^",6))
+23 IF $ORDER(^PRCP(445,INVPT,1,ITEMDA,5,0))
Begin DoDot:1
+24 DO HS
SET PRCPDA=0
FOR
SET PRCPDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA,5,PRCPDA))
if 'PRCPDA!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(PRCPDA,0))
Begin DoDot:2
+25 WRITE !
IF $PIECE(ITEMDATA,"^",12)=$PIECE(DATA,"^")
WRITE ?3,"m"
+26 SET Y=$PIECE(DATA,"^")
SET Y=$SELECT(Y["PRC(440":$PIECE($GET(^PRC(440,+Y,0)),"^"),1:$PIECE($GET(^PRCP(445,+Y,0)),"^"))
if '+$PIECE(DATA,"^",4)
SET $PIECE(DATA,"^",4)=1
+27 WRITE ?5,$EXTRACT(Y,1,27),?37,"[#",+DATA,"]",?45,$JUSTIFY($PIECE(DATA,"^",4),9),?68,$JUSTIFY($$UNITVAL^PRCPUX1($PIECE(DATA,"^",3),$PIECE(DATA,"^",2)," per "),11)
+28 IF $Y>(IOSL-5)
IF $ORDER(^PRCP(445,INVPT,1,ITEMDA,5,PRCPDA))
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
DO HS
End DoDot:2
End DoDot:1
+29 IF $GET(PRCPFLAG)
DO Q
QUIT
+30 IF $ORDER(^PRCP(445,INVPT,1,ITEMDA,7,0))
Begin DoDot:1
+31 IF $Y>(IOSL-7)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
+32 DO HO
SET PRCPDA=0
FOR
SET PRCPDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA,7,PRCPDA))
if 'PRCPDA!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(PRCPDA,0))
Begin DoDot:2
+33 if '+$PIECE(DATA,"^",5)
SET $PIECE(DATA,"^",5)=1
+34 WRITE !?1,$PIECE($GET(^PRCS(410,PRCPDA,0)),"^"),?21,$JUSTIFY(+$PIECE(DATA,"^",2),7),?32,$JUSTIFY(UNIT,11),?50,$JUSTIFY($PIECE(DATA,"^",5),5),?57,$JUSTIFY(...
... $PIECE(DATA,"^",2)/$PIECE(DATA,"^",5),7),?68,$JUSTIFY($$UNITVAL^PRCPUX1($PIECE(DATA,"^",4),$PIECE(DATA,"^",3)," per "),11)
+35 SET D0=PRCPDA
DO STATUS^PRCSES
WRITE !?10,"REQUEST STATUS: ",X
+36 IF $Y>(IOSL-5)
IF $ORDER(^PRCP(445,INVPT,1,ITEMDA,7,PRCPDA))
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
DO HO
End DoDot:2
End DoDot:1
+37 IF $GET(PRCPFLAG)
DO Q
QUIT
+38 SET X1=$EXTRACT(DATE,1,5)_"01"
SET X2=-180
DO C^%DTC
SET X=$EXTRACT(X,1,5)
+39 IF $ORDER(^PRCP(445,INVPT,1,ITEMDA,2,X))
Begin DoDot:1
+40 IF $Y>(IOSL-7)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
+41 DO HU
SET PRCPDA=X
FOR
SET PRCPDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA,2,PRCPDA))
if 'PRCPDA!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(PRCPDA,0))
Begin DoDot:2
+42 WRITE !?9,$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(PRCPDA,4,5))," ",17+$EXTRACT(PRCPDA),$EXTRACT(PRCPDA,2,3),?29,$JUSTIFY($PIECE(DATA,"^",2),15),?47,$JUSTIFY($PIECE(DATA,"^",3),17,3)
+43 IF $Y>(IOSL-5)
IF $ORDER(^PRCP(445,INVPT,1,ITEMDA,2,PRCPDA))
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
DO HU
End DoDot:2
End DoDot:1
+44 IF $GET(PRCPFLAG)
DO Q
QUIT
+45 IF $ORDER(^PRCP(445,INVPT,1,ITEMDA,3,X_"01"))
Begin DoDot:1
+46 IF $Y>(IOSL-7)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
+47 DO HR
SET PRCPDA=X_"01"
FOR
SET PRCPDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA,3,PRCPDA))
if 'PRCPDA!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(PRCPDA,0))
Begin DoDot:2
+48 WRITE !?9,$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(PRCPDA,4,5))," ",$EXTRACT(PRCPDA,6,7),", ",17+$EXTRACT(PRCPDA),$EXTRACT(PRCPDA,2,3),?29,$JUSTIFY($PIECE(DATA,"^",2),13)
+49 IF $Y>(IOSL-5)
IF $ORDER(^PRCP(445,INVPT,1,ITEMDA,3,PRCPDA))
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
DO HR
End DoDot:2
End DoDot:1
+50 IF '$GET(PRCPFLAG)
DO END^PRCPUREP
Q DO ^%ZISC
QUIT
+1 ;
+2 ;
H SET %=NOW_" PAGE: "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"DISPLAY ITEM REPORT FOR ",INVNAME,?(80-$LENGTH(%)),%
+2 SET %=""
SET $PIECE(%,"-",81)=""
WRITE !,"NSN",?19,"DESCRIPTION",?49,"[IM#]",?59,"GROUP : DESCRIPTION",!,%
+3 QUIT
+4 ;
+5 ;
HS ;header for procurement sources
+1 WRITE !?15,"-----POSSIBLE SOURCES (m=MANDATORY SOURCE)-----",!?5,"VENDOR",?37,"[#V]",?45,"CONV FACT",?68,"UNIT per REC"
+2 QUIT
+3 ;
+4 ;
HO ;header for outstanding transactions
+1 WRITE !?22,"-----OUTSTANDING TRANSACTIONS-----",!?1,"TRANSACTION NO. QTY ORD in UNIT per ISS CONV FACT QTY REC in UNIT per REC"
+2 QUIT
+3 ;
+4 ;
HU ;header for usage
+1 WRITE !?24,"-----USAGE/ISSUES HISTORY-----",!?9,"DATE USED/ISSUED QTY USED/ISSUED COST USED/ISSUED"
+2 QUIT
+3 ;
+4 ;
HR ;header for receipts
+1 WRITE !?26,"-----RECEIPTS HISTORY-----",!?9,"DATE RECEIVED QTY RECEIVED"
+2 QUIT
