Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHRPTX

PRCHRPTX.m

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