- PRCPRCTA ;WISC/RFJ-cost trend analysis (option, whse) ;26 May 93
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- I PRCP("DPTYPE")="P" D PRIMARY^PRCPRCTP Q
- ;
- ; cost trend analysis for whse
- N %,%H,%I,DATEEND,DATESTRT,PRCPEND,PRCPSTRT,PRCPSUMM,X,Y
- K X S X(1)="The Cost Trend Analysis Report will compute the average item cost for the specified period based on the monthly opening balance last receipt cost."
- S X(2)="It will compare the computed average item cost with the current monthly opening balance average cost and display the percent increase or decrease change."
- S X(3)="The report will sort Warehouse inventory items by NSN."
- D DISPLAY^PRCPUX2(40,79,.X)
- K X S X(1)="Enter the date range (month-year) for computing the average item cost." D DISPLAY^PRCPUX2(2,40,.X)
- D MONTHSEL^PRCPURS2 I '$G(DATEEND) Q
- K X S X(1)="Select the range of NSNs to display." W ! D DISPLAY^PRCPUX2(2,40,.X)
- D NSNSEL^PRCPURS0 I '$D(PRCPSTRT) Q
- S PRCPSUMM=$$SUMMARY^PRCPURS0 I PRCPSUMM<0 Q
- W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
- . S ZTDESC="Cost Trend Analysis",ZTRTN="DQ^PRCPRCTA"
- . S ZTSAVE("PRCP*")="",ZTSAVE("DATE*")="",ZTSAVE("ZTREQ")="@"
- W !!,"<*> please wait <*>"
- DQ ; queue starts here
- N AVG,CHANGE,COUNT,CURDT,CURRENT,D,DATA,DATE,DATEEDT,DATESDT,HDR,ITEMDA,ITEMDATA,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL
- K ^TMP($J,"PRCPRCTA")
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA D
- . S NSN=$$NSN^PRCPUX1(ITEMDA) S:NSN="" NSN=" "
- . I $E(NSN,1,$L(PRCPSTRT))'=PRCPSTRT,$E(NSN,1,$L(PRCPEND))'=PRCPEND I NSN']PRCPSTRT!(PRCPEND']NSN) Q
- . S (COUNT,TOTAL)=0
- . S DATE=$E(DATESTRT,1,5) F D Q:DATE>$E(DATEEND,1,5)
- . . S D=$G(^PRCP(445.1,PRCP("I"),1,ITEMDA,1,DATE,0))
- . . S ^TMP($J,"PRCPRCTA",NSN,ITEMDA,DATE)=+$P(D,"^",7)
- . . I $P(D,"^",7) S COUNT=COUNT+1,TOTAL=TOTAL+$P(D,"^",7)
- . . S X1=DATE_"00",X2=40 D C^%DTC S DATE=$E(X,1,5)
- . S AVG=$S(COUNT=0:0,1:$J(TOTAL/COUNT,0,3)),CURRENT=+$P($G(^PRCP(445.1,PRCP("I"),1,ITEMDA,1,$E(DT,1,5),0)),"^",7),CHANGE=$S(AVG=0:"***.**",1:(CURRENT-AVG)/AVG*100)
- . S ^TMP($J,"PRCPRCTA",NSN,ITEMDA,"TOTAL")=AVG_"^"_CURRENT_"^"_CHANGE
- ; print report
- D NOW^%DTC S Y=% D DD^%DT S NOW=Y,Y=$E(DT,1,5)_"00" D DD^%DT S CURDT=Y
- S Y=$E(DATESTRT,1,5)_"00" D DD^%DT S DATESDT=Y,Y=$E(DATEEND,1,5)_"00" D DD^%DT S DATEEDT=Y
- S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
- S NSN="" F S NSN=$O(^TMP($J,"PRCPRCTA",NSN)) Q:NSN=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRCTA",NSN,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
- . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
- . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
- . W !!,$TR(NSN,"-"),?15,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,18),?34,$J(ITEMDA,6),$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),10)
- . S D=$G(^TMP($J,"PRCPRCTA",NSN,ITEMDA,"TOTAL"))
- . W $J($P(D,"^"),10,2),$J($P(D,"^",2),10,2),$J($P(D,"^",3),10,2)
- . I $G(PRCPSUMM) Q
- . S DATE=0 F D Q:'DATE!($G(PRCPFLAG))
- . . S (DATA,HDR)=""
- . . F COUNT=1:1:9 S DATE=$O(^TMP($J,"PRCPRCTA",NSN,ITEMDA,DATE)) Q:'DATE S D=^(DATE) D
- . . . S %=$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",+$E(DATE,4,5))_" "_$E(DATE,2,3),HDR=HDR_$J(%,8)
- . . . S DATA=DATA_$J(D,8,2)
- . . I DATA'="" W !?5,HDR,!?5,DATA
- . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- I '$G(PRCPFLAG) D END^PRCPUREP
- D ^%ZISC K ^TMP($J,"PRCPRCTA")
- Q
- ;
- H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
- W $C(13),"COST TREND ANALYSIS FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
- W !?5,"CUM AVG CALCULATED FROM DATE RANGE: ",DATESDT," TO ",DATEEDT
- S %="",$P(%,"-",81)="" W !,"NSN",?15,"DESCRIPTION",?38,"MI",$J("UNIT/IS",10),$J("CUM AVG",10),$J(CURDT,10),$J("%CHANGE",10),!,%
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRCTA 4006 printed Feb 18, 2025@23:41:04 Page 2
- PRCPRCTA ;WISC/RFJ-cost trend analysis (option, whse) ;26 May 93
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +4 IF PRCP("DPTYPE")="P"
- DO PRIMARY^PRCPRCTP
- QUIT
- +5 ;
- +6 ; cost trend analysis for whse
- +7 NEW %,%H,%I,DATEEND,DATESTRT,PRCPEND,PRCPSTRT,PRCPSUMM,X,Y
- +8 KILL X
- SET X(1)="The Cost Trend Analysis Report will compute the average item cost for the specified period based on the monthly opening balance last receipt cost."
- +9 SET X(2)="It will compare the computed average item cost with the current monthly opening balance average cost and display the percent increase or decrease change."
- +10 SET X(3)="The report will sort Warehouse inventory items by NSN."
- +11 DO DISPLAY^PRCPUX2(40,79,.X)
- +12 KILL X
- SET X(1)="Enter the date range (month-year) for computing the average item cost."
- DO DISPLAY^PRCPUX2(2,40,.X)
- +13 DO MONTHSEL^PRCPURS2
- IF '$GET(DATEEND)
- QUIT
- +14 KILL X
- SET X(1)="Select the range of NSNs to display."
- WRITE !
- DO DISPLAY^PRCPUX2(2,40,.X)
- +15 DO NSNSEL^PRCPURS0
- IF '$DATA(PRCPSTRT)
- QUIT
- +16 SET PRCPSUMM=$$SUMMARY^PRCPURS0
- IF PRCPSUMM<0
- QUIT
- +17 WRITE !
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +18 SET ZTDESC="Cost Trend Analysis"
- SET ZTRTN="DQ^PRCPRCTA"
- +19 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("DATE*")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- QUIT
- +20 WRITE !!,"<*> please wait <*>"
- DQ ; queue starts here
- +1 NEW AVG,CHANGE,COUNT,CURDT,CURRENT,D,DATA,DATE,DATEEDT,DATESDT,HDR,ITEMDA,ITEMDATA,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL
- +2 KILL ^TMP($JOB,"PRCPRCTA")
- +3 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- Begin DoDot:1
- +4 SET NSN=$$NSN^PRCPUX1(ITEMDA)
- if NSN=""
- SET NSN=" "
- +5 IF $EXTRACT(NSN,1,$LENGTH(PRCPSTRT))'=PRCPSTRT
- IF $EXTRACT(NSN,1,$LENGTH(PRCPEND))'=PRCPEND
- IF NSN']PRCPSTRT!(PRCPEND']NSN)
- QUIT
- +6 SET (COUNT,TOTAL)=0
- +7 SET DATE=$EXTRACT(DATESTRT,1,5)
- FOR
- Begin DoDot:2
- +8 SET D=$GET(^PRCP(445.1,PRCP("I"),1,ITEMDA,1,DATE,0))
- +9 SET ^TMP($JOB,"PRCPRCTA",NSN,ITEMDA,DATE)=+$PIECE(D,"^",7)
- +10 IF $PIECE(D,"^",7)
- SET COUNT=COUNT+1
- SET TOTAL=TOTAL+$PIECE(D,"^",7)
- +11 SET X1=DATE_"00"
- SET X2=40
- DO C^%DTC
- SET DATE=$EXTRACT(X,1,5)
- End DoDot:2
- if DATE>$EXTRACT(DATEEND,1,5)
- QUIT
- +12 SET AVG=$SELECT(COUNT=0:0,1:$JUSTIFY(TOTAL/COUNT,0,3))
- SET CURRENT=+$PIECE($GET(^PRCP(445.1,PRCP("I"),1,ITEMDA,1,$EXTRACT(DT,1,5),0)),"^",7)
- SET CHANGE=$SELECT(AVG=0:"***.**",1:(CURRENT-AVG)/AVG*100)
- +13 SET ^TMP($JOB,"PRCPRCTA",NSN,ITEMDA,"TOTAL")=AVG_"^"_CURRENT_"^"_CHANGE
- End DoDot:1
- +14 ; print report
- +15 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET NOW=Y
- SET Y=$EXTRACT(DT,1,5)_"00"
- DO DD^%DT
- SET CURDT=Y
- +16 SET Y=$EXTRACT(DATESTRT,1,5)_"00"
- DO DD^%DT
- SET DATESDT=Y
- SET Y=$EXTRACT(DATEEND,1,5)_"00"
- DO DD^%DT
- SET DATEEDT=Y
- +17 SET PAGE=1
- SET SCREEN=$$SCRPAUSE^PRCPUREP
- USE IO
- DO H
- +18 SET NSN=""
- FOR
- SET NSN=$ORDER(^TMP($JOB,"PRCPRCTA",NSN))
- if NSN=""!($GET(PRCPFLAG))
- QUIT
- SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRCTA",NSN,ITEMDA))
- if 'ITEMDA!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:1
- +19 IF $GET(ZTQUEUED)
- IF $$S^%ZTLOAD
- SET PRCPFLAG=1
- WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
- QUIT
- +20 IF $Y>(IOSL-6)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- +21 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
- +22 WRITE !!,$TRANSLATE(NSN,"-"),?15,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,18),?34,$JUSTIFY(ITEMDA,6),$JUSTIFY($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),10)
- +23 SET D=$GET(^TMP($JOB,"PRCPRCTA",NSN,ITEMDA,"TOTAL"))
- +24 WRITE $JUSTIFY($PIECE(D,"^"),10,2),$JUSTIFY($PIECE(D,"^",2),10,2),$JUSTIFY($PIECE(D,"^",3),10,2)
- +25 IF $GET(PRCPSUMM)
- QUIT
- +26 SET DATE=0
- FOR
- Begin DoDot:2
- +27 SET (DATA,HDR)=""
- +28 FOR COUNT=1:1:9
- SET DATE=$ORDER(^TMP($JOB,"PRCPRCTA",NSN,ITEMDA,DATE))
- if 'DATE
- QUIT
- SET D=^(DATE)
- Begin DoDot:3
- +29 SET %=$PIECE("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",+$EXTRACT(DATE,4,5))_" "_$EXTRACT(DATE,2,3)
- SET HDR=HDR_$JUSTIFY(%,8)
- +30 SET DATA=DATA_$JUSTIFY(D,8,2)
- End DoDot:3
- +31 IF DATA'=""
- WRITE !?5,HDR,!?5,DATA
- +32 IF $Y>(IOSL-6)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- End DoDot:2
- if 'DATE!($GET(PRCPFLAG))
- QUIT
- End DoDot:1
- +33 IF '$GET(PRCPFLAG)
- DO END^PRCPUREP
- +34 DO ^%ZISC
- KILL ^TMP($JOB,"PRCPRCTA")
- +35 QUIT
- +36 ;
- H SET %=NOW_" PAGE "_PAGE
- SET PAGE=PAGE+1
- IF PAGE'=2!(SCREEN)
- WRITE @IOF
- +1 WRITE $CHAR(13),"COST TREND ANALYSIS FOR: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
- +2 WRITE !?5,"CUM AVG CALCULATED FROM DATE RANGE: ",DATESDT," TO ",DATEEDT
- +3 SET %=""
- SET $PIECE(%,"-",81)=""
- WRITE !,"NSN",?15,"DESCRIPTION",?38,"MI",$JUSTIFY("UNIT/IS",10),$JUSTIFY("CUM AVG",10),$JUSTIFY(CURDT,10),$JUSTIFY("%CHANGE",10),!,%
- +4 QUIT