Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACKQR4

ACKQR4.m

Go to the documentation of this file.
  1. ACKQR4 ;AUG/JLTP BIR/PTD-Procedure Cost Statistics ; [ 12/07/95 9:52 AM ]
  1. ;;3.0;QUASAR;**8**;Feb 11, 2000
  1. ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
  1. OPTN ; Introduce option.
  1. W @IOF,!,"This option produces a report of all CPT-4 codes used within a selected date",!,"range and their associated costs.",!
  1. ;
  1. ; get Division
  1. S ACKDIV=$$DIV^ACKQUTL2(3,.ACKDIV,"AI") G:+ACKDIV=0 EXIT
  1. ;
  1. ; get date range
  1. D DTRANGE^ACKQRU G:$D(DIRUT) EXIT
  1. ;
  1. DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
  1. K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
  1. 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
  1. DQ ; Entry point when queued.
  1. U IO
  1. D SORT,PRINT G EXIT
  1. SORT ;
  1. N ACKTME
  1. K ^TMP("ACKQR4",$J) S ACKPG=0
  1. D NOW^%DTC
  1. S ACKXDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKTME=$P(%,".",1)
  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
  1. .S ACKHDR5=^ACK(509850.6,ACKV,5)
  1. .; get division and make sure it was selected
  1. .S ACKVDIV=$P(ACKHDR5,U,1) I '$D(ACKDIV(ACKVDIV)) Q
  1. .S ACKCSC=$P($G(^ACK(509850.6,ACKV,2)),U) Q:ACKCSC=""
  1. .I ACKCSC'="A",ACKCSC'="AT",ACKCSC'="S",ACKCSC'="ST" Q
  1. .S ACKP=0 F S ACKP=$O(^ACK(509850.6,ACKV,3,ACKP)) Q:'ACKP D
  1. ..S ACKPD=^ACK(509850.6,ACKV,3,ACKP,0),ACKPP=+ACKPD
  1. ..S ACKPN=$P($G(^ICPT(ACKPP,0)),U) Q:ACKPN="" S ACKPDSC=$$PROCTXT^ACKQUTL8(ACKPP,ACKTME)
  1. ..S ACKPC=$P(^ACK(509850.4,ACKPP,0),U,6)
  1. ..; Get the Volume of times the Procedure was administered
  1. ..S ACKVOL=$P(ACKPD,U,3) I ACKVOL="" S ACKVOL=1
  1. ..S ACKM=0
  1. ..S:'$D(^TMP("ACKQR4",$J,0,ACKVDIV,ACKPP,ACKM)) ^(ACKM)=ACKPN_U_ACKPDSC_U_ACKPC
  1. ..S ^TMP("ACKQR4",$J,1,ACKVDIV,ACKCSC,ACKPP,ACKM)=$G(^TMP("ACKQR4",$J,1,ACKVDIV,ACKCSC,ACKPP,ACKM))+ACKVOL
  1. K ACKVDIV
  1. Q
  1. PRINT ;
  1. I '$D(^TMP("ACKQR4",$J,1)) D Q
  1. . D DHD("")
  1. . W !!,"No data found for report specifications."
  1. . D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
  1. ; print the report for each division
  1. S ACKDIV="" K ACKDCNT S ACKDCNT=0
  1. F S ACKDIV=$O(ACKDIV(ACKDIV)) Q:ACKDIV=""!($D(DIRUT)) D PRINT2 Q:$D(DIRUT)
  1. I '$D(DIRUT) I ACKDCNT>0 D TOTALS
  1. Q
  1. ;
  1. PRINT2 ; print for a single division
  1. I '$D(^TMP("ACKQR4",$J,1,ACKDIV)) D Q
  1. . D DHD(1)
  1. . W !!,"No data found for report specifications.",!!
  1. . D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
  1. D DHD(1)
  1. ;
  1. S ACKCSC="",ACKT=0
  1. F S ACKCSC=$O(^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC)) Q:ACKCSC=""!($D(DIRUT)) D
  1. .I $Y>(IOSL-9) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD(1)
  1. .S ACKCSX=$S(ACKCSC="A":"Audiology",ACKCSC="S":"Speech Pathology",ACKCSC="AT":"Audiology Telephone",ACKCSC="ST":"Speech Telephone",1:"")
  1. .W !!,"STOP CODE: ",ACKCSX S ACKT(ACKCSC)=0
  1. .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
  1. ..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD(1)
  1. ..S ACKQQ=^TMP("ACKQR4",$J,1,ACKDIV,ACKCSC,ACKPC,ACKM),ACKTC=ACKQQ*$P(ACKD,U,3)
  1. ..S ACKT=ACKT+ACKTC,ACKT(ACKCSC)=ACKT(ACKCSC)+ACKTC
  1. ..W !,$J(ACKQQ,4),?6,$P(ACKD,U),?15,$P(ACKD,U,2),$S(ACKM]0:" "_$E(ACKM,1,29),1:"")
  1. ..W ?50,$J("$"_$J($P(ACKD,U,3),0,2),8),?60,$J("$"_$J(ACKTC,0,2),10)
  1. .W !!,ACKCSX," Total:",?60,$J("$"_$J(ACKT(ACKCSC),0,2),10)
  1. Q:$D(DIRUT)
  1. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD(1)
  1. W !!,"Grand Total: ",?60,$J("$"_$J(ACKT,0,2),10)
  1. D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
  1. S ACKDCNT=ACKDCNT+ACKT
  1. S ACKDCNT(ACKDIV)=ACKT
  1. Q
  1. DHD(ACKDHD) ;
  1. W:($E(IOST)="C")!(ACKPG>0) @IOF
  1. S ACKPG=ACKPG+1
  1. W "Printed: ",ACKXDT,?(IOM-8),"Page: ",ACKPG,!
  1. F X="Procedure Cost Comparison","for Date Range",ACKXBD_" to "_ACKXED W ! D CNTR^ACKQUTL(X)
  1. I ACKDHD W ! D CNTR^ACKQUTL("For Division: "_$$DIVNAME(ACKDIV))
  1. W !!,"QUAN",?6,"CODE",?15,"DESCRIPTION",?54,"COST",?65,"TOTAL"
  1. S X="",$P(X,"-",IOM)="-" W !,X
  1. Q
  1. ;
  1. EXIT ;
  1. 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)
  1. K ACKVOL,ACKHDR5,ACKDIV
  1. W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1. Q
  1. ;
  1. DIVNAME(ACKVDIV) ; get division name
  1. Q $$GET1^DIQ(40.8,ACKDIV_",",.01)
  1. ;
  1. ;
  1. TOTALS ; Display Totals
  1. S ACKPG=ACKPG+1 W @IOF,"Printed: ",ACKXDT,?(IOM-8),"Page: ",ACKPG,!
  1. F X="Procedure Cost Comparison","for Date Range",ACKXBD_" to "_ACKXED W ! D CNTR^ACKQUTL(X)
  1. W ! D CNTR^ACKQUTL("Summary") W !
  1. S X="",$P(X,"-",IOM)="-" W !,X,!!
  1. ;
  1. S ACKDIV=""
  1. F S ACKDIV=$O(ACKDCNT(ACKDIV)) Q:ACKDIV="" D
  1. . W !,?8,"Total for Division: "_$$DIVNAME(ACKDIV),?57,$J("$"_$J(ACKDCNT(ACKDIV),0,2),10)
  1. W !!,?8,"Grand Total for all Divisions ",?57,$J("$"_$J(ACKDCNT,0,2),10)
  1. Q