PRCHRPTX ;AAC/JDM-PRCH ITEM HISTORY BY DATE RANGE ; [1/13/99 11:13am]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; <<<<<<<<<<<< Expected Variables In >>>>>>>>>>>>>
; PRC("SITE")=Stn.# (Mandatory)
; ITMNO;ITMNO=Item Master #
; <<<<<<<<<<<< Other Variables Used >>>>>>>>>>>>>>
; FR1 & TO1=Starting and ending FCP for sort
; FR2 & TO2=Starting & ending Stn.# for sort (Set from PRC("SITE")
; FR3 & TO3=Starting & ending Itm.# for sort (Set from ITMNO)
; FR4 & TO4=Starting & ending PO Date for sort
; ITMDESC=Set from file entry
;
EN ;DISPLAY ITEM HISTORY
;
XXLST S STN=PRC("SITE")
S ABORT=0
W !,"STN: ",STN
K DIR
S DIR(0)="S^ALL:ALL FCPs;RANGE:RANGE of FCPs;SPECIFIC:SPECIFIC FCP"
S DIR("A")="List Item Activity (by DATE RANGE) for"
S DIR("B")="ALL"
D ^DIR
I X["^"!($D(DTOUT)) G EXIT
S SCTL=X
I $E(X,1)="A"!($E(X,1)="a") D G XXITM
. S FR2=STN
. S TO2=STN
. S FR1=0
. S TO1="99999 ZZZ"
. Q
W !!,"START WITH FCP"
I $E(SCTL,1)="S"!($E(SCTL,1)="s") W " and END WITH FCP"
S DIC="^PRC(420,STN,1,"
S DIC(0)="QEAMNZ"
D ^DIC
I X="^" G EXIT
I Y'>0 W !,"INVALID SELECTION. TRY AGAIN ('^' TO ABORT)." G XXLST
S X=$P(Y,U,2)
S FR1=$P(X," ",1)
S FR2=STN
I $E(SCTL,1)="S"!($E(SCTL,1)="s") G XFCP
;
TOFCP W !!,"END WITH FCP"
D ^DIC
I Y'>0 W !,"INVALID SELECTION. TRY AGAIN ('^' TO ABORT)." G TOFCP
I X="^" G EXIT
;
XFCP S X=$P(Y,U,2)
S TO1=$P(X," ",1)
S TO2=STN
;
XXITM I $D(ITMNO) D G XXDT
. S FR3=ITMNO
. S TO3=ITMNO
. Q
S DIC="^PRC(441,"
S DIC(0)="QEAMNZ"
D ^DIC
I X="^" G EXIT
I Y'>0 W !,"INVALID SELECTION" G XXITM
S ITMNO=$P(Y(0),U,1)
S FR3=ITMNO
S TO3=ITMNO
;
XXDT S ITMDESC=$P(^PRC(441,ITMNO,0),U,2)
D NOW^%DTC
D YX^%DTC
S DTX=$P(Y,"@",1)
S DTX="JAN 1,"_$P(DTX,",",2)
K DIR
S DIR(0)="D"
S DIR("A")="DATE ORDERED (BEGIN RANGE)"
S DIR("B")=DTX
D ^DIR
I $D(DTOUT)!(X["^") G EXIT
D ^%DT
S FR4=Y
K DIR
S DIR(0)="D"
S DIR("A")="DATE ORDERED (END RANGE) "
S DIR("B")="TODAY"
D ^DIR
I $D(DTOUT)!(X["^") G EXIT
D ^%DT
S TO4=Y
;
S NX=0
;
S ZTSAVE("FR1")=""
S ZTSAVE("FR2")=""
S ZTSAVE("FR3")=""
S ZTSAVE("FR4")=""
S ZTSAVE("TO1")=""
S ZTSAVE("TO2")=""
S ZTSAVE("TO3")=""
S ZTSAVE("TO4")=""
S ZTSAVE("ITMNO")=""
S ZTSAVE("ITMDESC")=""
D EN^XUTMDEVQ("LOOPPD^PRCHRPTX","ITEM HISTORY Report by Date Range",.ZTSAVE,.%ZIS)
I '$D(ZTSK) W ! G EXIT
K ZTSK
Q
;
LOOPPD ; Set up to locate records to display.
N FCPS,FCPE,STN,DATES,DATET,LNCT,ABORT,NX,SITFCPS,SITFCPE
N FCP,COUNT,HDR,PG
S PG=0
S FCPS=FR1
S FCPE=TO1
S STN=FR2
S ITMNO=FR3
S DATES=FR4
S DATET=TO4
S ABORT=0
S NX=0
S SITFCPS=STN_FCPS
S SITFCPE=STN_FCPE
;
LOOPPD1 ; Loop through file 441.
;
; 1. Loop through Fund Control Point for PRC("SITE")
; within one Item Master File Number.
; 2. Loop through P.O. DATE (in reverse order).
; 3. Loop through a single P.O. DATE to get file 442 PO NUMBER.
;
; These three nested loops will locate Purchase Orders to display.
;
S FCP=0
S COUNT=0
;
; Get FCP.
;
F S FCP=$O(^PRC(441,ITMNO,4,"B",FCP)) Q:FCP'>0 D Q:ABORT=1
. Q:STN'=$E(FCP,1,$L(STN))
. Q:FCPS>0&((FCP<SITFCPS)!(FCP>SITFCPE))
. ;
. ; Because DATE in "AC" x-reference is in reverse order(latest
. ; date first) the search must start after TO4, the ending PO date.
. ;
. S DATE=(9999999-DATET)-1
. S NODATE=0
. ;
. ; Starting a new FCP. Force listing a header.
. ;
. K HDR
. ;
. ; Get DATE.
. ;
. F D Q:NODATE=1 Q:ABORT=1
. . S DATE=$O(^PRC(441,ITMNO,4,FCP,1,"AC",DATE))
. . I DATE'>0 S NODATE=1 Q
. . S CKDATE=9999999-DATE
. . ;
. . ; See if date found is before FR4 (starting date).
. . ; If true, there will be no more dates between FR4 and TO4.
. . ; Set the flag to stop this loop through "AC".
. . ;
. . I CKDATE<DATES S NODATE=1 Q
. . ;
. . ; If the date found is after TO4 (ending date) there may be
. . ; some dates between FR4 and TO4.
. . ;
. . Q:CKDATE>DATET
. . S PO=0
. . ;
. . ; Get PO NUMBER (may be more than one per DATE).
. . ;
. . F S PO=$O(^PRC(441,ITMNO,4,FCP,1,"AC",DATE,PO)) Q:PO'>0 D Q:ABORT=1
. . . S POCK=$G(^PRC(442,PO,0))
. . . Q:POCK']""
. . . S COUNT=COUNT+1
. . . D DISP
. . . Q
. . Q
. Q
Q
;
DISP S LX=$O(^PRC(442,PO,2,"AE",ITMNO,0))
Q:LX'>0
S LXN0(LX)=$G(^PRC(442,PO,2,LX,0))
S LXN2(LX)=$G(^PRC(442,PO,2,LX,2))
S ND0=$G(^PRC(442,PO,0))
S ND1=$G(^PRC(442,PO,1))
S PONUM=$P(ND0,U,1)
S PODTX=$P(ND1,U,15)
S FCPX=$P(ND0,U,3)
S VP=$P(ND1,U,1)
S IMFX=$P(LXN0(LX),U,5)
S QTY=$P(LXN0(LX),U,2)
S UIP=$P(LXN0(LX),U,3)
S ACST=$P(LXN0(LX),U,9)
S QPR=+$P(LXN2(LX),U,8)
S TCST=$P(LXN2(LX),U,1)
S STNX=$P(PONUM,"-",1)
S FCPX=$P(FCPX," ",1)
S MAXL=IOSL-4
I '$D(LNCT) D Q:ABORT=1
. S LNCT=0
. D HDR
. S HDR=1
. Q
I '$D(HDR)&(LNCT>9) D Q:ABORT=1
. S HDR=1
. S LCNT=1
. D HDR
. Q
S LNCT=LNCT+3
D:LNCT>MAXL HDR
S X=PODTX
D H^%DTC
D YX^%DTC
S PODT=Y
S UIPX=" "
S VNDX=" "
S:UIP'="" UIPX=$P(^PRCD(420.5,UIP,0),U,1)
S:VP'=""&(VP'=0) VNDX=$P(^PRC(440,VP,0),U,1)
S:ACST'["." ACST=ACST_".00"
S:TCST'["." TCST=TCST_".00"
S ACL=$L(ACST)
S TCL=$L(TCST)
S ACS2=$P(ACST,".",2)
S TCS2=$P(TCST,".",2)
F M=1:1:2 D
. S ACS2=ACS2_$E("00",1,2-$L(ACS2))
. S TCS2=TCS2_$E("00",1,2-$L(TCS2))
. Q
S ACST=$P(ACST,".",1)_"."_ACS2
S TCST=$P(TCST,".",1)_"."_TCS2
S SP9=" "
F M=1:1:9 D
. S ACST=$E(SP9,1,9-$L(ACST))_ACST
. S TCST=$E(SP9,1,9-$L(TCST))_TCST
. S QTY=$E(SP9,1,9-$L(QTY))_QTY
. S QPR=$E(SP9,1,9-$L(QPR))_QPR
. Q
I ABORT=0 D
. W !!,PODT,?15,PONUM,?26,QPR,?38,UIPX,?48,ACST,?59,TCST,?70,QTY,!,VNDX
. S STATX=$P($G(^PRC(442,PO,7)),U,1)
. W:STATX=45 ?50,"Order Status=CANCELLED"
. Q
Q
;
MOFCP K DIR
S DIR(0)="Y"
S DIR("A")="Would you like to do another FCP Date-Range Listing for this item"
S DIR("B")="NO"
D ^DIR
I $D(DTOUT)!(X["^")!(X["N")!(X="n") G EXIT
G XXLST
;
EXIT K CST,P2,ABORT
D Q^PRCHRPT1
G EN^PRCHRPT1
;
CALCCST ; EP -- CALCULATES ACTUAL UNIT COST TO 2 DECIMALS
S CST=$P(X,U,9)
I CST'["." S CST=CST_"."
S P2=$P(CST,".",2)
I $L(P2)=0 S P2="00"
I $L(P2)=1 S P2=P2_"0"
I $L(P2)>2&($E(P2,3)>4) S $E(P2,2)=$E(P2,2)+1
I $L(P2)>2 S P2=$E(P2,1,2)
S CST=$P(CST,".",1)_"."_P2
F J=1:1:10 I $L(CST)<10 S CST=" "_CST
W CST
Q
;
HDR I $E(IOST)="C"&(LNCT'=0) W ! D PAUSE Q:ABORT=1
S FCPD=FCPX
S PG=PG+1
S:FCPX>0 FCPD=$P(ND0,U,3)
W @IOF,!!,"Item Number: ",ITMNO,?25,"Description: "
W ITMDESC,?71,"Page ",PG
W !?7,"SITE: ",STN,?25,"FCP: ",FCPD,!!,?26,"Quantity"
W !,?26,"Previously",?38,"Unit of",?71,"Quantity"
W !,"Date Ordered",?15,"PO Number",?26,"Received",?38,"Purchase"
W ?48,"Unit Cost",?59,"Total Cost",?71,"Ordered",!
F I=1:1:80 W "_"
S LNCT=9
Q
;
PAUSE ; Test for prompt to return or exit
K DIR
S ABORT=0
S DIR(0)="E"
D ^DIR
I Y=""!(Y=0) S ABORT=1
Q
;
ASK Q:$E(IOST)="P"
W !!,"Press RETURN to continue"
R X:DTIME
S ASK=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPTX 7216 printed Dec 13, 2024@02:10:38 Page 2
PRCHRPTX ;AAC/JDM-PRCH ITEM HISTORY BY DATE RANGE ; [1/13/99 11:13am]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 ; <<<<<<<<<<<< Expected Variables In >>>>>>>>>>>>>
+4 ; PRC("SITE")=Stn.# (Mandatory)
+5 ; ITMNO;ITMNO=Item Master #
+6 ; <<<<<<<<<<<< Other Variables Used >>>>>>>>>>>>>>
+7 ; FR1 & TO1=Starting and ending FCP for sort
+8 ; FR2 & TO2=Starting & ending Stn.# for sort (Set from PRC("SITE")
+9 ; FR3 & TO3=Starting & ending Itm.# for sort (Set from ITMNO)
+10 ; FR4 & TO4=Starting & ending PO Date for sort
+11 ; ITMDESC=Set from file entry
+12 ;
EN ;DISPLAY ITEM HISTORY
+1 ;
XXLST SET STN=PRC("SITE")
+1 SET ABORT=0
+2 WRITE !,"STN: ",STN
+3 KILL DIR
+4 SET DIR(0)="S^ALL:ALL FCPs;RANGE:RANGE of FCPs;SPECIFIC:SPECIFIC FCP"
+5 SET DIR("A")="List Item Activity (by DATE RANGE) for"
+6 SET DIR("B")="ALL"
+7 DO ^DIR
+8 IF X["^"!($DATA(DTOUT))
GOTO EXIT
+9 SET SCTL=X
+10 IF $EXTRACT(X,1)="A"!($EXTRACT(X,1)="a")
Begin DoDot:1
+11 SET FR2=STN
+12 SET TO2=STN
+13 SET FR1=0
+14 SET TO1="99999 ZZZ"
+15 QUIT
End DoDot:1
GOTO XXITM
+16 WRITE !!,"START WITH FCP"
+17 IF $EXTRACT(SCTL,1)="S"!($EXTRACT(SCTL,1)="s")
WRITE " and END WITH FCP"
+18 SET DIC="^PRC(420,STN,1,"
+19 SET DIC(0)="QEAMNZ"
+20 DO ^DIC
+21 IF X="^"
GOTO EXIT
+22 IF Y'>0
WRITE !,"INVALID SELECTION. TRY AGAIN ('^' TO ABORT)."
GOTO XXLST
+23 SET X=$PIECE(Y,U,2)
+24 SET FR1=$PIECE(X," ",1)
+25 SET FR2=STN
+26 IF $EXTRACT(SCTL,1)="S"!($EXTRACT(SCTL,1)="s")
GOTO XFCP
+27 ;
TOFCP WRITE !!,"END WITH FCP"
+1 DO ^DIC
+2 IF Y'>0
WRITE !,"INVALID SELECTION. TRY AGAIN ('^' TO ABORT)."
GOTO TOFCP
+3 IF X="^"
GOTO EXIT
+4 ;
XFCP SET X=$PIECE(Y,U,2)
+1 SET TO1=$PIECE(X," ",1)
+2 SET TO2=STN
+3 ;
XXITM IF $DATA(ITMNO)
Begin DoDot:1
+1 SET FR3=ITMNO
+2 SET TO3=ITMNO
+3 QUIT
End DoDot:1
GOTO XXDT
+4 SET DIC="^PRC(441,"
+5 SET DIC(0)="QEAMNZ"
+6 DO ^DIC
+7 IF X="^"
GOTO EXIT
+8 IF Y'>0
WRITE !,"INVALID SELECTION"
GOTO XXITM
+9 SET ITMNO=$PIECE(Y(0),U,1)
+10 SET FR3=ITMNO
+11 SET TO3=ITMNO
+12 ;
XXDT SET ITMDESC=$PIECE(^PRC(441,ITMNO,0),U,2)
+1 DO NOW^%DTC
+2 DO YX^%DTC
+3 SET DTX=$PIECE(Y,"@",1)
+4 SET DTX="JAN 1,"_$PIECE(DTX,",",2)
+5 KILL DIR
+6 SET DIR(0)="D"
+7 SET DIR("A")="DATE ORDERED (BEGIN RANGE)"
+8 SET DIR("B")=DTX
+9 DO ^DIR
+10 IF $DATA(DTOUT)!(X["^")
GOTO EXIT
+11 DO ^%DT
+12 SET FR4=Y
+13 KILL DIR
+14 SET DIR(0)="D"
+15 SET DIR("A")="DATE ORDERED (END RANGE) "
+16 SET DIR("B")="TODAY"
+17 DO ^DIR
+18 IF $DATA(DTOUT)!(X["^")
GOTO EXIT
+19 DO ^%DT
+20 SET TO4=Y
+21 ;
+22 SET NX=0
+23 ;
+24 SET ZTSAVE("FR1")=""
+25 SET ZTSAVE("FR2")=""
+26 SET ZTSAVE("FR3")=""
+27 SET ZTSAVE("FR4")=""
+28 SET ZTSAVE("TO1")=""
+29 SET ZTSAVE("TO2")=""
+30 SET ZTSAVE("TO3")=""
+31 SET ZTSAVE("TO4")=""
+32 SET ZTSAVE("ITMNO")=""
+33 SET ZTSAVE("ITMDESC")=""
+34 DO EN^XUTMDEVQ("LOOPPD^PRCHRPTX","ITEM HISTORY Report by Date Range",.ZTSAVE,.%ZIS)
+35 IF '$DATA(ZTSK)
WRITE !
GOTO EXIT
+36 KILL ZTSK
+37 QUIT
+38 ;
LOOPPD ; Set up to locate records to display.
+1 NEW FCPS,FCPE,STN,DATES,DATET,LNCT,ABORT,NX,SITFCPS,SITFCPE
+2 NEW FCP,COUNT,HDR,PG
+3 SET PG=0
+4 SET FCPS=FR1
+5 SET FCPE=TO1
+6 SET STN=FR2
+7 SET ITMNO=FR3
+8 SET DATES=FR4
+9 SET DATET=TO4
+10 SET ABORT=0
+11 SET NX=0
+12 SET SITFCPS=STN_FCPS
+13 SET SITFCPE=STN_FCPE
+14 ;
LOOPPD1 ; Loop through file 441.
+1 ;
+2 ; 1. Loop through Fund Control Point for PRC("SITE")
+3 ; within one Item Master File Number.
+4 ; 2. Loop through P.O. DATE (in reverse order).
+5 ; 3. Loop through a single P.O. DATE to get file 442 PO NUMBER.
+6 ;
+7 ; These three nested loops will locate Purchase Orders to display.
+8 ;
+9 SET FCP=0
+10 SET COUNT=0
+11 ;
+12 ; Get FCP.
+13 ;
+14 FOR
SET FCP=$ORDER(^PRC(441,ITMNO,4,"B",FCP))
if FCP'>0
QUIT
Begin DoDot:1
+15 if STN'=$EXTRACT(FCP,1,$LENGTH(STN))
QUIT
+16 if FCPS>0&((FCP<SITFCPS)!(FCP>SITFCPE))
QUIT
+17 ;
+18 ; Because DATE in "AC" x-reference is in reverse order(latest
+19 ; date first) the search must start after TO4, the ending PO date.
+20 ;
+21 SET DATE=(9999999-DATET)-1
+22 SET NODATE=0
+23 ;
+24 ; Starting a new FCP. Force listing a header.
+25 ;
+26 KILL HDR
+27 ;
+28 ; Get DATE.
+29 ;
+30 FOR
Begin DoDot:2
+31 SET DATE=$ORDER(^PRC(441,ITMNO,4,FCP,1,"AC",DATE))
+32 IF DATE'>0
SET NODATE=1
QUIT
+33 SET CKDATE=9999999-DATE
+34 ;
+35 ; See if date found is before FR4 (starting date).
+36 ; If true, there will be no more dates between FR4 and TO4.
+37 ; Set the flag to stop this loop through "AC".
+38 ;
+39 IF CKDATE<DATES
SET NODATE=1
QUIT
+40 ;
+41 ; If the date found is after TO4 (ending date) there may be
+42 ; some dates between FR4 and TO4.
+43 ;
+44 if CKDATE>DATET
QUIT
+45 SET PO=0
+46 ;
+47 ; Get PO NUMBER (may be more than one per DATE).
+48 ;
+49 FOR
SET PO=$ORDER(^PRC(441,ITMNO,4,FCP,1,"AC",DATE,PO))
if PO'>0
QUIT
Begin DoDot:3
+50 SET POCK=$GET(^PRC(442,PO,0))
+51 if POCK']""
QUIT
+52 SET COUNT=COUNT+1
+53 DO DISP
+54 QUIT
End DoDot:3
if ABORT=1
QUIT
+55 QUIT
End DoDot:2
if NODATE=1
QUIT
if ABORT=1
QUIT
+56 QUIT
End DoDot:1
if ABORT=1
QUIT
+57 QUIT
+58 ;
DISP SET LX=$ORDER(^PRC(442,PO,2,"AE",ITMNO,0))
+1 if LX'>0
QUIT
+2 SET LXN0(LX)=$GET(^PRC(442,PO,2,LX,0))
+3 SET LXN2(LX)=$GET(^PRC(442,PO,2,LX,2))
+4 SET ND0=$GET(^PRC(442,PO,0))
+5 SET ND1=$GET(^PRC(442,PO,1))
+6 SET PONUM=$PIECE(ND0,U,1)
+7 SET PODTX=$PIECE(ND1,U,15)
+8 SET FCPX=$PIECE(ND0,U,3)
+9 SET VP=$PIECE(ND1,U,1)
+10 SET IMFX=$PIECE(LXN0(LX),U,5)
+11 SET QTY=$PIECE(LXN0(LX),U,2)
+12 SET UIP=$PIECE(LXN0(LX),U,3)
+13 SET ACST=$PIECE(LXN0(LX),U,9)
+14 SET QPR=+$PIECE(LXN2(LX),U,8)
+15 SET TCST=$PIECE(LXN2(LX),U,1)
+16 SET STNX=$PIECE(PONUM,"-",1)
+17 SET FCPX=$PIECE(FCPX," ",1)
+18 SET MAXL=IOSL-4
+19 IF '$DATA(LNCT)
Begin DoDot:1
+20 SET LNCT=0
+21 DO HDR
+22 SET HDR=1
+23 QUIT
End DoDot:1
if ABORT=1
QUIT
+24 IF '$DATA(HDR)&(LNCT>9)
Begin DoDot:1
+25 SET HDR=1
+26 SET LCNT=1
+27 DO HDR
+28 QUIT
End DoDot:1
if ABORT=1
QUIT
+29 SET LNCT=LNCT+3
+30 if LNCT>MAXL
DO HDR
+31 SET X=PODTX
+32 DO H^%DTC
+33 DO YX^%DTC
+34 SET PODT=Y
+35 SET UIPX=" "
+36 SET VNDX=" "
+37 if UIP'=""
SET UIPX=$PIECE(^PRCD(420.5,UIP,0),U,1)
+38 if VP'=""&(VP'=0)
SET VNDX=$PIECE(^PRC(440,VP,0),U,1)
+39 if ACST'["."
SET ACST=ACST_".00"
+40 if TCST'["."
SET TCST=TCST_".00"
+41 SET ACL=$LENGTH(ACST)
+42 SET TCL=$LENGTH(TCST)
+43 SET ACS2=$PIECE(ACST,".",2)
+44 SET TCS2=$PIECE(TCST,".",2)
+45 FOR M=1:1:2
Begin DoDot:1
+46 SET ACS2=ACS2_$EXTRACT("00",1,2-$LENGTH(ACS2))
+47 SET TCS2=TCS2_$EXTRACT("00",1,2-$LENGTH(TCS2))
+48 QUIT
End DoDot:1
+49 SET ACST=$PIECE(ACST,".",1)_"."_ACS2
+50 SET TCST=$PIECE(TCST,".",1)_"."_TCS2
+51 SET SP9=" "
+52 FOR M=1:1:9
Begin DoDot:1
+53 SET ACST=$EXTRACT(SP9,1,9-$LENGTH(ACST))_ACST
+54 SET TCST=$EXTRACT(SP9,1,9-$LENGTH(TCST))_TCST
+55 SET QTY=$EXTRACT(SP9,1,9-$LENGTH(QTY))_QTY
+56 SET QPR=$EXTRACT(SP9,1,9-$LENGTH(QPR))_QPR
+57 QUIT
End DoDot:1
+58 IF ABORT=0
Begin DoDot:1
+59 WRITE !!,PODT,?15,PONUM,?26,QPR,?38,UIPX,?48,ACST,?59,TCST,?70,QTY,!,VNDX
+60 SET STATX=$PIECE($GET(^PRC(442,PO,7)),U,1)
+61 if STATX=45
WRITE ?50,"Order Status=CANCELLED"
+62 QUIT
End DoDot:1
+63 QUIT
+64 ;
MOFCP KILL DIR
+1 SET DIR(0)="Y"
+2 SET DIR("A")="Would you like to do another FCP Date-Range Listing for this item"
+3 SET DIR("B")="NO"
+4 DO ^DIR
+5 IF $DATA(DTOUT)!(X["^")!(X["N")!(X="n")
GOTO EXIT
+6 GOTO XXLST
+7 ;
EXIT KILL CST,P2,ABORT
+1 DO Q^PRCHRPT1
+2 GOTO EN^PRCHRPT1
+3 ;
CALCCST ; EP -- CALCULATES ACTUAL UNIT COST TO 2 DECIMALS
+1 SET CST=$PIECE(X,U,9)
+2 IF CST'["."
SET CST=CST_"."
+3 SET P2=$PIECE(CST,".",2)
+4 IF $LENGTH(P2)=0
SET P2="00"
+5 IF $LENGTH(P2)=1
SET P2=P2_"0"
+6 IF $LENGTH(P2)>2&($EXTRACT(P2,3)>4)
SET $EXTRACT(P2,2)=$EXTRACT(P2,2)+1
+7 IF $LENGTH(P2)>2
SET P2=$EXTRACT(P2,1,2)
+8 SET CST=$PIECE(CST,".",1)_"."_P2
+9 FOR J=1:1:10
IF $LENGTH(CST)<10
SET CST=" "_CST
+10 WRITE CST
+11 QUIT
+12 ;
HDR IF $EXTRACT(IOST)="C"&(LNCT'=0)
WRITE !
DO PAUSE
if ABORT=1
QUIT
+1 SET FCPD=FCPX
+2 SET PG=PG+1
+3 if FCPX>0
SET FCPD=$PIECE(ND0,U,3)
+4 WRITE @IOF,!!,"Item Number: ",ITMNO,?25,"Description: "
+5 WRITE ITMDESC,?71,"Page ",PG
+6 WRITE !?7,"SITE: ",STN,?25,"FCP: ",FCPD,!!,?26,"Quantity"
+7 WRITE !,?26,"Previously",?38,"Unit of",?71,"Quantity"
+8 WRITE !,"Date Ordered",?15,"PO Number",?26,"Received",?38,"Purchase"
+9 WRITE ?48,"Unit Cost",?59,"Total Cost",?71,"Ordered",!
+10 FOR I=1:1:80
WRITE "_"
+11 SET LNCT=9
+12 QUIT
+13 ;
PAUSE ; Test for prompt to return or exit
+1 KILL DIR
+2 SET ABORT=0
+3 SET DIR(0)="E"
+4 DO ^DIR
+5 IF Y=""!(Y=0)
SET ABORT=1
+6 QUIT
+7 ;
ASK if $EXTRACT(IOST)="P"
QUIT
+1 WRITE !!,"Press RETURN to continue"
+2 READ X:DTIME
+3 SET ASK=1
+4 QUIT
