ACKQDWLR ;HCIOFO/BH-Print A&SP Capitation Report ; [ 06/06/99 10:45 AM ]
;;3.0;QUASAR;**1**;Feb 11, 2000
;
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;
;
SUMZIP ; Display summary of ZIP data
Q:'$D(^TMP("ACKQDWLP",$J,"S",3))
;
N ACKF,ACKZSCTA,ACKZSTTA,ACKZSUTA,ACKZSPTA,ACKDD,ACKZC
N ACKSTR,ACKZSCTS,ACKZSTTS,ACKZSUTS,ACKZSPTS,ACKTYPE
S (ACKZSCTA,ACKZSTTA,ACKZSUTA,ACKZSPTA,ACKZSCTS,ACKZSTTS,ACKZSUTS,ACKZSPTS)=0
S AS="",ACKTYPE="ZIP"
; Display Heading and sub heading
D HEADER,ZIPHD
;
F S AS=$O(^TMP("ACKQDWLP",$J,"S",3,AS)) Q:AS=""!($D(DIRUT)) D
.I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ZIPHD
.S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
.W !," "_XAS,":"
.S (ACKZC,ACKSTR)=""
.F S ACKZC=$O(^TMP("ACKQDWLP",$J,"S",3,AS,ACKZC)) Q:ACKZC=""!($D(DIRUT)) D
..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ZIPHD W !," "_XAS,":"
..S ACKF=1,ACKDD=""
..F S ACKDD=$O(^TMP("ACKQDWLP",$J,"S",3,AS,ACKZC,ACKDD)) Q:ACKDD=""!($D(DIRUT)) D
...S ACKSTR=^TMP("ACKQDWLP",$J,"S",3,AS,ACKZC,ACKDD)
...; Print Zip data
...W !
...I ACKF W " "_ACKZC S ACKF=0
...W ?9,$P(ACKDIV(ACKDD),U,3)
...W ?32,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
...W ?45,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
...W ?59,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
...W ?72,$S($P(ACKSTR,U,4):$P(ACKSTR,U,4),1:"0")
...;
...; Calculate Totals
...S @("ACKZSCT"_AS)=@("ACKZSCT"_AS)+$P(ACKSTR,U,1)
...S @("ACKZSTT"_AS)=@("ACKZSTT"_AS)+$P(ACKSTR,U,2)
...S @("ACKZSUT"_AS)=@("ACKZSUT"_AS)+$P(ACKSTR,U,3)
...S @("ACKZSPT"_AS)=@("ACKZSPT"_AS)+$P(ACKSTR,U,4)
..;
..Q:$D(DIRUT)
.Q:$D(DIRUT)
.S $P(LN,"-",80)="" W !,LN
.W !," "_XAS," Total: ",?32,@("ACKZSCT"_AS),?45,@("ACKZSTT"_AS)
.W ?59,@("ACKZSUT"_AS),?72,@("ACKZSPT"_AS),!
;
Q:$D(DIRUT)
; Calculate and Display Grand Total for ZIP
N ACKGT1,ACKGT2,ACKGT3,ACKGT4
S ACKGT1=$G(ACKZSCTS)+$G(ACKZSCTA)
S ACKGT2=$G(ACKZSTTS)+$G(ACKZSTTA)
S ACKGT3=$G(ACKZSUTS)+$G(ACKZSUTA)
S ACKGT4=$G(ACKZSPTS)+$G(ACKZSPTA)
I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ZIPHD W !," "_XAS,":"
W !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,?72,ACKGT4,!
D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
;
Q
;
SUMICD ; Display summary of ICD data
Q:'$D(^TMP("ACKQDWLP",$J,"S",1))
;
N ACKF,ACKISCTA,ACKISTTA,ACKISUTA,ACKDD,ACKIC
N ACKSTR,ACKISCTS,ACKISTTS,ACKISUTS,ACKTYPE
S (ACKISCTA,ACKISTTA,ACKISUTA,ACKISCTS,ACKISTTS,ACKISUTS)=0
S ACKTYPE="ICD"
; Display main heading and sub heading
D HEADER,ICDCPTHD
;
S AS=""
F S AS=$O(^TMP("ACKQDWLP",$J,"S",1,AS)) Q:AS=""!($D(DIRUT)) D
. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD
. S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
. W !," "_XAS,":"
. S (ACKIC,ACKSTR)=""
. F S ACKIC=$O(^TMP("ACKQDWLP",$J,"S",1,AS,ACKIC)) Q:ACKIC=""!($D(DIRUT)) D
.. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W !," "_XAS,":"
.. S ACKF=1,ACKDD=""
.. F S ACKDD=$O(^TMP("ACKQDWLP",$J,"S",1,AS,ACKIC,ACKDD)) Q:ACKDD=""!($D(DIRUT)) D
... S ACKSTR=^TMP("ACKQDWLP",$J,"S",1,AS,ACKIC,ACKDD)
...; Print ICD data
... W !
... I ACKF W " "_ACKIC S ACKF=0
... W ?9,$P(ACKDIV(ACKDD),U,3)
... W ?32,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
... W ?45,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
... W ?59,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
...;
...; Calculate Totals
... S @("ACKISCT"_AS)=@("ACKISCT"_AS)+$P(ACKSTR,U,1)
... S @("ACKISTT"_AS)=@("ACKISTT"_AS)+$P(ACKSTR,U,2)
... S @("ACKISUT"_AS)=@("ACKISUT"_AS)+$P(ACKSTR,U,3)
..;
.. Q:$D(DIRUT)
. Q:$D(DIRUT)
. S $P(LN,"-",80)="" W !,LN
. W !," "_XAS," Total: ",?32,@("ACKISCT"_AS),?45,@("ACKISTT"_AS)
. W ?59,@("ACKISUT"_AS),!
;
Q:$D(DIRUT)
; Calculate and Display Grand Total for ZIP
N ACKGT1,ACKGT2,ACKGT3
S ACKGT1=$G(ACKISCTS)+$G(ACKISCTA)
S ACKGT2=$G(ACKISTTS)+$G(ACKISTTA)
S ACKGT3=$G(ACKISUTS)+$G(ACKISUTA)
;
I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W !," "_XAS,":"
W !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,!
D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
;
Q
;
SUMCPT ; Display summary of CPT data
Q:'$D(^TMP("ACKQDWLP",$J,"S",2))
;
N ACKF,ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKDD,ACKCC
N ACKSTR,ACKCSCTS,ACKCSTTS,ACKCSUTS,ACKTYPE
S (ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKCSCTS,ACKCSTTS,ACKCSUTS)=0
S ACKTYPE="CPT"
; Display main heading and sub heading
D HEADER,ICDCPTHD
;
S AS=""
F S AS=$O(^TMP("ACKQDWLP",$J,"S",2,AS)) Q:AS=""!($D(DIRUT)) D
. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD
. S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
. W !," "_XAS,":"
. S (ACKCC,ACKSTR)=""
.;
. F S ACKCC=$O(^TMP("ACKQDWLP",$J,"S",2,AS,ACKCC)) Q:ACKCC=""!($D(DIRUT)) D
.. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W " "_XAS,":"
.. S ACKF=1,ACKDD=""
.. F S ACKDD=$O(^TMP("ACKQDWLP",$J,"S",2,AS,ACKCC,ACKDD)) Q:ACKDD=""!($D(DIRUT)) D
... S ACKSTR=^TMP("ACKQDWLP",$J,"S",2,AS,ACKCC,ACKDD)
...; Print Zip data
... W !
... I ACKF W " "_$$GET1^DIQ(509850.4,ACKCC_",",.01) S ACKF=0
... W ?9,$P(ACKDIV(ACKDD),U,3)
... W ?32,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
... W ?45,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
... W ?59,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
...;
...; Calculate Totals
... S @("ACKCSCT"_AS)=@("ACKCSCT"_AS)+$P(ACKSTR,U,1)
... S @("ACKCSTT"_AS)=@("ACKCSTT"_AS)+$P(ACKSTR,U,2)
... S @("ACKCSUT"_AS)=@("ACKCSUT"_AS)+$P(ACKSTR,U,3)
..;
.. Q:$D(DIRUT)
. Q:$D(DIRUT)
. S $P(LN,"-",80)="" W !,LN
. W !," "_XAS," Total: ",?32,@("ACKCSCT"_AS),?45,@("ACKCSTT"_AS)
. W ?59,@("ACKCSUT"_AS),!
;
Q:$D(DIRUT)
; Calculate and Display Grand Total for CPT
N ACKGT1,ACKGT2,ACKGT3
S ACKGT1=$G(ACKCSCTS)+$G(ACKCSCTA)
S ACKGT2=$G(ACKCSTTS)+$G(ACKCSTTA)
S ACKGT3=$G(ACKCSUTS)+$G(ACKCSUTA)
;
I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W !," "_XAS,":"
W !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,!
D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
;
Q
;
SUMEC ; Display summary of EC data
Q:'$D(^TMP("ACKQDWLP",$J,"S",5))
;
N ACKF,ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKDD,ACKCC
N ACKSTR,ACKCSCTS,ACKCSTTS,ACKCSUTS,ACKTYPE
S (ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKCSCTS,ACKCSTTS,ACKCSUTS)=0
S ACKTYPE="EC"
; Display main heading and sub heading
D HEADER,ICDCPTHD
S AS=""
F S AS=$O(^TMP("ACKQDWLP",$J,"S",5,AS)) Q:AS=""!($D(DIRUT)) D
. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD
. S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
. W !," "_XAS,":"
. S (ACKCC,ACKSTR)=""
.;
. F S ACKCC=$O(^TMP("ACKQDWLP",$J,"S",5,AS,ACKCC)) Q:ACKCC=""!($D(DIRUT)) D
.. I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W " "_XAS,":"
.. S ACKF=1,ACKDD=""
.. F S ACKDD=$O(^TMP("ACKQDWLP",$J,"S",5,AS,ACKCC,ACKDD)) Q:ACKDD=""!($D(DIRUT)) D
... S ACKSTR=^TMP("ACKQDWLP",$J,"S",5,AS,ACKCC,ACKDD)
...; Print EC data
... W !
... I ACKF W " "_$$GET1^DIQ(725,ACKCC_",",1,"I") S ACKF=0
... W ?9,$P(ACKDIV(ACKDD),U,3)
... W ?32,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
... W ?45,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
... W ?59,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
...;
...; Calculate Totals
... S @("ACKCSCT"_AS)=@("ACKCSCT"_AS)+$P(ACKSTR,U,1)
... S @("ACKCSTT"_AS)=@("ACKCSTT"_AS)+$P(ACKSTR,U,2)
... S @("ACKCSUT"_AS)=@("ACKCSUT"_AS)+$P(ACKSTR,U,3)
..;
.. Q:$D(DIRUT)
. Q:$D(DIRUT)
. S $P(LN,"-",80)="" W !,LN
. W !," "_XAS," Total: ",?32,@("ACKCSCT"_AS),?45,@("ACKCSTT"_AS)
. W ?59,@("ACKCSUT"_AS),!
;
Q:$D(DIRUT)
; Calculate and Display Grand Total for EC
N ACKGT1,ACKGT2,ACKGT3
S ACKGT1=$G(ACKCSCTS)+$G(ACKCSCTA)
S ACKGT2=$G(ACKCSTTS)+$G(ACKCSTTA)
S ACKGT3=$G(ACKCSUTS)+$G(ACKCSUTA)
;
I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D HEADER,ICDCPTHD W !," "_XAS,":"
W !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,!
;
; D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
Q
;
N X
S ACKPG=ACKPG+1 W @IOF,"Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG
F X="Audiology & Speech Pathology","Capitation Report Summary Report by "_ACKTYPE_" Code",$$XDAT^ACKQUTL(ACKM) W ! D CNTR^ACKQUTL(X)
W !
Q
;
ZIPHD ; Display sub heading for ZIP code
N X
W !," "_ACKTYPE,?9,"DIVISION",?30,"CLINIC",?43,"TELEPHONE",?58,"UNIQUE"
W !," EXAMS",?30,"VISITS",?44,"VISITS",?57,"PATIENTS",?71,"C&P"
D LINE
Q
;
ICDCPTHD ; Display sub heading for ICD/CPT code
N X
W !," "_ACKTYPE,?9,"DIVISION",?30,"CLINIC",?43,"TELEPHONE",?58,"UNIQUE"
W !," EXAMS",?30,"VISITS",?44,"VISITS",?57,"PATIENTS"
D LINE
Q
;
;
LINE ; Write line if dashes
S X="",$P(X,"-",IOM)="-" W !,X
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQDWLR 8920 printed Apr 09, 2024@21:35:09 Page 2
ACKQDWLR ;HCIOFO/BH-Print A&SP Capitation Report ; [ 06/06/99 10:45 AM ]
+1 ;;3.0;QUASAR;**1**;Feb 11, 2000
+2 ;
+3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+4 ;
+5 ;
SUMZIP ; Display summary of ZIP data
+1 if '$DATA(^TMP("ACKQDWLP",$JOB,"S",3))
QUIT
+2 ;
+3 NEW ACKF,ACKZSCTA,ACKZSTTA,ACKZSUTA,ACKZSPTA,ACKDD,ACKZC
+4 NEW ACKSTR,ACKZSCTS,ACKZSTTS,ACKZSUTS,ACKZSPTS,ACKTYPE
+5 SET (ACKZSCTA,ACKZSTTA,ACKZSUTA,ACKZSPTA,ACKZSCTS,ACKZSTTS,ACKZSUTS,ACKZSPTS)=0
+6 SET AS=""
SET ACKTYPE="ZIP"
+7 ; Display Heading and sub heading
+8 DO HEADER
DO ZIPHD
+9 ;
+10 FOR
SET AS=$ORDER(^TMP("ACKQDWLP",$JOB,"S",3,AS))
if AS=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+11 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ZIPHD
+12 SET XAS=$SELECT(AS="A":"Audiology",1:"Speech Pathology")
+13 WRITE !," "_XAS,":"
+14 SET (ACKZC,ACKSTR)=""
+15 FOR
SET ACKZC=$ORDER(^TMP("ACKQDWLP",$JOB,"S",3,AS,ACKZC))
if ACKZC=""!($DATA(DIRUT))
QUIT
Begin DoDot:2
+16 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ZIPHD
WRITE !," "_XAS,":"
+17 SET ACKF=1
SET ACKDD=""
+18 FOR
SET ACKDD=$ORDER(^TMP("ACKQDWLP",$JOB,"S",3,AS,ACKZC,ACKDD))
if ACKDD=""!($DATA(DIRUT))
QUIT
Begin DoDot:3
+19 SET ACKSTR=^TMP("ACKQDWLP",$JOB,"S",3,AS,ACKZC,ACKDD)
+20 ; Print Zip data
+21 WRITE !
+22 IF ACKF
WRITE " "_ACKZC
SET ACKF=0
+23 WRITE ?9,$PIECE(ACKDIV(ACKDD),U,3)
+24 WRITE ?32,$SELECT($PIECE(ACKSTR,U,1):$PIECE(ACKSTR,U,1),1:"0")
+25 WRITE ?45,$SELECT($PIECE(ACKSTR,U,2):$PIECE(ACKSTR,U,2),1:"0")
+26 WRITE ?59,$SELECT($PIECE(ACKSTR,U,3):$PIECE(ACKSTR,U,3),1:"0")
+27 WRITE ?72,$SELECT($PIECE(ACKSTR,U,4):$PIECE(ACKSTR,U,4),1:"0")
+28 ;
+29 ; Calculate Totals
+30 SET @("ACKZSCT"_AS)=@("ACKZSCT"_AS)+$PIECE(ACKSTR,U,1)
+31 SET @("ACKZSTT"_AS)=@("ACKZSTT"_AS)+$PIECE(ACKSTR,U,2)
+32 SET @("ACKZSUT"_AS)=@("ACKZSUT"_AS)+$PIECE(ACKSTR,U,3)
+33 SET @("ACKZSPT"_AS)=@("ACKZSPT"_AS)+$PIECE(ACKSTR,U,4)
End DoDot:3
+34 ;
+35 if $DATA(DIRUT)
QUIT
End DoDot:2
+36 if $DATA(DIRUT)
QUIT
+37 SET $PIECE(LN,"-",80)=""
WRITE !,LN
+38 WRITE !," "_XAS," Total: ",?32,@("ACKZSCT"_AS),?45,@("ACKZSTT"_AS)
+39 WRITE ?59,@("ACKZSUT"_AS),?72,@("ACKZSPT"_AS),!
End DoDot:1
+40 ;
+41 if $DATA(DIRUT)
QUIT
+42 ; Calculate and Display Grand Total for ZIP
+43 NEW ACKGT1,ACKGT2,ACKGT3,ACKGT4
+44 SET ACKGT1=$GET(ACKZSCTS)+$GET(ACKZSCTA)
+45 SET ACKGT2=$GET(ACKZSTTS)+$GET(ACKZSTTA)
+46 SET ACKGT3=$GET(ACKZSUTS)+$GET(ACKZSUTA)
+47 SET ACKGT4=$GET(ACKZSPTS)+$GET(ACKZSPTA)
+48 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ZIPHD
WRITE !," "_XAS,":"
+49 WRITE !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,?72,ACKGT4,!
+50 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
+51 ;
+52 QUIT
+53 ;
SUMICD ; Display summary of ICD data
+1 if '$DATA(^TMP("ACKQDWLP",$JOB,"S",1))
QUIT
+2 ;
+3 NEW ACKF,ACKISCTA,ACKISTTA,ACKISUTA,ACKDD,ACKIC
+4 NEW ACKSTR,ACKISCTS,ACKISTTS,ACKISUTS,ACKTYPE
+5 SET (ACKISCTA,ACKISTTA,ACKISUTA,ACKISCTS,ACKISTTS,ACKISUTS)=0
+6 SET ACKTYPE="ICD"
+7 ; Display main heading and sub heading
+8 DO HEADER
DO ICDCPTHD
+9 ;
+10 SET AS=""
+11 FOR
SET AS=$ORDER(^TMP("ACKQDWLP",$JOB,"S",1,AS))
if AS=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+12 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ICDCPTHD
+13 SET XAS=$SELECT(AS="A":"Audiology",1:"Speech Pathology")
+14 WRITE !," "_XAS,":"
+15 SET (ACKIC,ACKSTR)=""
+16 FOR
SET ACKIC=$ORDER(^TMP("ACKQDWLP",$JOB,"S",1,AS,ACKIC))
if ACKIC=""!($DATA(DIRUT))
QUIT
Begin DoDot:2
+17 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ICDCPTHD
WRITE !," "_XAS,":"
+18 SET ACKF=1
SET ACKDD=""
+19 FOR
SET ACKDD=$ORDER(^TMP("ACKQDWLP",$JOB,"S",1,AS,ACKIC,ACKDD))
if ACKDD=""!($DATA(DIRUT))
QUIT
Begin DoDot:3
+20 SET ACKSTR=^TMP("ACKQDWLP",$JOB,"S",1,AS,ACKIC,ACKDD)
+21 ; Print ICD data
+22 WRITE !
+23 IF ACKF
WRITE " "_ACKIC
SET ACKF=0
+24 WRITE ?9,$PIECE(ACKDIV(ACKDD),U,3)
+25 WRITE ?32,$SELECT($PIECE(ACKSTR,U,1):$PIECE(ACKSTR,U,1),1:"0")
+26 WRITE ?45,$SELECT($PIECE(ACKSTR,U,2):$PIECE(ACKSTR,U,2),1:"0")
+27 WRITE ?59,$SELECT($PIECE(ACKSTR,U,3):$PIECE(ACKSTR,U,3),1:"0")
+28 ;
+29 ; Calculate Totals
+30 SET @("ACKISCT"_AS)=@("ACKISCT"_AS)+$PIECE(ACKSTR,U,1)
+31 SET @("ACKISTT"_AS)=@("ACKISTT"_AS)+$PIECE(ACKSTR,U,2)
+32 SET @("ACKISUT"_AS)=@("ACKISUT"_AS)+$PIECE(ACKSTR,U,3)
End DoDot:3
+33 ;
+34 if $DATA(DIRUT)
QUIT
End DoDot:2
+35 if $DATA(DIRUT)
QUIT
+36 SET $PIECE(LN,"-",80)=""
WRITE !,LN
+37 WRITE !," "_XAS," Total: ",?32,@("ACKISCT"_AS),?45,@("ACKISTT"_AS)
+38 WRITE ?59,@("ACKISUT"_AS),!
End DoDot:1
+39 ;
+40 if $DATA(DIRUT)
QUIT
+41 ; Calculate and Display Grand Total for ZIP
+42 NEW ACKGT1,ACKGT2,ACKGT3
+43 SET ACKGT1=$GET(ACKISCTS)+$GET(ACKISCTA)
+44 SET ACKGT2=$GET(ACKISTTS)+$GET(ACKISTTA)
+45 SET ACKGT3=$GET(ACKISUTS)+$GET(ACKISUTA)
+46 ;
+47 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ICDCPTHD
WRITE !," "_XAS,":"
+48 WRITE !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,!
+49 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
+50 ;
+51 QUIT
+52 ;
SUMCPT ; Display summary of CPT data
+1 if '$DATA(^TMP("ACKQDWLP",$JOB,"S",2))
QUIT
+2 ;
+3 NEW ACKF,ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKDD,ACKCC
+4 NEW ACKSTR,ACKCSCTS,ACKCSTTS,ACKCSUTS,ACKTYPE
+5 SET (ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKCSCTS,ACKCSTTS,ACKCSUTS)=0
+6 SET ACKTYPE="CPT"
+7 ; Display main heading and sub heading
+8 DO HEADER
DO ICDCPTHD
+9 ;
+10 SET AS=""
+11 FOR
SET AS=$ORDER(^TMP("ACKQDWLP",$JOB,"S",2,AS))
if AS=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+12 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ICDCPTHD
+13 SET XAS=$SELECT(AS="A":"Audiology",1:"Speech Pathology")
+14 WRITE !," "_XAS,":"
+15 SET (ACKCC,ACKSTR)=""
+16 ;
+17 FOR
SET ACKCC=$ORDER(^TMP("ACKQDWLP",$JOB,"S",2,AS,ACKCC))
if ACKCC=""!($DATA(DIRUT))
QUIT
Begin DoDot:2
+18 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ICDCPTHD
WRITE " "_XAS,":"
+19 SET ACKF=1
SET ACKDD=""
+20 FOR
SET ACKDD=$ORDER(^TMP("ACKQDWLP",$JOB,"S",2,AS,ACKCC,ACKDD))
if ACKDD=""!($DATA(DIRUT))
QUIT
Begin DoDot:3
+21 SET ACKSTR=^TMP("ACKQDWLP",$JOB,"S",2,AS,ACKCC,ACKDD)
+22 ; Print Zip data
+23 WRITE !
+24 IF ACKF
WRITE " "_$$GET1^DIQ(509850.4,ACKCC_",",.01)
SET ACKF=0
+25 WRITE ?9,$PIECE(ACKDIV(ACKDD),U,3)
+26 WRITE ?32,$SELECT($PIECE(ACKSTR,U,1):$PIECE(ACKSTR,U,1),1:"0")
+27 WRITE ?45,$SELECT($PIECE(ACKSTR,U,2):$PIECE(ACKSTR,U,2),1:"0")
+28 WRITE ?59,$SELECT($PIECE(ACKSTR,U,3):$PIECE(ACKSTR,U,3),1:"0")
+29 ;
+30 ; Calculate Totals
+31 SET @("ACKCSCT"_AS)=@("ACKCSCT"_AS)+$PIECE(ACKSTR,U,1)
+32 SET @("ACKCSTT"_AS)=@("ACKCSTT"_AS)+$PIECE(ACKSTR,U,2)
+33 SET @("ACKCSUT"_AS)=@("ACKCSUT"_AS)+$PIECE(ACKSTR,U,3)
End DoDot:3
+34 ;
+35 if $DATA(DIRUT)
QUIT
End DoDot:2
+36 if $DATA(DIRUT)
QUIT
+37 SET $PIECE(LN,"-",80)=""
WRITE !,LN
+38 WRITE !," "_XAS," Total: ",?32,@("ACKCSCT"_AS),?45,@("ACKCSTT"_AS)
+39 WRITE ?59,@("ACKCSUT"_AS),!
End DoDot:1
+40 ;
+41 if $DATA(DIRUT)
QUIT
+42 ; Calculate and Display Grand Total for CPT
+43 NEW ACKGT1,ACKGT2,ACKGT3
+44 SET ACKGT1=$GET(ACKCSCTS)+$GET(ACKCSCTA)
+45 SET ACKGT2=$GET(ACKCSTTS)+$GET(ACKCSTTA)
+46 SET ACKGT3=$GET(ACKCSUTS)+$GET(ACKCSUTA)
+47 ;
+48 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ICDCPTHD
WRITE !," "_XAS,":"
+49 WRITE !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,!
+50 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
+51 ;
+52 QUIT
+53 ;
SUMEC ; Display summary of EC data
+1 if '$DATA(^TMP("ACKQDWLP",$JOB,"S",5))
QUIT
+2 ;
+3 NEW ACKF,ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKDD,ACKCC
+4 NEW ACKSTR,ACKCSCTS,ACKCSTTS,ACKCSUTS,ACKTYPE
+5 SET (ACKCSCTA,ACKCSTTA,ACKCSUTA,ACKCSCTS,ACKCSTTS,ACKCSUTS)=0
+6 SET ACKTYPE="EC"
+7 ; Display main heading and sub heading
+8 DO HEADER
DO ICDCPTHD
+9 SET AS=""
+10 FOR
SET AS=$ORDER(^TMP("ACKQDWLP",$JOB,"S",5,AS))
if AS=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+11 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ICDCPTHD
+12 SET XAS=$SELECT(AS="A":"Audiology",1:"Speech Pathology")
+13 WRITE !," "_XAS,":"
+14 SET (ACKCC,ACKSTR)=""
+15 ;
+16 FOR
SET ACKCC=$ORDER(^TMP("ACKQDWLP",$JOB,"S",5,AS,ACKCC))
if ACKCC=""!($DATA(DIRUT))
QUIT
Begin DoDot:2
+17 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ICDCPTHD
WRITE " "_XAS,":"
+18 SET ACKF=1
SET ACKDD=""
+19 FOR
SET ACKDD=$ORDER(^TMP("ACKQDWLP",$JOB,"S",5,AS,ACKCC,ACKDD))
if ACKDD=""!($DATA(DIRUT))
QUIT
Begin DoDot:3
+20 SET ACKSTR=^TMP("ACKQDWLP",$JOB,"S",5,AS,ACKCC,ACKDD)
+21 ; Print EC data
+22 WRITE !
+23 IF ACKF
WRITE " "_$$GET1^DIQ(725,ACKCC_",",1,"I")
SET ACKF=0
+24 WRITE ?9,$PIECE(ACKDIV(ACKDD),U,3)
+25 WRITE ?32,$SELECT($PIECE(ACKSTR,U,1):$PIECE(ACKSTR,U,1),1:"0")
+26 WRITE ?45,$SELECT($PIECE(ACKSTR,U,2):$PIECE(ACKSTR,U,2),1:"0")
+27 WRITE ?59,$SELECT($PIECE(ACKSTR,U,3):$PIECE(ACKSTR,U,3),1:"0")
+28 ;
+29 ; Calculate Totals
+30 SET @("ACKCSCT"_AS)=@("ACKCSCT"_AS)+$PIECE(ACKSTR,U,1)
+31 SET @("ACKCSTT"_AS)=@("ACKCSTT"_AS)+$PIECE(ACKSTR,U,2)
+32 SET @("ACKCSUT"_AS)=@("ACKCSUT"_AS)+$PIECE(ACKSTR,U,3)
End DoDot:3
+33 ;
+34 if $DATA(DIRUT)
QUIT
End DoDot:2
+35 if $DATA(DIRUT)
QUIT
+36 SET $PIECE(LN,"-",80)=""
WRITE !,LN
+37 WRITE !," "_XAS," Total: ",?32,@("ACKCSCT"_AS),?45,@("ACKCSTT"_AS)
+38 WRITE ?59,@("ACKCSUT"_AS),!
End DoDot:1
+39 ;
+40 if $DATA(DIRUT)
QUIT
+41 ; Calculate and Display Grand Total for EC
+42 NEW ACKGT1,ACKGT2,ACKGT3
+43 SET ACKGT1=$GET(ACKCSCTS)+$GET(ACKCSCTA)
+44 SET ACKGT2=$GET(ACKCSTTS)+$GET(ACKCSTTA)
+45 SET ACKGT3=$GET(ACKCSUTS)+$GET(ACKCSUTA)
+46 ;
+47 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO HEADER
DO ICDCPTHD
WRITE !," "_XAS,":"
+48 WRITE !," Grand Total",?32,ACKGT1,?45,ACKGT2,?59,ACKGT3,!
+49 ;
+50 ; D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
+51 QUIT
+52 ;
+1 NEW X
+2 SET ACKPG=ACKPG+1
WRITE @IOF,"Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG
+3 FOR X="Audiology & Speech Pathology","Capitation Report Summary Report by "_ACKTYPE_" Code",$$XDAT^ACKQUTL(ACKM)
WRITE !
DO CNTR^ACKQUTL(X)
+4 WRITE !
+5 QUIT
+6 ;
ZIPHD ; Display sub heading for ZIP code
+1 NEW X
+2 WRITE !," "_ACKTYPE,?9,"DIVISION",?30,"CLINIC",?43,"TELEPHONE",?58,"UNIQUE"
+3 WRITE !," EXAMS",?30,"VISITS",?44,"VISITS",?57,"PATIENTS",?71,"C&P"
+4 DO LINE
+5 QUIT
+6 ;
ICDCPTHD ; Display sub heading for ICD/CPT code
+1 NEW X
+2 WRITE !," "_ACKTYPE,?9,"DIVISION",?30,"CLINIC",?43,"TELEPHONE",?58,"UNIQUE"
+3 WRITE !," EXAMS",?30,"VISITS",?44,"VISITS",?57,"PATIENTS"
+4 DO LINE
+5 QUIT
+6 ;
+7 ;
LINE ; Write line if dashes
+1 SET X=""
SET $PIECE(X,"-",IOM)="-"
WRITE !,X
+2 QUIT
+3 ;
