PRCHRP8 ;WISC/KMB/CR-PC STATISTICS REPORT ;7/16/98 14:55
;;5.1;IFCAP;**8**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
N C1,C2,C3,C4,C5,AMT,PC,P,PRC,ZP,CP,LCT,BOC,CNT,PDATE,TRAN,XXZ,EX,Y,YY,PCLCT,PCCNT,BB,AA,COUNT,FDATE,EDATE,PCN,GTOT,END,TDATE
N PCNUM,SEQNUM,CTR,CTR1,CPCNT,I,PRCRI,Z0,Z1,Z7,Z23,ZP1,ZIP,USER,%
K ^TMP($J)
W @IOF S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
Q:$G(X)="^"
;
RANGE ;
S DIR("A")="Enter beginning date",DIR("?")="Enter the first date for which you wish to see records"
S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S FDATE=+Y W " ",Y(0)
S DIR("A")="Enter ending date",DIR("?")="Enter the last date for which you wish to see records"
S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S EDATE=+Y W " ",Y(0)
I EDATE<FDATE W !,"Date range is incorrect." G RANGE
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="DETAIL^PRCHRP8",ZTSAVE("EDATE")="",ZTSAVE("FDATE")="",ZTSAVE("PRC*")="" D ^%ZTLOAD,^%ZISC Q
D DETAIL,^%ZISC Q
;
DETAIL ;
D NOW^%DTC S Y=% D DD^%DT S TDATE=Y
S GTOT=0,U="^",(COUNT,P,EX,CNT)=1
S CTR=FDATE F S CTR=$O(^PRC(442,"AB",CTR)) Q:+CTR=0 Q:CTR>EDATE D
.S CTR1=0 F S CTR1=$O(^PRC(442,"AB",CTR,CTR1)) Q:+CTR1=0 D
..S ZP1=CTR1 S Z0=$G(^PRC(442,ZP1,0)),Z1=$G(^PRC(442,ZP1,1)),Z7=$P(Z0,"^",12) S:Z7="" Z7=0
..I $D(PRC("SITE")) Q:$P(Z0,"-")'=PRC("SITE")
..S SEQNUM=$P(Z0,"^")
..S Z23=$G(^PRC(442,ZP1,23))
..S (Y,YY)=$P(Z1,"^",15) Q:YY<FDATE Q:YY>EDATE
..S CP=$P(Z0,"^",3),CP=+$P(CP," ") Q:CP=0
..S:$G(AA(CP,1))="" AA(CP,1)=0 S AA(CP,1)=AA(CP,1)+1
..S PC=$P(Z23,"^",8) Q:PC="" S PCNUM=$P($G(^PRC(440.5,PC,0)),"^") Q:PCNUM="" S PCN=$P($G(^PRC(440.5,PC,0)),"^",11),PCN=$E(PCN,1,28)
..D DD^%DT S PDATE=Y
..S:$G(AA(CP))="" AA(CP)=0 S:$G(AA(CP,2))="" AA(CP,2)=0
..S AMT=$P(Z0,"^",15),LCT=$P($G(^PRCS(410,Z7,"IT",0)),"^",4),AA(CP,2)=AA(CP,2)+AMT,AA(CP)=AA(CP)+1,GTOT=GTOT+AMT
..S USER=$P($G(^PRC(440.5,PC,0)),"^",8) Q:USER="" S USER=$P($G(^VA(200,USER,0)),"^") Q:USER=""
..S ^TMP($J,CP,USER,PCNUM,YY,COUNT)=PCN_"^"_SEQNUM_"^"_LCT_"^"_AMT_"^"_PDATE,COUNT=COUNT+1
..I '$D(BB(PCNUM)) S (BB(PCNUM),BB(PCNUM,1),BB(PCNUM,2))=0
..S BB(PCNUM)=BB(PCNUM)+LCT,BB(PCNUM,1)=BB(PCNUM,1)+1,BB(PCNUM,2)=BB(PCNUM,2)+AMT
;
WRITE ;
U IO
I '$D(^TMP($J)) S C1="",C2="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
S (C1,C2,C3,C4,C5)=0 F S C1=$O(^TMP($J,C1)) Q:EX[U Q:C1="" D
.F S C2=$O(^TMP($J,C1,C2)) Q:EX[U Q:C2="" D
..D HEADER
..F S C3=$O(^TMP($J,C1,C2,C3)) Q:EX[U Q:C3="" D
...F S C4=$O(^TMP($J,C1,C2,C3,C4)) Q:EX[U Q:C4="" D
....F S C5=$O(^TMP($J,C1,C2,C3,C4,C5)) Q:EX[U Q:C5="" D
.....S ZIP=^TMP($J,C1,C2,C3,C4,C5) W !,$P(ZIP,"^"),?30,$P(ZIP,"^",2),?43,$P(ZIP,"^",3) S AMT=$P(ZIP,"^",4) W ?52,$J(AMT,12,2),?67,$P(ZIP,"^",5)
.....I (IOSL-$Y)<8 D HOLD Q:EX[U
...I EX'[U S PCCNT=BB(C3,2)/BB(C3,1),PCLCT=BB(C3)/BB(C3,1) W !!,"AVERAGE DOLLAR COST FOR CARD: $",$J(PCCNT,0,2),!," AVERAGE LINE COUNT FOR CARD: ",$J(PCLCT,0,2),!
..I EX'[U S CPCNT=100*(AA(C1)/AA(C1,1)) W !!,"% OF PC ORDERS FOR CP ",C1,": ",$J(CPCNT,0,3),!,"PC ORDER COUNT: ",AA(C1),?30,"TOTAL ORDER COUNT: ",AA(C1,1),!," PC SUBTOTAL: ",$J(AA(C1,2),0,2)
..I $E(IOST,1,2)'="P-",EX'[U W !,"Press return to continue, '^', to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U
I EX'[U W !?25,"STATION GRAND TOTAL - $",$J(GTOT,0,2)
K ^TMP($J)
QUIT
;
HOLD G HEADER:$E(IOST,1,2)="P-"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U D:EX'=U HEADER
QUIT
;
W @IOF
W "PURCHASE CARD STATISTICS REPORT",?42,TDATE,?70,"PAGE ",P
W !,"PURCHASE CARD NAME",?30,"PO NUMBER",?43,"LINE ITEMS",?58,"AMOUNT",?67,"DATE PLACED"
W ! F I=1:1:8 W "----------"
W !!,"FCP: ",C1,?20,"BUYER: ",C2,!
S P=P+1 QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP8 3801 printed Nov 22, 2024@17:20:29 Page 2
PRCHRP8 ;WISC/KMB/CR-PC STATISTICS REPORT ;7/16/98 14:55
+1 ;;5.1;IFCAP;**8**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
+1 NEW C1,C2,C3,C4,C5,AMT,PC,P,PRC,ZP,CP,LCT,BOC,CNT,PDATE,TRAN,XXZ,EX,Y,YY,PCLCT,PCCNT,BB,AA,COUNT,FDATE,EDATE,PCN,GTOT,END,TDATE
+2 NEW PCNUM,SEQNUM,CTR,CTR1,CPCNT,I,PRCRI,Z0,Z1,Z7,Z23,ZP1,ZIP,USER,%
+3 KILL ^TMP($JOB)
+4 WRITE @IOF
SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
+5 if $GET(X)="^"
QUIT
+6 ;
RANGE ;
+1 SET DIR("A")="Enter beginning date"
SET DIR("?")="Enter the first date for which you wish to see records"
+2 SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if +Y<1
QUIT
SET FDATE=+Y
WRITE " ",Y(0)
+3 SET DIR("A")="Enter ending date"
SET DIR("?")="Enter the last date for which you wish to see records"
+4 SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if +Y<1
QUIT
SET EDATE=+Y
WRITE " ",Y(0)
+5 IF EDATE<FDATE
WRITE !,"Date range is incorrect."
GOTO RANGE
+6 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+7 IF $DATA(IO("Q"))
SET ZTRTN="DETAIL^PRCHRP8"
SET ZTSAVE("EDATE")=""
SET ZTSAVE("FDATE")=""
SET ZTSAVE("PRC*")=""
DO ^%ZTLOAD
DO ^%ZISC
QUIT
+8 DO DETAIL
DO ^%ZISC
QUIT
+9 ;
DETAIL ;
+1 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TDATE=Y
+2 SET GTOT=0
SET U="^"
SET (COUNT,P,EX,CNT)=1
+3 SET CTR=FDATE
FOR
SET CTR=$ORDER(^PRC(442,"AB",CTR))
if +CTR=0
QUIT
if CTR>EDATE
QUIT
Begin DoDot:1
+4 SET CTR1=0
FOR
SET CTR1=$ORDER(^PRC(442,"AB",CTR,CTR1))
if +CTR1=0
QUIT
Begin DoDot:2
+5 SET ZP1=CTR1
SET Z0=$GET(^PRC(442,ZP1,0))
SET Z1=$GET(^PRC(442,ZP1,1))
SET Z7=$PIECE(Z0,"^",12)
if Z7=""
SET Z7=0
+6 IF $DATA(PRC("SITE"))
if $PIECE(Z0,"-")'=PRC("SITE")
QUIT
+7 SET SEQNUM=$PIECE(Z0,"^")
+8 SET Z23=$GET(^PRC(442,ZP1,23))
+9 SET (Y,YY)=$PIECE(Z1,"^",15)
if YY<FDATE
QUIT
if YY>EDATE
QUIT
+10 SET CP=$PIECE(Z0,"^",3)
SET CP=+$PIECE(CP," ")
if CP=0
QUIT
+11 if $GET(AA(CP,1))=""
SET AA(CP,1)=0
SET AA(CP,1)=AA(CP,1)+1
+12 SET PC=$PIECE(Z23,"^",8)
if PC=""
QUIT
SET PCNUM=$PIECE($GET(^PRC(440.5,PC,0)),"^")
if PCNUM=""
QUIT
SET PCN=$PIECE($GET(^PRC(440.5,PC,0)),"^",11)
SET PCN=$EXTRACT(PCN,1,28)
+13 DO DD^%DT
SET PDATE=Y
+14 if $GET(AA(CP))=""
SET AA(CP)=0
if $GET(AA(CP,2))=""
SET AA(CP,2)=0
+15 SET AMT=$PIECE(Z0,"^",15)
SET LCT=$PIECE($GET(^PRCS(410,Z7,"IT",0)),"^",4)
SET AA(CP,2)=AA(CP,2)+AMT
SET AA(CP)=AA(CP)+1
SET GTOT=GTOT+AMT
+16 SET USER=$PIECE($GET(^PRC(440.5,PC,0)),"^",8)
if USER=""
QUIT
SET USER=$PIECE($GET(^VA(200,USER,0)),"^")
if USER=""
QUIT
+17 SET ^TMP($JOB,CP,USER,PCNUM,YY,COUNT)=PCN_"^"_SEQNUM_"^"_LCT_"^"_AMT_"^"_PDATE
SET COUNT=COUNT+1
+18 IF '$DATA(BB(PCNUM))
SET (BB(PCNUM),BB(PCNUM,1),BB(PCNUM,2))=0
+19 SET BB(PCNUM)=BB(PCNUM)+LCT
SET BB(PCNUM,1)=BB(PCNUM,1)+1
SET BB(PCNUM,2)=BB(PCNUM,2)+AMT
End DoDot:2
End DoDot:1
+20 ;
WRITE ;
+1 USE IO
+2 IF '$DATA(^TMP($JOB))
SET C1=""
SET C2=""
DO HEADER
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+3 SET (C1,C2,C3,C4,C5)=0
FOR
SET C1=$ORDER(^TMP($JOB,C1))
if EX[U
QUIT
if C1=""
QUIT
Begin DoDot:1
+4 FOR
SET C2=$ORDER(^TMP($JOB,C1,C2))
if EX[U
QUIT
if C2=""
QUIT
Begin DoDot:2
+5 DO HEADER
+6 FOR
SET C3=$ORDER(^TMP($JOB,C1,C2,C3))
if EX[U
QUIT
if C3=""
QUIT
Begin DoDot:3
+7 FOR
SET C4=$ORDER(^TMP($JOB,C1,C2,C3,C4))
if EX[U
QUIT
if C4=""
QUIT
Begin DoDot:4
+8 FOR
SET C5=$ORDER(^TMP($JOB,C1,C2,C3,C4,C5))
if EX[U
QUIT
if C5=""
QUIT
Begin DoDot:5
+9 SET ZIP=^TMP($JOB,C1,C2,C3,C4,C5)
WRITE !,$PIECE(ZIP,"^"),?30,$PIECE(ZIP,"^",2),?43,$PIECE(ZIP,"^",3)
SET AMT=$PIECE(ZIP,"^",4)
WRITE ?52,$JUSTIFY(AMT,12,2),?67,$PIECE(ZIP,"^",5)
+10 IF (IOSL-$Y)<8
DO HOLD
if EX[U
QUIT
End DoDot:5
End DoDot:4
+11 IF EX'[U
SET PCCNT=BB(C3,2)/BB(C3,1)
SET PCLCT=BB(C3)/BB(C3,1)
WRITE !!,"AVERAGE DOLLAR COST FOR CARD: $",$JUSTIFY(PCCNT,0,2),!," AVERAGE LINE COUNT FOR CARD: ",$JUSTIFY(PCLCT,0,2),!
End DoDot:3
+12 IF EX'[U
SET CPCNT=100*(AA(C1)/AA(C1,1))
WRITE !!,"% OF PC ORDERS FOR CP ",C1,": ",$JUSTIFY(CPCNT,0,3),!,"PC ORDER COUNT: ",AA(C1),?30,"TOTAL ORDER COUNT: ",AA(C1,1),!," PC SUBTOTAL: ",$JUSTIFY(AA(C1,2),0,2)
+13 IF $EXTRACT(IOST,1,2)'="P-"
IF EX'[U
WRITE !,"Press return to continue, '^', to exit: "
READ XXZ:DTIME
if XXZ[U
SET EX=U
if '$TEST
SET EX=U
End DoDot:2
End DoDot:1
+14 IF EX'[U
WRITE !?25,"STATION GRAND TOTAL - $",$JUSTIFY(GTOT,0,2)
+15 KILL ^TMP($JOB)
+16 QUIT
+17 ;
HOLD if $EXTRACT(IOST,1,2)="P-"!(IO'=IO(0))
GOTO HEADER
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ[U
SET EX=U
if '$TEST
SET EX=U
if EX'=U
DO HEADER
+1 QUIT
+2 ;
+1 WRITE @IOF
+2 WRITE "PURCHASE CARD STATISTICS REPORT",?42,TDATE,?70,"PAGE ",P
+3 WRITE !,"PURCHASE CARD NAME",?30,"PO NUMBER",?43,"LINE ITEMS",?58,"AMOUNT",?67,"DATE PLACED"
+4 WRITE !
FOR I=1:1:8
WRITE "----------"
+5 WRITE !!,"FCP: ",C1,?20,"BUYER: ",C2,!
+6 SET P=P+1
QUIT
