- 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 Feb 18, 2025@23:37 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