ACKQR4 ;AUG/JLTP BIR/PTD-Procedure Cost Statistics ; [ 12/07/95 9:52 AM ]
;;3.0;QUASAR;**8**;Feb 11, 2000
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
OPTN ; Introduce option.
W @IOF,!,"This option produces a report of all CPT-4 codes used within a selected date",!,"range and their associated costs.",!
;
; get Division
S ACKDIV=$$DIV^ACKQUTL2(3,.ACKDIV,"AI") G:+ACKDIV=0 EXIT
;
; get date range
D DTRANGE^ACKQRU G:$D(DIRUT) EXIT
;
DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^ACKQR4",ZTDESC="QUASAR - Cost Comparison Report",ZTSAVE("ACK*")="" D ^%ZTLOAD D HOME^%ZIS K ZTSK G EXIT
DQ ; Entry point when queued.
U IO
D SORT,PRINT G EXIT
SORT ;
N ACKTME
K ^TMP("ACKQR4",$J) S ACKPG=0
D NOW^%DTC
S ACKXDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKTME=$P(%,".",1)
F ACKD=ACKBD:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKED) S ACKV=0 F S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV D
.S ACKHDR5=^ACK(509850.6,ACKV,5)
.; get division and make sure it was selected
.S ACKVDIV=$P(ACKHDR5,U,1) I '$D(ACKDIV(ACKVDIV)) Q
.S ACKCSC=$P($G(^ACK(509850.6,ACKV,2)),U) Q:ACKCSC=""
.I ACKCSC'="A",ACKCSC'="AT",ACKCSC'="S",ACKCSC'="ST" Q
.S ACKP=0 F S ACKP=$O(^ACK(509850.6,ACKV,3,ACKP)) Q:'ACKP D
..S ACKPD=^ACK(509850.6,ACKV,3,ACKP,0),ACKPP=+ACKPD
..S ACKPN=$P($G(^ICPT(ACKPP,0)),U) Q:ACKPN="" S ACKPDSC=$$PROCTXT^ACKQUTL8(ACKPP,ACKTME)
..S ACKPC=$P(^ACK(509850.4,ACKPP,0),U,6)
..; Get the Volume of times the Procedure was administered
..S ACKVOL=$P(ACKPD,U,3) I ACKVOL="" S ACKVOL=1
..S ACKM=0
..S:'$D(^TMP("ACKQR4",$J,0,ACKVDIV,ACKPP,ACKM)) ^(ACKM)=ACKPN_U_ACKPDSC_U_ACKPC
..S ^TMP("ACKQR4",$J,1,ACKVDIV,ACKCSC,ACKPP,ACKM)=$G(^TMP("ACKQR4",$J,1,ACKVDIV,ACKCSC,ACKPP,ACKM))+ACKVOL
K ACKVDIV
Q
PRINT ;
I '$D(^TMP("ACKQR4",$J,1)) D Q
. D DHD("")
. W !!,"No data found for report specifications."
. D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
; print the report for each division
S ACKDIV="" K ACKDCNT S ACKDCNT=0
F S ACKDIV=$O(ACKDIV(ACKDIV)) Q:ACKDIV=""!($D(DIRUT)) D PRINT2 Q:$D(DIRUT)
I '$D(DIRUT) I ACKDCNT>0 D TOTALS
Q
;
PRINT2 ; print for a single division
I '$D(^TMP("ACKQR4",$J,1,ACKDIV)) D Q
. D DHD(1)
. W !!,"No data found for report specifications.",!!
. D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
D DHD(1)
;
S ACKCSC="",ACKT=0
F S ACKCSC=$O(^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC)) Q:ACKCSC=""!($D(DIRUT)) D
.I $Y>(IOSL-9) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD(1)
.S ACKCSX=$S(ACKCSC="A":"Audiology",ACKCSC="S":"Speech Pathology",ACKCSC="AT":"Audiology Telephone",ACKCSC="ST":"Speech Telephone",1:"")
.W !!,"STOP CODE: ",ACKCSX S ACKT(ACKCSC)=0
.S ACKPC=0 F S ACKPC=$O(^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC,ACKPC)) Q:'ACKPC!($D(DIRUT)) S ACKM="" F S ACKM=$O(^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC,ACKPC,ACKM)) Q:ACKM=""!($D(DIRUT)) S ACKD=^TMP("ACKQR4",$J,0,ACKDIV,ACKPC,ACKM) D
..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD(1)
..S ACKQQ=^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC,ACKPC,ACKM),ACKTC=ACKQQ*$P(ACKD,U,3)
..S ACKT=ACKT+ACKTC,ACKT(ACKCSC)=ACKT(ACKCSC)+ACKTC
..W !,$J(ACKQQ,4),?6,$P(ACKD,U),?15,$P(ACKD,U,2),$S(ACKM]0:" "_$E(ACKM,1,29),1:"")
..W ?50,$J("$"_$J($P(ACKD,U,3),0,2),8),?60,$J("$"_$J(ACKTC,0,2),10)
.W !!,ACKCSX," Total:",?60,$J("$"_$J(ACKT(ACKCSC),0,2),10)
Q:$D(DIRUT)
I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD(1)
W !!,"Grand Total: ",?60,$J("$"_$J(ACKT,0,2),10)
D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
S ACKDCNT=ACKDCNT+ACKT
S ACKDCNT(ACKDIV)=ACKT
Q
DHD(ACKDHD) ;
W:($E(IOST)="C")!(ACKPG>0) @IOF
S ACKPG=ACKPG+1
W "Printed: ",ACKXDT,?(IOM-8),"Page: ",ACKPG,!
F X="Procedure Cost Comparison","for Date Range",ACKXBD_" to "_ACKXED W ! D CNTR^ACKQUTL(X)
I ACKDHD W ! D CNTR^ACKQUTL("For Division: "_$$DIVNAME(ACKDIV))
W !!,"QUAN",?6,"CODE",?15,"DESCRIPTION",?54,"COST",?65,"TOTAL"
S X="",$P(X,"-",IOM)="-" W !,X
Q
;
EXIT ;
K ACKBD,ACKCSC,ACKCSX,ACKD,ACKED,ACKM,ACKMP,ACKP,ACKPC,ACKPD,ACKPDSC,ACKPG,ACKPN,ACKPP,ACKQQ,ACKT,ACKTC,ACKV,ACKXBD,ACKXDT,ACKXED,X,Y,ZTSK,^TMP("ACKQR4",$J)
K ACKVOL,ACKHDR5,ACKDIV
W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
DIVNAME(ACKVDIV) ; get division name
Q $$GET1^DIQ(40.8,ACKDIV_",",.01)
;
;
TOTALS ; Display Totals
S ACKPG=ACKPG+1 W @IOF,"Printed: ",ACKXDT,?(IOM-8),"Page: ",ACKPG,!
F X="Procedure Cost Comparison","for Date Range",ACKXBD_" to "_ACKXED W ! D CNTR^ACKQUTL(X)
W ! D CNTR^ACKQUTL("Summary") W !
S X="",$P(X,"-",IOM)="-" W !,X,!!
;
S ACKDIV=""
F S ACKDIV=$O(ACKDCNT(ACKDIV)) Q:ACKDIV="" D
. W !,?8,"Total for Division: "_$$DIVNAME(ACKDIV),?57,$J("$"_$J(ACKDCNT(ACKDIV),0,2),10)
W !!,?8,"Grand Total for all Divisions ",?57,$J("$"_$J(ACKDCNT,0,2),10)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQR4 5005 printed Apr 09, 2024@21:35:22 Page 2
ACKQR4 ;AUG/JLTP BIR/PTD-Procedure Cost Statistics ; [ 12/07/95 9:52 AM ]
+1 ;;3.0;QUASAR;**8**;Feb 11, 2000
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
OPTN ; Introduce option.
+1 WRITE @IOF,!,"This option produces a report of all CPT-4 codes used within a selected date",!,"range and their associated costs.",!
+2 ;
+3 ; get Division
+4 SET ACKDIV=$$DIV^ACKQUTL2(3,.ACKDIV,"AI")
if +ACKDIV=0
GOTO EXIT
+5 ;
+6 ; get date range
+7 DO DTRANGE^ACKQRU
if $DATA(DIRUT)
GOTO EXIT
+8 ;
DEV WRITE !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
+1 KILL %ZIS,IOP
SET %ZIS="QM"
SET %ZIS("B")=""
DO ^%ZIS
IF POP
WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED."
GOTO EXIT
+2 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="DQ^ACKQR4"
SET ZTDESC="QUASAR - Cost Comparison Report"
SET ZTSAVE("ACK*")=""
DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
GOTO EXIT
DQ ; Entry point when queued.
+1 USE IO
+2 DO SORT
DO PRINT
GOTO EXIT
SORT ;
+1 NEW ACKTME
+2 KILL ^TMP("ACKQR4",$JOB)
SET ACKPG=0
+3 DO NOW^%DTC
+4 SET ACKXDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%)
SET ACKTME=$PIECE(%,".",1)
+5 FOR ACKD=ACKBD:0
SET ACKD=$ORDER(^ACK(509850.6,"B",ACKD))
if 'ACKD!(ACKD>ACKED)
QUIT
SET ACKV=0
FOR
SET ACKV=$ORDER(^ACK(509850.6,"B",ACKD,ACKV))
if 'ACKV
QUIT
Begin DoDot:1
+6 SET ACKHDR5=^ACK(509850.6,ACKV,5)
+7 ; get division and make sure it was selected
+8 SET ACKVDIV=$PIECE(ACKHDR5,U,1)
IF '$DATA(ACKDIV(ACKVDIV))
QUIT
+9 SET ACKCSC=$PIECE($GET(^ACK(509850.6,ACKV,2)),U)
if ACKCSC=""
QUIT
+10 IF ACKCSC'="A"
IF ACKCSC'="AT"
IF ACKCSC'="S"
IF ACKCSC'="ST"
QUIT
+11 SET ACKP=0
FOR
SET ACKP=$ORDER(^ACK(509850.6,ACKV,3,ACKP))
if 'ACKP
QUIT
Begin DoDot:2
+12 SET ACKPD=^ACK(509850.6,ACKV,3,ACKP,0)
SET ACKPP=+ACKPD
+13 SET ACKPN=$PIECE($GET(^ICPT(ACKPP,0)),U)
if ACKPN=""
QUIT
SET ACKPDSC=$$PROCTXT^ACKQUTL8(ACKPP,ACKTME)
+14 SET ACKPC=$PIECE(^ACK(509850.4,ACKPP,0),U,6)
+15 ; Get the Volume of times the Procedure was administered
+16 SET ACKVOL=$PIECE(ACKPD,U,3)
IF ACKVOL=""
SET ACKVOL=1
+17 SET ACKM=0
+18 if '$DATA(^TMP("ACKQR4",$JOB,0,ACKVDIV,ACKPP,ACKM))
SET ^(ACKM)=ACKPN_U_ACKPDSC_U_ACKPC
+19 SET ^TMP("ACKQR4",$JOB,1,ACKVDIV,ACKCSC,ACKPP,ACKM)=$GET(^TMP("ACKQR4",$JOB,1,ACKVDIV,ACKCSC,ACKPP,ACKM))+ACKVOL
End DoDot:2
End DoDot:1
+20 KILL ACKVDIV
+21 QUIT
PRINT ;
+1 IF '$DATA(^TMP("ACKQR4",$JOB,1))
Begin DoDot:1
+2 DO DHD("")
+3 WRITE !!,"No data found for report specifications."
+4 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
End DoDot:1
QUIT
+5 ; print the report for each division
+6 SET ACKDIV=""
KILL ACKDCNT
SET ACKDCNT=0
+7 FOR
SET ACKDIV=$ORDER(ACKDIV(ACKDIV))
if ACKDIV=""!($DATA(DIRUT))
QUIT
DO PRINT2
if $DATA(DIRUT)
QUIT
+8 IF '$DATA(DIRUT)
IF ACKDCNT>0
DO TOTALS
+9 QUIT
+10 ;
PRINT2 ; print for a single division
+1 IF '$DATA(^TMP("ACKQR4",$JOB,1,ACKDIV))
Begin DoDot:1
+2 DO DHD(1)
+3 WRITE !!,"No data found for report specifications.",!!
+4 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
End DoDot:1
QUIT
+5 DO DHD(1)
+6 ;
+7 SET ACKCSC=""
SET ACKT=0
+8 FOR
SET ACKCSC=$ORDER(^TMP("ACKQR4",$JOB,1,ACKDIV,ACKCSC))
if ACKCSC=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+9 IF $Y>(IOSL-9)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD(1)
+10 SET ACKCSX=$SELECT(ACKCSC="A":"Audiology",ACKCSC="S":"Speech Pathology",ACKCSC="AT":"Audiology Telephone",ACKCSC="ST":"Speech Telephone",1:"")
+11 WRITE !!,"STOP CODE: ",ACKCSX
SET ACKT(ACKCSC)=0
+12 SET ACKPC=0
FOR
SET ACKPC=$ORDER(^TMP("ACKQR4",$JOB,1,ACKDIV,ACKCSC,ACKPC))
if 'ACKPC!($DATA(DIRUT))
QUIT
SET ACKM=""
FOR
SET ACKM=$ORDER(^TMP("ACKQR4",$JOB,1,ACKDIV,ACKCSC,ACKPC,ACKM))
if ACKM=""!($DATA(DIRUT))
QUIT
SET ACKD=^TMP("ACKQR4",$JOB,0,ACKDIV,ACKPC,ACKM)
Begin DoDot:2
+13 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD(1)
+14 SET ACKQQ=^TMP("ACKQR4",$JOB,1,ACKDIV,ACKCSC,ACKPC,ACKM)
SET ACKTC=ACKQQ*$PIECE(ACKD,U,3)
+15 SET ACKT=ACKT+ACKTC
SET ACKT(ACKCSC)=ACKT(ACKCSC)+ACKTC
+16 WRITE !,$JUSTIFY(ACKQQ,4),?6,$PIECE(ACKD,U),?15,$PIECE(ACKD,U,2),$SELECT(ACKM]0:" "_$EXTRACT(ACKM,1,29),1:"")
+17 WRITE ?50,$JUSTIFY("$"_$JUSTIFY($PIECE(ACKD,U,3),0,2),8),?60,$JUSTIFY("$"_$JUSTIFY(ACKTC,0,2),10)
End DoDot:2
+18 WRITE !!,ACKCSX," Total:",?60,$JUSTIFY("$"_$JUSTIFY(ACKT(ACKCSC),0,2),10)
End DoDot:1
+19 if $DATA(DIRUT)
QUIT
+20 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD(1)
+21 WRITE !!,"Grand Total: ",?60,$JUSTIFY("$"_$JUSTIFY(ACKT,0,2),10)
+22 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
+23 SET ACKDCNT=ACKDCNT+ACKT
+24 SET ACKDCNT(ACKDIV)=ACKT
+25 QUIT
DHD(ACKDHD) ;
+1 if ($EXTRACT(IOST)="C")!(ACKPG>0)
WRITE @IOF
+2 SET ACKPG=ACKPG+1
+3 WRITE "Printed: ",ACKXDT,?(IOM-8),"Page: ",ACKPG,!
+4 FOR X="Procedure Cost Comparison","for Date Range",ACKXBD_" to "_ACKXED
WRITE !
DO CNTR^ACKQUTL(X)
+5 IF ACKDHD
WRITE !
DO CNTR^ACKQUTL("For Division: "_$$DIVNAME(ACKDIV))
+6 WRITE !!,"QUAN",?6,"CODE",?15,"DESCRIPTION",?54,"COST",?65,"TOTAL"
+7 SET X=""
SET $PIECE(X,"-",IOM)="-"
WRITE !,X
+8 QUIT
+9 ;
EXIT ;
+1 KILL ACKBD,ACKCSC,ACKCSX,ACKD,ACKED,ACKM,ACKMP,ACKP,ACKPC,ACKPD,ACKPDSC,ACKPG,ACKPN,ACKPP,ACKQQ,ACKT,ACKTC,ACKV,ACKXBD,ACKXDT,ACKXED,X,Y,ZTSK,^TMP("ACKQR4",$JOB)
+2 KILL ACKVOL,ACKHDR5,ACKDIV
+3 if $EXTRACT(IOST)="C"
WRITE @IOF
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
+5 ;
DIVNAME(ACKVDIV) ; get division name
+1 QUIT $$GET1^DIQ(40.8,ACKDIV_",",.01)
+2 ;
+3 ;
TOTALS ; Display Totals
+1 SET ACKPG=ACKPG+1
WRITE @IOF,"Printed: ",ACKXDT,?(IOM-8),"Page: ",ACKPG,!
+2 FOR X="Procedure Cost Comparison","for Date Range",ACKXBD_" to "_ACKXED
WRITE !
DO CNTR^ACKQUTL(X)
+3 WRITE !
DO CNTR^ACKQUTL("Summary")
WRITE !
+4 SET X=""
SET $PIECE(X,"-",IOM)="-"
WRITE !,X,!!
+5 ;
+6 SET ACKDIV=""
+7 FOR
SET ACKDIV=$ORDER(ACKDCNT(ACKDIV))
if ACKDIV=""
QUIT
Begin DoDot:1
+8 WRITE !,?8,"Total for Division: "_$$DIVNAME(ACKDIV),?57,$JUSTIFY("$"_$JUSTIFY(ACKDCNT(ACKDIV),0,2),10)
End DoDot:1
+9 WRITE !!,?8,"Grand Total for all Divisions ",?57,$JUSTIFY("$"_$JUSTIFY(ACKDCNT,0,2),10)
+10 QUIT
