- 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 Feb 18, 2025@23:59:02 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