- PRCPRCTP ;WISC/RFJ/DST-cost trend analysis (primary) ;26 May 93
- ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
- ;Per VHA Directive 2004-038, this routine should not be modified.
- Q
- ;
- ;
- PRIMARY ; cost trend analysis for primary
- ; There is no Cost Trend Analysis for secondary
- N %,%H,%I,DATEEND,DATESTRT,PRCPALLI,PRCPSUMM,X,X1,X2,Y
- N ODI ; On-Demand Item flag
- 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 Primary inventory items by description."
- 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 Items to display." W ! D DISPLAY^PRCPUX2(2,40,.X)
- D ITEMSEL^PRCPURS4 I '$G(PRCPALLI),'$O(^TMP($J,"PRCPURS4",0)) Q
- S PRCPSUMM=$$SUMMARY^PRCPURS0 I PRCPSUMM<0 Q
- W ! S %ZIS="Q" D ^%ZIS G:POP Q I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q
- . S ZTDESC="Cost Trend Analysis",ZTRTN="DQ^PRCPRCTP"
- . S ZTSAVE("PRCP*")="",ZTSAVE("DATE*")="",ZTSAVE("^TMP($J,""PRCPURS4"",")="",ZTSAVE("ZTREQ")="@"
- W !!,"<*> please wait <*>"
- DQ ; queue starts here
- N AVG,CHANGE,COUNT,CURDT,CURRENT,D,DATA,DATE,DATEEDT,DATESDT,DESCR,HDR,ITEMDA,ITEMDATA,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL
- K ^TMP($J,"PRCPRCTP")
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA D
- . I '$G(PRCPALLI),'$D(^TMP($J,"PRCPURS4",ITEMDA)) Q
- . S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
- . 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,"PRCPRCTP",$E(DESCR,1,15),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,"PRCPRCTP",$E(DESCR,1,15),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 DESCR="" F S DESCR=$O(^TMP($J,"PRCPRCTP",DESCR)) Q:DESCR=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRCTP",DESCR,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))
- . ; On-Demand Item flag check
- . S ODI=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
- . ;
- . W !!,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,33),?35,$J(ITEMDA,6),?42,$S(ODI="Y":"D",1:""),?43,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8)
- . S D=$G(^TMP($J,"PRCPRCTP",DESCR,ITEMDA,"TOTAL"))
- . W $J($P(D,"^"),9,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,"PRCPRCTP",DESCR,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
- Q D ^%ZISC K ^TMP($J,"PRCPRCTP"),^TMP($J,"PRCPURS4")
- 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 !,"DESCRIPTION",?38,"IM",?42,"OD",$J("UNIT/IS",9),$J("CUM AVG",9),$J(CURDT,9),$J("%CHANGE",9),!,%
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRCTP 4239 printed Mar 13, 2025@21:19:29 Page 2
- PRCPRCTP ;WISC/RFJ/DST-cost trend analysis (primary) ;26 May 93
- +1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- PRIMARY ; cost trend analysis for primary
- +1 ; There is no Cost Trend Analysis for secondary
- +2 NEW %,%H,%I,DATEEND,DATESTRT,PRCPALLI,PRCPSUMM,X,X1,X2,Y
- +3 ; On-Demand Item flag
- NEW ODI
- +4 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."
- +5 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."
- +6 SET X(3)="The report will sort Primary inventory items by description."
- +7 DO DISPLAY^PRCPUX2(40,79,.X)
- +8 KILL X
- SET X(1)="Enter the date range (month-year) for computing the average item cost."
- DO DISPLAY^PRCPUX2(2,40,.X)
- +9 DO MONTHSEL^PRCPURS2
- IF '$GET(DATEEND)
- QUIT
- +10 KILL X
- SET X(1)="Select the Items to display."
- WRITE !
- DO DISPLAY^PRCPUX2(2,40,.X)
- +11 DO ITEMSEL^PRCPURS4
- IF '$GET(PRCPALLI)
- IF '$ORDER(^TMP($JOB,"PRCPURS4",0))
- QUIT
- +12 SET PRCPSUMM=$$SUMMARY^PRCPURS0
- IF PRCPSUMM<0
- QUIT
- +13 WRITE !
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- GOTO Q
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +14 SET ZTDESC="Cost Trend Analysis"
- SET ZTRTN="DQ^PRCPRCTP"
- +15 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("DATE*")=""
- SET ZTSAVE("^TMP($J,""PRCPURS4"",")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- DO Q
- QUIT
- +16 WRITE !!,"<*> please wait <*>"
- DQ ; queue starts here
- +1 NEW AVG,CHANGE,COUNT,CURDT,CURRENT,D,DATA,DATE,DATEEDT,DATESDT,DESCR,HDR,ITEMDA,ITEMDATA,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL
- +2 KILL ^TMP($JOB,"PRCPRCTP")
- +3 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- Begin DoDot:1
- +4 IF '$GET(PRCPALLI)
- IF '$DATA(^TMP($JOB,"PRCPURS4",ITEMDA))
- QUIT
- +5 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
- if DESCR=""
- SET DESCR=" "
- +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,"PRCPRCTP",$EXTRACT(DESCR,1,15),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,"PRCPRCTP",$EXTRACT(DESCR,1,15),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 DESCR=""
- FOR
- SET DESCR=$ORDER(^TMP($JOB,"PRCPRCTP",DESCR))
- if DESCR=""!($GET(PRCPFLAG))
- QUIT
- SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRCTP",DESCR,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 ; On-Demand Item flag check
- +23 SET ODI=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
- +24 ;
- +25 WRITE !!,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,33),?35,$JUSTIFY(ITEMDA,6),?42,$SELECT(ODI="Y":"D",1:""),?43,$JUSTIFY($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8)
- +26 SET D=$GET(^TMP($JOB,"PRCPRCTP",DESCR,ITEMDA,"TOTAL"))
- +27 WRITE $JUSTIFY($PIECE(D,"^"),9,2),$JUSTIFY($PIECE(D,"^",2),10,2),$JUSTIFY($PIECE(D,"^",3),10,2)
- +28 IF $GET(PRCPSUMM)
- QUIT
- +29 SET DATE=0
- FOR
- Begin DoDot:2
- +30 SET (DATA,HDR)=""
- +31 FOR COUNT=1:1:9
- SET DATE=$ORDER(^TMP($JOB,"PRCPRCTP",DESCR,ITEMDA,DATE))
- if 'DATE
- QUIT
- SET D=^(DATE)
- Begin DoDot:3
- +32 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)
- +33 SET DATA=DATA_$JUSTIFY(D,8,2)
- End DoDot:3
- +34 IF DATA'=""
- WRITE !?5,HDR,!?5,DATA
- +35 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
- +36 IF '$GET(PRCPFLAG)
- DO END^PRCPUREP
- Q DO ^%ZISC
- KILL ^TMP($JOB,"PRCPRCTP"),^TMP($JOB,"PRCPURS4")
- +1 QUIT
- +2 ;
- 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 !,"DESCRIPTION",?38,"IM",?42,"OD",$JUSTIFY("UNIT/IS",9),$JUSTIFY("CUM AVG",9),$JUSTIFY(CURDT,9),$JUSTIFY("%CHANGE",9),!,%
- +4 QUIT
