PRCHRPT1 ;ID/RSD,SF-ISC/TKW-PRINT OPTIONS ; [1/13/99 1:27pm]
V ;;5.1;IFCAP;**15,70,106,132**;Oct 20, 2000;Build 3
;Per VHA Directive 2004-038, this routine should not be modified.
;
EN ;DISPLAY ITEM HISTORY
S PRCF("X")="SP",AGN=1,LLCT=0,LNCT=0 D ^PRCFSITE
EN0 Q:'$D(PRC("SITE")) W !! S DIC="^PRC(441,",DIC(0)="QEAMNZ" D ^DIC G Q:Y<0 S D0=+Y I '$D(^(4,0)) W !,"History for this item does not yet exist. Press <RETURN>" R X:DTIME G EN0
S PRCHQ="ITEM^PRCHRPT1",ITMY=Y(0) D RDTXS G:'$D(PRC("SITE")) Q D ^PRCHQUE K DIC,ZTSK,D0
G EN0
;
EN1 ;PRINT ITEM CATALOG
S PRCF("X")="SP" D ^PRCFSITE
EN10 Q:'$D(PRC("SITE")) K PRCHD S M="FUND CONTROL POINT",DIS(0)="I PRC(""SITE"")=$E($O(^PRC(441,D0,4,""B"",PRC(""SITE""))),1,3)" D RNG G Q:FR["^"!(TO["^") I FR["?"!(TO["?") D DSP^PRCHRPT2 G EN10
I FR S X=+FR D FX S FR=X
I TO S X=+TO D FX S TO=X
S FR=FR_",!",TO=TO_",z",DIC="^PRC(441,",FLDS="[PRCHITCAT]",BY="#@FCP,FCP,FCP,LONG NAME;"""",@$E(SHORT DESCRIPTION,1,50)" S L=0 D EN1^DIP
;
Q K FR,TO,FLDS,BY,DIC,I,J,K,L,PRC,PRCHFCP,D0,DA,M,DIS,ZTSK
K %,ABORT,DIR,FCPNO,FCPTCNT,FCPTPGS,FR1,FR2,FR3,FR4,ITMNO,ITMY,LCNT,LLIM,NXD,PRCHQ,PRCRI,PRCI,RTX,^TEMP("FCPCNT"),^TEMP("FCPDT"),^TEMP("FCPNAME"),^TEMP("FCPPGS"),TO1,TO2,TO3,TO4,TXCNT,TXFCP,TXIEN,TXR,TXS,TXSTN,X,Y
K AGN,C,DDH,SCTL,STN,ITMDESC,^TMP("PRCHRPT1",$J)
K COUNT,DIRUT,FLG,LLCT,LNCT,NX,PRCF("X"),PRCHPDAT,ZTRTN
QUIT
;
FX I $D(^PRC(420,+PRC("SITE"),1,X,0)) S X=PRC("SITE")_$P($P(^(0),U,1)," ",1)
Q
;
ITEM S TXR=$G(^TMP("PRCHITMH",0)) S:'TXR TXR=10
S U="^" Q:'$D(^PRC(441,D0,0)) S W=$P(^(0),U,2),ASK=0,(W1,W(3),W(4))=0,W(2)="",PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:0),W(1)=PRC("SITE")_0 K ^TMP("PRCHRPT1",$J)
F W(1)=W(1):0 Q:'$O(^PRC(441,D0,4,"B",W(1))) S W(1)=$O(^PRC(441,D0,4,"B",W(1))) S PRCHFCP=$S($D(^PRC(420,PRC("SITE"),1,+$E(W(1),4,9),0)):$P(^(0),U,1),1:$E(W(1),4,9)) K ^TMP("PRCHRPT1",$J) D ITEM0 Q:ASK
K ASK,W,W1,DIC,COUNT,DIRUT,FLG,LLCT,LNCT,NX,PRCF("X"),PRCHPDAT
D:$D(ZTSK) KILL^%ZTLOAD K ZTSK
Q
;
ITEM0 I $D(^PRC(441,D0,4,W(1),1,"AC")) D
. S W(2)=""
. S W(3)=""
. S FLG=""
. S COUNT=""
. F S W(3)=$O(^PRC(441,D0,4,W(1),1,"AC",W(3))) Q:W(3)'>0 Q:FLG=1 D
. . S W(4)=""
. . F S W(4)=$O(^PRC(441,D0,4,W(1),1,"AC",W(3),W(4))) Q:W(4)'>0 D
. . . S ^TMP("PRCHRPT1",$J,(W(4)))=W(4)
. . . S COUNT=COUNT+1
. . . I COUNT=TXR S FLG=1 Q
. . . Q
. . Q
. Q
I '$D(^PRC(441,D0,4,W(1),1,"AC")) D Q
. D HDR Q:ASK=1
. I $D(PRCHFCP) W !!,"FCP: "_PRCHFCP_" has no history for this item."
. Q
G:ASK=1 Q
NONE I $O(^TMP("PRCHRPT1",$J,0))="" W !,"A history for this item does not yet exist." D Q
. I $G(ZTSK)'>0 W !,"Press RETURN to continue." R X:DTIME Q
I $G(LNCT)="" S LNCT=0
I LNCT=0 D HDR
I LNCT'=0,$E(IOST)="P" S LNCT=0 D HDR
I LNCT'=0,$E(IOST)'="P" D ASK Q:ASK S LNCT=0 D HDR
;
SKPTXS S NX=0 I $G(LNCT)="" S LNCT=0
F K=1:1:TXR Q:'$O(^TMP("PRCHRPT1",$J,NX)) S NX=$O(^TMP("PRCHRPT1",$J,NX)),W(6)=^TMP("PRCHRPT1",$J,NX) Q:W(6)="" S LNCT=LNCT+1,W(5)=0,W(5)=$O(^PRC(442,W(6),2,"AE",D0,W(5))) I W(5)'="" S W1=W1+1 D ITEM1 D CKLCT Q:ASK
I 'W1 K ^TMP("PRCHRPT1",$J) G NONE
Q
;
CKLCT I $E(IOST)'="P"&(LNCT=5) S LNCT=0 D ASK Q:ASK D HDR:$O(^TMP("PRCHRPT1",$J,NX))
I $E(IOST)="P"&(LNCT=50) S LNCT=0 D ASK Q:ASK D HDR:$O(^TMP("PRCHRPT1",$J,NX))
Q
;
ITEM1 W ! I $D(^PRC(442,W(6),1)),$P(^(1),U,15)'="" S Y=$P(^(1),U,15) D DD^%DT W Y
W ?15,$P(^PRC(442,W(6),0),U,1)
I $D(^PRC(442,W(6),2,W(5),2)) S W(7)=^(2) W ?26,$J($P(^(2),U,8),10)
I $D(^PRC(442,W(6),2,W(5),0)) S W(8)=^(0) W:+$P(W(8),U,3) ?38,$P($G(^PRCD(420.5,+$P(W(8),U,3),0)),U,1)
W:$D(W(8)) ?48,$J($P(W(8),U,9),9,2) W:$D(W(7)) ?59,$J($P(W(7),U,1),10,2) W:$D(W(8)) ?71,$J($P(W(8),U,2),8)
I $P($G(^PRC(442,W(6),1)),U,1)>0 S W(8)=$P(^(1),U,1),W(8)=$P($G(^PRC(440,W(8),0)),U,1) I W(8)'="" W !,"Vendor: ",W(8)
K W(7),W(8)
Q
;
ASK Q:$E(IOST)="P" W !!,"Press RETURN to continue, '^' to Quit" R X:DTIME I X["^" S ASK=1
Q
;
RNG ; ALLOW ENTRY OF BEGINNING AND ENDING RANGE
S FR="",TO="z" W !!!,"START WITH "_M_": FIRST//" R FR:DTIME S:$T=0 FR="^" I (FR["?")!(FR["^")!(FR="") Q
I FR'="@",$D(PRCHD),PRCHD="DATE" K %DT S X=FR D ^%DT S FR=Y W:Y=-1 $C(7),!,"INVALID DATE" G:Y=-1 RNG D DD^%DT W " ",Y
W !!,"GO TO "_M_": LAST//" R TO:DTIME S:$T=0 TO="^" Q:(TO["^")!(TO["?") S:TO="" TO="z" Q:TO="z"
I $D(PRCHD),PRCHD="DATE" S X=TO D ^%DT S TO=Y W:Y=-1 $C(7),!,"INVALID DATE" G:Y=-1 RNG D DD^%DT W " ",Y
I (+FR=FR)&(+TO=TO) I FR>TO W $C(7),!,"INVALID RANGE" G RNG
I FR'="@" I (+FR'=FR)!(+TO'=TO) I FR]TO W $C(7),!,"INVALID RANGE" G RNG
Q
;
PDT ; ROUTINE ALLOWING ENTRY OF A DATE FOR PRINTING, ETC. (DEFAULTS TO NOW)
W !!,"Enter date (and time, if not NOW) to "_M S %DT="AET",%DT("A")="DATE: NOW//" D ^%DT K %DT
S:X="" X="NOW",Y=$H S PRCHPDAT=Y Q:X="NOW"!(X["^") G:Y=-1 PDT
I +$P(Y,".",2)'>0 W $C(7),!,"You must enter the time as well as the date to print the report" G PDT
S PRCHPDAT=Y
Q
;
SDEV ; SELECT DEVICE FOR QUEUED PRINTING
W ! K %ZIS,IOP S %ZIS="Q",IOP="Q",%ZIS("B")="" D ^%ZIS
S IOP=ION_";"_IOST_";"_IOM_";"_IOSL I IO=IO(0) D ^%ZIS U IO D @ZTRTN D ^%ZISC
Q
HDR ;
;
I $G(LNCT)>0&($E(IOST)'="P") D ASK Q:ASK
W @IOF,!!,"Item Number: ",D0,?25,"Description: ",W,!?8,"FCP: ",PRCHFCP,!!,?26,"Quantity",!,?26,"Previously",?38,"Unit of",?71,"Quantity"
W !,"Date Ordered",?15,"PO Number",?26,"Received",?38,"Purchase",?48,"Unit Cost",?59,"Total Cost",?71,"Ordered",! F I=1:1:80 W "_"
Q
RDTXS ; Prompt for # back TX's to list for an FCP(default=10,max=9999)
W !
RDTXS1 K DIR
S DIR(0)="F^1:4"
S DIR("A")="Enter # BACK TRANSACTIONS to list, 'S' to sort or '^' to EXIT"
S DIR("B")=10
S DIR("?")="Enter 1-9999 or 'S' to sort by PO Date, FCP, etc."
S DIR("??")="^D WARN^PRCHRPT1"
D ^DIR
S TXS=X
I $D(DIRUT) S ABORT=1 G Q
I TXS?.N&((TXS<1)!(TXS>9999)) D QUESTION G RDTXS1
I TXS?.N S TXR=TXS,^TMP("PRCHITMH",0)=TXR*1,TXR=^TMP("PRCHITMH",0),RTX="A" Q
I TXS'="s"&(TXS'="S") W ! D QUESTION G RDTXS1
S ITMNO=$P(ITMY,U,1) G EN^PRCHRPTX
Q
;
QUESTION ;
W !!,"Enter 1-9999 or 'S' to sort by PO Date, FCP, etc."
Q
;
WARN ;
W @IOF,!?10,"List Transaction History for Specified Item",!!
W !,"You may obtain either a listing of a specified number of back transactions",!,"for the item or all transactions (by FCP) within a specified date range."
W !!,"Please be aware that the latter involves complex sorting and may",!,"take awhile to complete. Therefore, it is suggested that it be queued to",!,"a printer to immediately free your workstation.",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPT1 6550 printed Dec 13, 2024@02:10:28 Page 2
PRCHRPT1 ;ID/RSD,SF-ISC/TKW-PRINT OPTIONS ; [1/13/99 1:27pm]
V ;;5.1;IFCAP;**15,70,106,132**;Oct 20, 2000;Build 3
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
EN ;DISPLAY ITEM HISTORY
+1 SET PRCF("X")="SP"
SET AGN=1
SET LLCT=0
SET LNCT=0
DO ^PRCFSITE
EN0 if '$DATA(PRC("SITE"))
QUIT
WRITE !!
SET DIC="^PRC(441,"
SET DIC(0)="QEAMNZ"
DO ^DIC
if Y<0
GOTO Q
SET D0=+Y
IF '$DATA(^(4,0))
WRITE !,"History for this item does not yet exist. Press <RETURN>"
READ X:DTIME
GOTO EN0
+1 SET PRCHQ="ITEM^PRCHRPT1"
SET ITMY=Y(0)
DO RDTXS
if '$DATA(PRC("SITE"))
GOTO Q
DO ^PRCHQUE
KILL DIC,ZTSK,D0
+2 GOTO EN0
+3 ;
EN1 ;PRINT ITEM CATALOG
+1 SET PRCF("X")="SP"
DO ^PRCFSITE
EN10 if '$DATA(PRC("SITE"))
QUIT
KILL PRCHD
SET M="FUND CONTROL POINT"
SET DIS(0)="I PRC(""SITE"")=$E($O(^PRC(441,D0,4,""B"",PRC(""SITE""))),1,3)"
DO RNG
if FR["^"!(TO["^")
GOTO Q
IF FR["?"!(TO["?")
DO DSP^PRCHRPT2
GOTO EN10
+1 IF FR
SET X=+FR
DO FX
SET FR=X
+2 IF TO
SET X=+TO
DO FX
SET TO=X
+3 SET FR=FR_",!"
SET TO=TO_",z"
SET DIC="^PRC(441,"
SET FLDS="[PRCHITCAT]"
SET BY="#@FCP,FCP,FCP,LONG NAME;"""",@$E(SHORT DESCRIPTION,1,50)"
SET L=0
DO EN1^DIP
+4 ;
Q KILL FR,TO,FLDS,BY,DIC,I,J,K,L,PRC,PRCHFCP,D0,DA,M,DIS,ZTSK
+1 KILL %,ABORT,DIR,FCPNO,FCPTCNT,FCPTPGS,FR1,FR2,FR3,FR4,ITMNO,ITMY,LCNT,LLIM,NXD,PRCHQ,PRCRI,PRCI,RTX,^TEMP("FCPCNT"),^TEMP("FCPDT"),^TEMP("FCPNAME"),^TEMP("FCPPGS"),TO1,TO2,TO3,TO4,TXCNT,TXFCP,TXIEN,TXR,TXS,TXSTN,X,Y
+2 KILL AGN,C,DDH,SCTL,STN,ITMDESC,^TMP("PRCHRPT1",$JOB)
+3 KILL COUNT,DIRUT,FLG,LLCT,LNCT,NX,PRCF("X"),PRCHPDAT,ZTRTN
+4 QUIT
+5 ;
FX IF $DATA(^PRC(420,+PRC("SITE"),1,X,0))
SET X=PRC("SITE")_$PIECE($PIECE(^(0),U,1)," ",1)
+1 QUIT
+2 ;
ITEM SET TXR=$GET(^TMP("PRCHITMH",0))
if 'TXR
SET TXR=10
+1 SET U="^"
if '$DATA(^PRC(441,D0,0))
QUIT
SET W=$PIECE(^(0),U,2)
SET ASK=0
SET (W1,W(3),W(4))=0
SET W(2)=""
SET PRC("SITE")=$SELECT($DATA(PRC("SITE")):PRC("SITE"),1:0)
SET W(1)=PRC("SITE")_0
KILL ^TMP("PRCHRPT1",$JOB)
+2 FOR W(1)=W(1):0
if '$ORDER(^PRC(441,D0,4,"B",W(1)))
QUIT
SET W(1)=$ORDER(^PRC(441,D0,4,"B",W(1)))
SET PRCHFCP=$SELECT($DATA(^PRC(420,PRC("SITE"),1,+$EXTRACT(W(1),4,9),0)):$PIECE(^(0),U,1),1:$EXTRACT(W(1),4,9))
KILL ^TMP("PRCHRPT1",$JOB)
DO ITEM0
if ASK
QUIT
+3 KILL ASK,W,W1,DIC,COUNT,DIRUT,FLG,LLCT,LNCT,NX,PRCF("X"),PRCHPDAT
+4 if $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+5 QUIT
+6 ;
ITEM0 IF $DATA(^PRC(441,D0,4,W(1),1,"AC"))
Begin DoDot:1
+1 SET W(2)=""
+2 SET W(3)=""
+3 SET FLG=""
+4 SET COUNT=""
+5 FOR
SET W(3)=$ORDER(^PRC(441,D0,4,W(1),1,"AC",W(3)))
if W(3)'>0
QUIT
if FLG=1
QUIT
Begin DoDot:2
+6 SET W(4)=""
+7 FOR
SET W(4)=$ORDER(^PRC(441,D0,4,W(1),1,"AC",W(3),W(4)))
if W(4)'>0
QUIT
Begin DoDot:3
+8 SET ^TMP("PRCHRPT1",$JOB,(W(4)))=W(4)
+9 SET COUNT=COUNT+1
+10 IF COUNT=TXR
SET FLG=1
QUIT
+11 QUIT
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 IF '$DATA(^PRC(441,D0,4,W(1),1,"AC"))
Begin DoDot:1
+15 DO HDR
if ASK=1
QUIT
+16 IF $DATA(PRCHFCP)
WRITE !!,"FCP: "_PRCHFCP_" has no history for this item."
+17 QUIT
End DoDot:1
QUIT
+18 if ASK=1
GOTO Q
NONE IF $ORDER(^TMP("PRCHRPT1",$JOB,0))=""
WRITE !,"A history for this item does not yet exist."
Begin DoDot:1
+1 IF $GET(ZTSK)'>0
WRITE !,"Press RETURN to continue."
READ X:DTIME
QUIT
End DoDot:1
QUIT
+2 IF $GET(LNCT)=""
SET LNCT=0
+3 IF LNCT=0
DO HDR
+4 IF LNCT'=0
IF $EXTRACT(IOST)="P"
SET LNCT=0
DO HDR
+5 IF LNCT'=0
IF $EXTRACT(IOST)'="P"
DO ASK
if ASK
QUIT
SET LNCT=0
DO HDR
+6 ;
SKPTXS SET NX=0
IF $GET(LNCT)=""
SET LNCT=0
+1 FOR K=1:1:TXR
if '$ORDER(^TMP("PRCHRPT1",$JOB,NX))
QUIT
SET NX=$ORDER(^TMP("PRCHRPT1",$JOB,NX))
SET W(6)=^TMP("PRCHRPT1",$JOB,NX)
if W(6)=""
QUIT
SET LNCT=LNCT+1
SET W(5)=0
SET W(5)=$ORDER(^PRC(442,W(6),2,"AE",D0,W(5)))
IF W(5)'=""
SET W1=W1+1
DO ITEM1
DO CKLCT
if ASK
QUIT
+2 IF 'W1
KILL ^TMP("PRCHRPT1",$JOB)
GOTO NONE
+3 QUIT
+4 ;
CKLCT IF $EXTRACT(IOST)'="P"&(LNCT=5)
SET LNCT=0
DO ASK
if ASK
QUIT
if $ORDER(^TMP("PRCHRPT1",$JOB,NX))
DO HDR
+1 IF $EXTRACT(IOST)="P"&(LNCT=50)
SET LNCT=0
DO ASK
if ASK
QUIT
if $ORDER(^TMP("PRCHRPT1",$JOB,NX))
DO HDR
+2 QUIT
+3 ;
ITEM1 WRITE !
IF $DATA(^PRC(442,W(6),1))
IF $PIECE(^(1),U,15)'=""
SET Y=$PIECE(^(1),U,15)
DO DD^%DT
WRITE Y
+1 WRITE ?15,$PIECE(^PRC(442,W(6),0),U,1)
+2 IF $DATA(^PRC(442,W(6),2,W(5),2))
SET W(7)=^(2)
WRITE ?26,$JUSTIFY($PIECE(^(2),U,8),10)
+3 IF $DATA(^PRC(442,W(6),2,W(5),0))
SET W(8)=^(0)
if +$PIECE(W(8),U,3)
WRITE ?38,$PIECE($GET(^PRCD(420.5,+$PIECE(W(8),U,3),0)),U,1)
+4 if $DATA(W(8))
WRITE ?48,$JUSTIFY($PIECE(W(8),U,9),9,2)
if $DATA(W(7))
WRITE ?59,$JUSTIFY($PIECE(W(7),U,1),10,2)
if $DATA(W(8))
WRITE ?71,$JUSTIFY($PIECE(W(8),U,2),8)
+5 IF $PIECE($GET(^PRC(442,W(6),1)),U,1)>0
SET W(8)=$PIECE(^(1),U,1)
SET W(8)=$PIECE($GET(^PRC(440,W(8),0)),U,1)
IF W(8)'=""
WRITE !,"Vendor: ",W(8)
+6 KILL W(7),W(8)
+7 QUIT
+8 ;
ASK if $EXTRACT(IOST)="P"
QUIT
WRITE !!,"Press RETURN to continue, '^' to Quit"
READ X:DTIME
IF X["^"
SET ASK=1
+1 QUIT
+2 ;
RNG ; ALLOW ENTRY OF BEGINNING AND ENDING RANGE
+1 SET FR=""
SET TO="z"
WRITE !!!,"START WITH "_M_": FIRST//"
READ FR:DTIME
if $TEST=0
SET FR="^"
IF (FR["?")!(FR["^")!(FR="")
QUIT
+2 IF FR'="@"
IF $DATA(PRCHD)
IF PRCHD="DATE"
KILL %DT
SET X=FR
DO ^%DT
SET FR=Y
if Y=-1
WRITE $CHAR(7),!,"INVALID DATE"
if Y=-1
GOTO RNG
DO DD^%DT
WRITE " ",Y
+3 WRITE !!,"GO TO "_M_": LAST//"
READ TO:DTIME
if $TEST=0
SET TO="^"
if (TO["^")!(TO["?")
QUIT
if TO=""
SET TO="z"
if TO="z"
QUIT
+4 IF $DATA(PRCHD)
IF PRCHD="DATE"
SET X=TO
DO ^%DT
SET TO=Y
if Y=-1
WRITE $CHAR(7),!,"INVALID DATE"
if Y=-1
GOTO RNG
DO DD^%DT
WRITE " ",Y
+5 IF (+FR=FR)&(+TO=TO)
IF FR>TO
WRITE $CHAR(7),!,"INVALID RANGE"
GOTO RNG
+6 IF FR'="@"
IF (+FR'=FR)!(+TO'=TO)
IF FR]TO
WRITE $CHAR(7),!,"INVALID RANGE"
GOTO RNG
+7 QUIT
+8 ;
PDT ; ROUTINE ALLOWING ENTRY OF A DATE FOR PRINTING, ETC. (DEFAULTS TO NOW)
+1 WRITE !!,"Enter date (and time, if not NOW) to "_M
SET %DT="AET"
SET %DT("A")="DATE: NOW//"
DO ^%DT
KILL %DT
+2 if X=""
SET X="NOW"
SET Y=$HOROLOG
SET PRCHPDAT=Y
if X="NOW"!(X["^")
QUIT
if Y=-1
GOTO PDT
+3 IF +$PIECE(Y,".",2)'>0
WRITE $CHAR(7),!,"You must enter the time as well as the date to print the report"
GOTO PDT
+4 SET PRCHPDAT=Y
+5 QUIT
+6 ;
SDEV ; SELECT DEVICE FOR QUEUED PRINTING
+1 WRITE !
KILL %ZIS,IOP
SET %ZIS="Q"
SET IOP="Q"
SET %ZIS("B")=""
DO ^%ZIS
+2 SET IOP=ION_";"_IOST_";"_IOM_";"_IOSL
IF IO=IO(0)
DO ^%ZIS
USE IO
DO @ZTRTN
DO ^%ZISC
+3 QUIT
HDR ;
+1 ;
+2 IF $GET(LNCT)>0&($EXTRACT(IOST)'="P")
DO ASK
if ASK
QUIT
+3 WRITE @IOF,!!,"Item Number: ",D0,?25,"Description: ",W,!?8,"FCP: ",PRCHFCP,!!,?26,"Quantity",!,?26,"Previously",?38,"Unit of",?71,"Quantity"
+4 WRITE !,"Date Ordered",?15,"PO Number",?26,"Received",?38,"Purchase",?48,"Unit Cost",?59,"Total Cost",?71,"Ordered",!
FOR I=1:1:80
WRITE "_"
+5 QUIT
RDTXS ; Prompt for # back TX's to list for an FCP(default=10,max=9999)
+1 WRITE !
RDTXS1 KILL DIR
+1 SET DIR(0)="F^1:4"
+2 SET DIR("A")="Enter # BACK TRANSACTIONS to list, 'S' to sort or '^' to EXIT"
+3 SET DIR("B")=10
+4 SET DIR("?")="Enter 1-9999 or 'S' to sort by PO Date, FCP, etc."
+5 SET DIR("??")="^D WARN^PRCHRPT1"
+6 DO ^DIR
+7 SET TXS=X
+8 IF $DATA(DIRUT)
SET ABORT=1
GOTO Q
+9 IF TXS?.N&((TXS<1)!(TXS>9999))
DO QUESTION
GOTO RDTXS1
+10 IF TXS?.N
SET TXR=TXS
SET ^TMP("PRCHITMH",0)=TXR*1
SET TXR=^TMP("PRCHITMH",0)
SET RTX="A"
QUIT
+11 IF TXS'="s"&(TXS'="S")
WRITE !
DO QUESTION
GOTO RDTXS1
+12 SET ITMNO=$PIECE(ITMY,U,1)
GOTO EN^PRCHRPTX
+13 QUIT
+14 ;
QUESTION ;
+1 WRITE !!,"Enter 1-9999 or 'S' to sort by PO Date, FCP, etc."
+2 QUIT
+3 ;
WARN ;
+1 WRITE @IOF,!?10,"List Transaction History for Specified Item",!!
+2 WRITE !,"You may obtain either a listing of a specified number of back transactions",!,"for the item or all transactions (by FCP) within a specified date range."
+3 WRITE !!,"Please be aware that the latter involves complex sorting and may",!,"take awhile to complete. Therefore, it is suggested that it be queued to",!,"a printer to immediately free your workstation.",!
+4 QUIT
