ACKQDWLP ;AUG/JLTP BIR/PTD HCIOFO/BH - Print A&SP Capitation Report ;19 Nov 2013 9:53 AM
;;3.0;QUASAR;**1,22,21**;Feb 11, 2000;Build 40
;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
;
; Developed within V.3, works at Div level rather than site level -
; - pre v.3
;
;
; Reference/ICR
; $$CODEC^ICDEX - 5747
;
;
K ^TMP("ACKQDWLP",$J)
OPTN ; Introduce option
W @IOF,!,"This option produces a four-part Capitation Report.",!,"It includes Demographic, Diagnostic and Procedure data.",!
;
DIV ; select Div (user may select one/many/ALL)
S ACKDIV=$$DIV^ACKQUTL2(3,.ACKDIV,"IA") G:'ACKDIV EXIT
D GETDT^ACKQWL G:$D(DIRUT) EXIT D INIT^ACKQWL
;
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^ACKQDWLP",ZTDESC="QUASAR - Print A&SP Capitation Report",ZTSAVE("ACK*")="" D ^%ZTLOAD D HOME^%ZIS K ZTSK G EXIT
DQ ; Entry point when queued.
U IO
D NOW^%DTC S ACKCDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0 K ^TMP("ACKQWLD",$J)
D COMPILE,PRINT
;
EXIT ; ALWAYS EXIT HERE
K %I,ACKBFY,ACKCDT,ACKDA,ACKEM,ACKM,ACKPG,AS,CDR,CPT,DIR,DIRUT,DTOUT
K ACKDIV,DUOUT,I,ICD,LN,T,X,XAS,Y,ZIP,^TMP("ACKQDWLP",$J)
W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
COMPILE ; Comp properly sorted data in ^TMP
N ACK1,ACKVDVN,ACK6,ACKREC,ACKAUD,ACKSPE
;
S ACK1=""
F S ACK1=$O(ACKDIV(ACK1)) Q:ACK1="" D
. S ACKVDVN=$P(ACKDIV(ACK1),U,1)
. D ZIPSTAT,ICDSTAT,CPTSTAT,ECSTAT^ACKQDWLU
Q
;
ZIPSTAT ; ZIP stats
N ACKCODE
S ACK6=0
F S ACK6=$O(^ACK(509850.7,ACKDA,5,ACKVDVN,3,ACK6)) Q:ACK6=""!(ACK6'?.N) D
. S ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,3,ACK6,0)
. S ACKAUD=$P(ACKREC,U,2,5),ACKSPE=$P(ACKREC,U,6,9)
. S ACKCODE=$P(ACKREC,U,1)
. I $TR(ACKAUD,"^","")'="" D
. . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,3,"A",ACKCODE)=ACKAUD
. . S ^TMP("ACKQDWLP",$J,"S",3,"A",ACKCODE,ACKVDVN)=ACKAUD
. I $TR(ACKSPE,"^","")'="" D
. . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,3,"S",ACKCODE)=ACKSPE
. . S ^TMP("ACKQDWLP",$J,"S",3,"S",ACKCODE,ACKVDVN)=ACKSPE
Q
;
ICDSTAT ; ICD stats
N ACKCODE
S ACK6=0
F S ACK6=$O(^ACK(509850.7,ACKDA,5,ACKVDVN,1,ACK6)) Q:ACK6=""!(ACK6'?.N) D
. S ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,1,ACK6,0)
. S ACKAUD=$P(ACKREC,U,2,4),ACKSPE=$P(ACKREC,U,5,7)
. S ACKCODE=$P(ACKREC,U,1)
. ;ACKQ*3.0*22 updated api
. S ACKCODE=$$CODEC^ICDEX(80,ACKCODE)
. S ACKCODE=($S(ACKCODE?.NP:+ACKCODE,1:ACKCODE))
. I $TR(ACKAUD,"^","")'="" D
. . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,1,"A",ACKCODE)=ACKAUD
. . S ^TMP("ACKQDWLP",$J,"S",1,"A",ACKCODE,ACKVDVN)=ACKAUD
. I $TR(ACKSPE,"^","")'="" D
. . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,1,"S",ACKCODE)=ACKSPE
. . S ^TMP("ACKQDWLP",$J,"S",1,"S",ACKCODE,ACKVDVN)=ACKSPE
Q
;
CPTSTAT ; CPT Stats
N ACKCODE
S ACK6=0
F S ACK6=$O(^ACK(509850.7,ACKDA,5,ACKVDVN,2,ACK6)) Q:ACK6=""!(ACK6'?.N) D
. S ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,2,ACK6,0)
. S ACKAUD=$P(ACKREC,U,2,4),ACKSPE=$P(ACKREC,U,5,7)
. S ACKCODE=$P(ACKREC,U,1)
. I $TR(ACKAUD,"^","")'="" D
. . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,2,"A",ACKCODE)=ACKAUD
. . S ^TMP("ACKQDWLP",$J,"S",2,"A",ACKCODE,ACKVDVN)=ACKAUD
. I $TR(ACKSPE,"^","")'="" D
. . S ^TMP("ACKQDWLP",$J,"R",ACKVDVN,2,"S",ACKCODE)=ACKSPE
. . S ^TMP("ACKQDWLP",$J,"S",2,"S",ACKCODE,ACKVDVN)=ACKSPE
Q
;
PRINT ; Display results
N ACKDNME,ACKK1,ACKDIEN
;
S ACKDNME=""
N ACKK1,ACKDIEN,ACKPASS
S ACKPASS=0,ACKK1=""
F S ACKK1=$O(ACKDIV(ACKK1)) Q:ACKK1="" D
. S ACKDIEN=$P(ACKDIV(ACKK1),U,1)
. I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN)) S ACKPASS=1
I 'ACKPASS D DHD,LINE W !!,"No Capitation data found for selected Divisions." D:$E(IOST)="C" PAUSE^ACKQUTL Q
;
S ACKK1=""
F S ACKK1=$O(ACKDIV(ACKK1)) Q:ACKK1=""!($D(DIRUT)) D
. S ACKDIEN=$P(ACKDIV(ACKK1),U,1)
. S ACKDNME=$P(ACKDIV(ACKK1),U,3)
. ;
. I '$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,0)) D Q
.. D DHD,LINE
.. W !!,"No data found for this Division."
.. D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
. ;
. I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN,3)) D DHD,HD1,ZIP Q:$D(DIRUT)
. I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN,1)) D DHD,HD2,ICD Q:$D(DIRUT)
. I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN,2)) D DHD,HD3,CPT Q:$D(DIRUT)
. I $D(^TMP("ACKQDWLP",$J,"R",ACKDIEN,5)) D DHD,HD4,EC Q:$D(DIRUT)
. ;
Q:$D(DIRUT)
D SUMZIP^ACKQDWLR Q:$D(DIRUT)
D SUMICD^ACKQDWLR Q:$D(DIRUT)
D SUMCPT^ACKQDWLR Q:$D(DIRUT)
D SUMEC^ACKQDWLR Q:$D(DIRUT)
Q
;
ZIP ; For all visits
N ACKZCT,ACKZTT,ACKZUT,ACKZCPT
S AS=""
F S AS=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,3,AS)) Q:AS=""!($D(DIRUT)) D
.S ACKZCT=0,ACKZTT=0,ACKZUT=0,ACKZCPT=0
.I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD1
.S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
.W !," "_XAS,":"
.S (ZIP,T)="" F S ZIP=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,3,AS,ZIP)) Q:ZIP=""!($D(DIRUT)) D
..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD1 W !," "_XAS,":"
..S X=^TMP("ACKQDWLP",$J,"R",ACKDIEN,3,AS,ZIP)
..; Print Zip data
..W !," "_ZIP ; Write zero's instead of nulls
..W ?25,$S($P(X,U,1):$P(X,U,1),1:"0")
..W ?39,$S($P(X,U,2):$P(X,U,2),1:"0")
..W ?55,$S($P(X,U,3):$P(X,U,3),1:"0")
..W ?69,$S($P(X,U,4):$P(X,U,4),1:"0")
..;
..; Calculate Totals
..S ACKZCT=ACKZCT+$P(X,U,1),ACKZTT=ACKZTT+$P(X,U,2)
..S ACKZUT=ACKZUT+$P(X,U,3),ACKZCPT=ACKZCPT+$P(X,U,4)
..;
.Q:$D(DIRUT)
.S $P(LN,"-",80)="" W !,LN
.W !," "_XAS," Total: ",?25,ACKZCT,?39,ACKZTT,?55,ACKZUT,?69,ACKZCPT,!
Q:$D(DIRUT)
D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
Q
;
ICD ; ICD stats
N ACKICT,ACKITT,ACKIUT
; D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
S AS=0 F S AS=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,1,AS)) Q:AS=""!($D(DIRUT)) D
.S ACKICT=0,ACKITT=0,ACKIUT=0
.I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
.S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
.W !," "_XAS,":"
.S ICD="" F S ICD=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,1,AS,ICD)) Q:ICD=""!($D(DIRUT)) D
..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
..S ACKSTR=^TMP("ACKQDWLP",$J,"R",ACKDIEN,1,AS,ICD)
..; Display data
..W !," "_ICD
..W ?25,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
..W ?39,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
..W ?55,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
..; Calculate Totals
..S ACKICT=ACKICT+$P(ACKSTR,U,1),ACKITT=ACKITT+$P(ACKSTR,U,2)
..S ACKIUT=ACKIUT+$P(ACKSTR,U,3)
..;
.Q:$D(DIRUT)
.S $P(LN,"-",80)="" W !,LN
.W !," "_XAS," Total: ",?25,ACKICT,?39,ACKITT,?55,ACKIUT,!
.Q:$D(DIRUT)
Q:$D(DIRUT)
D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
Q
;
CPT ; CPT stats
N ACKCCT,ACKCTT,ACKCUT
;
S AS=0 F S AS=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,2,AS)) Q:AS=""!($D(DIRUT)) D
.S ACKCCT=0,ACKCTT=0,ACKCUT=0
.I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
.S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
.W !," "_XAS,":"
.S CPT="" F S CPT=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,2,AS,CPT)) Q:CPT=""!($D(DIRUT)) D
..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
..S ACKSTR=^TMP("ACKQDWLP",$J,"R",ACKDIEN,2,AS,CPT)
..; Display data
..W !," "_$$GET1^DIQ(509850.4,CPT_",",.01)
..W ?25,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
..W ?39,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
..W ?55,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
..; Calculate Totals
..S ACKCCT=ACKCCT+$P(ACKSTR,U,1),ACKCTT=ACKCTT+$P(ACKSTR,U,2)
..S ACKCUT=ACKCUT+$P(ACKSTR,U,3)
..;
.Q:$D(DIRUT)
.S $P(LN,"-",80)="" W !,LN
.W !," "_XAS," Total: ",?25,ACKCCT,?39,ACKCTT,?55,ACKCUT,!
.Q:$D(DIRUT)
Q:$D(DIRUT)
D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
Q
;
EC ; EC stats
N ACKCCT,ACKCTT,ACKCUT
;
S AS=0 F S AS=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,5,AS)) Q:AS=""!($D(DIRUT)) D
.S ACKCCT=0,ACKCTT=0,ACKCUT=0
.I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD4
.S XAS=$S(AS="A":"Audiology",1:"Speech Pathology")
.W !," "_XAS,":"
.S EC="" F S EC=$O(^TMP("ACKQDWLP",$J,"R",ACKDIEN,5,AS,EC)) Q:EC=""!($D(DIRUT)) D
..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD4
..S ACKSTR=^TMP("ACKQDWLP",$J,"R",ACKDIEN,5,AS,EC)
..; Display data
..W !," "_$$GET1^DIQ(725,EC_",",1,"I")
..W ?25,$S($P(ACKSTR,U,1):$P(ACKSTR,U,1),1:"0")
..W ?39,$S($P(ACKSTR,U,2):$P(ACKSTR,U,2),1:"0")
..W ?55,$S($P(ACKSTR,U,3):$P(ACKSTR,U,3),1:"0")
..; Calculate Totals
..S ACKCCT=ACKCCT+$P(ACKSTR,U,1),ACKCTT=ACKCTT+$P(ACKSTR,U,2)
..S ACKCUT=ACKCUT+$P(ACKSTR,U,3)
..;
.Q:$D(DIRUT)
.S $P(LN,"-",80)="" W !,LN
.W !," "_XAS," Total: ",?25,ACKCCT,?39,ACKCTT,?55,ACKCUT,!
.Q:$D(DIRUT)
Q:$D(DIRUT)
D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT)
Q
;
DHD ;
N X
W:($E(IOST)="C")!(ACKPG>0) @IOF
S ACKPG=ACKPG+1
W "Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG
W ! D CNTR^ACKQUTL("Audiology & Speech Pathology")
W ! D CNTR^ACKQUTL("Capitation Report")
I ACKPASS W ! D CNTR^ACKQUTL("for DIVISION: "_ACKDNME)
W ! D CNTR^ACKQUTL($$XDAT^ACKQUTL(ACKM)) W !
Q
;
HD1 ; Header for all visits
N X
W !,?23,"CLINIC",?36,"TELEPHONE",?53,"UNIQUE"
W !," ZIP CODE",?23,"VISITS",?37,"VISITS",?52,"PATIENTS",?68,"C&P"
D LINE Q
;
HD2 ; Head for ICD stats
N X W !,?23,"CLINIC",?36,"TELEPHONE"
W !," ICD",?23,"VISITS",?37,"VISITS",?53,"UNIQUE" D LINE Q
;
HD3 ; Head for CPT stats
N X W !,?23,"CLINIC",?36,"TELEPHONE"
W !," CPT",?23,"VISITS",?37,"VISITS",?53,"UNIQUE" D LINE Q
;
HD4 ; Head for EC stats
N X W !,?23,"CLINIC",?36,"TELEPHONE"
W !," EC",?23,"VISITS",?37,"VISITS",?53,"UNIQUE" D LINE Q
;
LINE S X="",$P(X,"-",IOM)="-" W !,X Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQDWLP 9793 printed Nov 22, 2024@17:42:09 Page 2
ACKQDWLP ;AUG/JLTP BIR/PTD HCIOFO/BH - Print A&SP Capitation Report ;19 Nov 2013 9:53 AM
+1 ;;3.0;QUASAR;**1,22,21**;Feb 11, 2000;Build 40
+2 ;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
+3 ;
+4 ; Developed within V.3, works at Div level rather than site level -
+5 ; - pre v.3
+6 ;
+7 ;
+8 ; Reference/ICR
+9 ; $$CODEC^ICDEX - 5747
+10 ;
+11 ;
+12 KILL ^TMP("ACKQDWLP",$JOB)
OPTN ; Introduce option
+1 WRITE @IOF,!,"This option produces a four-part Capitation Report.",!,"It includes Demographic, Diagnostic and Procedure data.",!
+2 ;
DIV ; select Div (user may select one/many/ALL)
+1 SET ACKDIV=$$DIV^ACKQUTL2(3,.ACKDIV,"IA")
if 'ACKDIV
GOTO EXIT
+2 DO GETDT^ACKQWL
if $DATA(DIRUT)
GOTO EXIT
DO INIT^ACKQWL
+3 ;
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^ACKQDWLP"
SET ZTDESC="QUASAR - Print A&SP Capitation Report"
SET ZTSAVE("ACK*")=""
DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
GOTO EXIT
DQ ; Entry point when queued.
+1 USE IO
+2 DO NOW^%DTC
SET ACKCDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%)
SET ACKPG=0
KILL ^TMP("ACKQWLD",$JOB)
+3 DO COMPILE
DO PRINT
+4 ;
EXIT ; ALWAYS EXIT HERE
+1 KILL %I,ACKBFY,ACKCDT,ACKDA,ACKEM,ACKM,ACKPG,AS,CDR,CPT,DIR,DIRUT,DTOUT
+2 KILL ACKDIV,DUOUT,I,ICD,LN,T,X,XAS,Y,ZIP,^TMP("ACKQDWLP",$JOB)
+3 if $EXTRACT(IOST)="C"
WRITE @IOF
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
+5 ;
COMPILE ; Comp properly sorted data in ^TMP
+1 NEW ACK1,ACKVDVN,ACK6,ACKREC,ACKAUD,ACKSPE
+2 ;
+3 SET ACK1=""
+4 FOR
SET ACK1=$ORDER(ACKDIV(ACK1))
if ACK1=""
QUIT
Begin DoDot:1
+5 SET ACKVDVN=$PIECE(ACKDIV(ACK1),U,1)
+6 DO ZIPSTAT
DO ICDSTAT
DO CPTSTAT
DO ECSTAT^ACKQDWLU
End DoDot:1
+7 QUIT
+8 ;
ZIPSTAT ; ZIP stats
+1 NEW ACKCODE
+2 SET ACK6=0
+3 FOR
SET ACK6=$ORDER(^ACK(509850.7,ACKDA,5,ACKVDVN,3,ACK6))
if ACK6=""!(ACK6'?.N)
QUIT
Begin DoDot:1
+4 SET ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,3,ACK6,0)
+5 SET ACKAUD=$PIECE(ACKREC,U,2,5)
SET ACKSPE=$PIECE(ACKREC,U,6,9)
+6 SET ACKCODE=$PIECE(ACKREC,U,1)
+7 IF $TRANSLATE(ACKAUD,"^","")'=""
Begin DoDot:2
+8 SET ^TMP("ACKQDWLP",$JOB,"R",ACKVDVN,3,"A",ACKCODE)=ACKAUD
+9 SET ^TMP("ACKQDWLP",$JOB,"S",3,"A",ACKCODE,ACKVDVN)=ACKAUD
End DoDot:2
+10 IF $TRANSLATE(ACKSPE,"^","")'=""
Begin DoDot:2
+11 SET ^TMP("ACKQDWLP",$JOB,"R",ACKVDVN,3,"S",ACKCODE)=ACKSPE
+12 SET ^TMP("ACKQDWLP",$JOB,"S",3,"S",ACKCODE,ACKVDVN)=ACKSPE
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
ICDSTAT ; ICD stats
+1 NEW ACKCODE
+2 SET ACK6=0
+3 FOR
SET ACK6=$ORDER(^ACK(509850.7,ACKDA,5,ACKVDVN,1,ACK6))
if ACK6=""!(ACK6'?.N)
QUIT
Begin DoDot:1
+4 SET ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,1,ACK6,0)
+5 SET ACKAUD=$PIECE(ACKREC,U,2,4)
SET ACKSPE=$PIECE(ACKREC,U,5,7)
+6 SET ACKCODE=$PIECE(ACKREC,U,1)
+7 ;ACKQ*3.0*22 updated api
+8 SET ACKCODE=$$CODEC^ICDEX(80,ACKCODE)
+9 SET ACKCODE=($SELECT(ACKCODE?.NP:+ACKCODE,1:ACKCODE))
+10 IF $TRANSLATE(ACKAUD,"^","")'=""
Begin DoDot:2
+11 SET ^TMP("ACKQDWLP",$JOB,"R",ACKVDVN,1,"A",ACKCODE)=ACKAUD
+12 SET ^TMP("ACKQDWLP",$JOB,"S",1,"A",ACKCODE,ACKVDVN)=ACKAUD
End DoDot:2
+13 IF $TRANSLATE(ACKSPE,"^","")'=""
Begin DoDot:2
+14 SET ^TMP("ACKQDWLP",$JOB,"R",ACKVDVN,1,"S",ACKCODE)=ACKSPE
+15 SET ^TMP("ACKQDWLP",$JOB,"S",1,"S",ACKCODE,ACKVDVN)=ACKSPE
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
CPTSTAT ; CPT Stats
+1 NEW ACKCODE
+2 SET ACK6=0
+3 FOR
SET ACK6=$ORDER(^ACK(509850.7,ACKDA,5,ACKVDVN,2,ACK6))
if ACK6=""!(ACK6'?.N)
QUIT
Begin DoDot:1
+4 SET ACKREC=^ACK(509850.7,ACKDA,5,ACKVDVN,2,ACK6,0)
+5 SET ACKAUD=$PIECE(ACKREC,U,2,4)
SET ACKSPE=$PIECE(ACKREC,U,5,7)
+6 SET ACKCODE=$PIECE(ACKREC,U,1)
+7 IF $TRANSLATE(ACKAUD,"^","")'=""
Begin DoDot:2
+8 SET ^TMP("ACKQDWLP",$JOB,"R",ACKVDVN,2,"A",ACKCODE)=ACKAUD
+9 SET ^TMP("ACKQDWLP",$JOB,"S",2,"A",ACKCODE,ACKVDVN)=ACKAUD
End DoDot:2
+10 IF $TRANSLATE(ACKSPE,"^","")'=""
Begin DoDot:2
+11 SET ^TMP("ACKQDWLP",$JOB,"R",ACKVDVN,2,"S",ACKCODE)=ACKSPE
+12 SET ^TMP("ACKQDWLP",$JOB,"S",2,"S",ACKCODE,ACKVDVN)=ACKSPE
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
PRINT ; Display results
+1 NEW ACKDNME,ACKK1,ACKDIEN
+2 ;
+3 SET ACKDNME=""
+4 NEW ACKK1,ACKDIEN,ACKPASS
+5 SET ACKPASS=0
SET ACKK1=""
+6 FOR
SET ACKK1=$ORDER(ACKDIV(ACKK1))
if ACKK1=""
QUIT
Begin DoDot:1
+7 SET ACKDIEN=$PIECE(ACKDIV(ACKK1),U,1)
+8 IF $DATA(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN))
SET ACKPASS=1
End DoDot:1
+9 IF 'ACKPASS
DO DHD
DO LINE
WRITE !!,"No Capitation data found for selected Divisions."
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
QUIT
+10 ;
+11 SET ACKK1=""
+12 FOR
SET ACKK1=$ORDER(ACKDIV(ACKK1))
if ACKK1=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+13 SET ACKDIEN=$PIECE(ACKDIV(ACKK1),U,1)
+14 SET ACKDNME=$PIECE(ACKDIV(ACKK1),U,3)
+15 ;
+16 IF '$ORDER(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,0))
Begin DoDot:2
+17 DO DHD
DO LINE
+18 WRITE !!,"No data found for this Division."
+19 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
End DoDot:2
QUIT
+20 ;
+21 IF $DATA(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,3))
DO DHD
DO HD1
DO ZIP
if $DATA(DIRUT)
QUIT
+22 IF $DATA(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,1))
DO DHD
DO HD2
DO ICD
if $DATA(DIRUT)
QUIT
+23 IF $DATA(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,2))
DO DHD
DO HD3
DO CPT
if $DATA(DIRUT)
QUIT
+24 IF $DATA(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,5))
DO DHD
DO HD4
DO EC
if $DATA(DIRUT)
QUIT
+25 ;
End DoDot:1
+26 if $DATA(DIRUT)
QUIT
+27 DO SUMZIP^ACKQDWLR
if $DATA(DIRUT)
QUIT
+28 DO SUMICD^ACKQDWLR
if $DATA(DIRUT)
QUIT
+29 DO SUMCPT^ACKQDWLR
if $DATA(DIRUT)
QUIT
+30 DO SUMEC^ACKQDWLR
if $DATA(DIRUT)
QUIT
+31 QUIT
+32 ;
ZIP ; For all visits
+1 NEW ACKZCT,ACKZTT,ACKZUT,ACKZCPT
+2 SET AS=""
+3 FOR
SET AS=$ORDER(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,3,AS))
if AS=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+4 SET ACKZCT=0
SET ACKZTT=0
SET ACKZUT=0
SET ACKZCPT=0
+5 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD
DO HD1
+6 SET XAS=$SELECT(AS="A":"Audiology",1:"Speech Pathology")
+7 WRITE !," "_XAS,":"
+8 SET (ZIP,T)=""
FOR
SET ZIP=$ORDER(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,3,AS,ZIP))
if ZIP=""!($DATA(DIRUT))
QUIT
Begin DoDot:2
+9 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD
DO HD1
WRITE !," "_XAS,":"
+10 SET X=^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,3,AS,ZIP)
+11 ; Print Zip data
+12 ; Write zero's instead of nulls
WRITE !," "_ZIP
+13 WRITE ?25,$SELECT($PIECE(X,U,1):$PIECE(X,U,1),1:"0")
+14 WRITE ?39,$SELECT($PIECE(X,U,2):$PIECE(X,U,2),1:"0")
+15 WRITE ?55,$SELECT($PIECE(X,U,3):$PIECE(X,U,3),1:"0")
+16 WRITE ?69,$SELECT($PIECE(X,U,4):$PIECE(X,U,4),1:"0")
+17 ;
+18 ; Calculate Totals
+19 SET ACKZCT=ACKZCT+$PIECE(X,U,1)
SET ACKZTT=ACKZTT+$PIECE(X,U,2)
+20 SET ACKZUT=ACKZUT+$PIECE(X,U,3)
SET ACKZCPT=ACKZCPT+$PIECE(X,U,4)
+21 ;
End DoDot:2
+22 if $DATA(DIRUT)
QUIT
+23 SET $PIECE(LN,"-",80)=""
WRITE !,LN
+24 WRITE !," "_XAS," Total: ",?25,ACKZCT,?39,ACKZTT,?55,ACKZUT,?69,ACKZCPT,!
End DoDot:1
+25 if $DATA(DIRUT)
QUIT
+26 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
+27 QUIT
+28 ;
ICD ; ICD stats
+1 NEW ACKICT,ACKITT,ACKIUT
+2 ; D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
+3 SET AS=0
FOR
SET AS=$ORDER(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,1,AS))
if AS=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+4 SET ACKICT=0
SET ACKITT=0
SET ACKIUT=0
+5 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD
DO HD2
+6 SET XAS=$SELECT(AS="A":"Audiology",1:"Speech Pathology")
+7 WRITE !," "_XAS,":"
+8 SET ICD=""
FOR
SET ICD=$ORDER(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,1,AS,ICD))
if ICD=""!($DATA(DIRUT))
QUIT
Begin DoDot:2
+9 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD
DO HD2
+10 SET ACKSTR=^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,1,AS,ICD)
+11 ; Display data
+12 WRITE !," "_ICD
+13 WRITE ?25,$SELECT($PIECE(ACKSTR,U,1):$PIECE(ACKSTR,U,1),1:"0")
+14 WRITE ?39,$SELECT($PIECE(ACKSTR,U,2):$PIECE(ACKSTR,U,2),1:"0")
+15 WRITE ?55,$SELECT($PIECE(ACKSTR,U,3):$PIECE(ACKSTR,U,3),1:"0")
+16 ; Calculate Totals
+17 SET ACKICT=ACKICT+$PIECE(ACKSTR,U,1)
SET ACKITT=ACKITT+$PIECE(ACKSTR,U,2)
+18 SET ACKIUT=ACKIUT+$PIECE(ACKSTR,U,3)
+19 ;
End DoDot:2
+20 if $DATA(DIRUT)
QUIT
+21 SET $PIECE(LN,"-",80)=""
WRITE !,LN
+22 WRITE !," "_XAS," Total: ",?25,ACKICT,?39,ACKITT,?55,ACKIUT,!
+23 if $DATA(DIRUT)
QUIT
End DoDot:1
+24 if $DATA(DIRUT)
QUIT
+25 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
+26 QUIT
+27 ;
CPT ; CPT stats
+1 NEW ACKCCT,ACKCTT,ACKCUT
+2 ;
+3 SET AS=0
FOR
SET AS=$ORDER(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,2,AS))
if AS=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+4 SET ACKCCT=0
SET ACKCTT=0
SET ACKCUT=0
+5 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD
DO HD3
+6 SET XAS=$SELECT(AS="A":"Audiology",1:"Speech Pathology")
+7 WRITE !," "_XAS,":"
+8 SET CPT=""
FOR
SET CPT=$ORDER(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,2,AS,CPT))
if CPT=""!($DATA(DIRUT))
QUIT
Begin DoDot:2
+9 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD
DO HD3
+10 SET ACKSTR=^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,2,AS,CPT)
+11 ; Display data
+12 WRITE !," "_$$GET1^DIQ(509850.4,CPT_",",.01)
+13 WRITE ?25,$SELECT($PIECE(ACKSTR,U,1):$PIECE(ACKSTR,U,1),1:"0")
+14 WRITE ?39,$SELECT($PIECE(ACKSTR,U,2):$PIECE(ACKSTR,U,2),1:"0")
+15 WRITE ?55,$SELECT($PIECE(ACKSTR,U,3):$PIECE(ACKSTR,U,3),1:"0")
+16 ; Calculate Totals
+17 SET ACKCCT=ACKCCT+$PIECE(ACKSTR,U,1)
SET ACKCTT=ACKCTT+$PIECE(ACKSTR,U,2)
+18 SET ACKCUT=ACKCUT+$PIECE(ACKSTR,U,3)
+19 ;
End DoDot:2
+20 if $DATA(DIRUT)
QUIT
+21 SET $PIECE(LN,"-",80)=""
WRITE !,LN
+22 WRITE !," "_XAS," Total: ",?25,ACKCCT,?39,ACKCTT,?55,ACKCUT,!
+23 if $DATA(DIRUT)
QUIT
End DoDot:1
+24 if $DATA(DIRUT)
QUIT
+25 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
+26 QUIT
+27 ;
EC ; EC stats
+1 NEW ACKCCT,ACKCTT,ACKCUT
+2 ;
+3 SET AS=0
FOR
SET AS=$ORDER(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,5,AS))
if AS=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+4 SET ACKCCT=0
SET ACKCTT=0
SET ACKCUT=0
+5 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD
DO HD4
+6 SET XAS=$SELECT(AS="A":"Audiology",1:"Speech Pathology")
+7 WRITE !," "_XAS,":"
+8 SET EC=""
FOR
SET EC=$ORDER(^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,5,AS,EC))
if EC=""!($DATA(DIRUT))
QUIT
Begin DoDot:2
+9 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
DO DHD
DO HD4
+10 SET ACKSTR=^TMP("ACKQDWLP",$JOB,"R",ACKDIEN,5,AS,EC)
+11 ; Display data
+12 WRITE !," "_$$GET1^DIQ(725,EC_",",1,"I")
+13 WRITE ?25,$SELECT($PIECE(ACKSTR,U,1):$PIECE(ACKSTR,U,1),1:"0")
+14 WRITE ?39,$SELECT($PIECE(ACKSTR,U,2):$PIECE(ACKSTR,U,2),1:"0")
+15 WRITE ?55,$SELECT($PIECE(ACKSTR,U,3):$PIECE(ACKSTR,U,3),1:"0")
+16 ; Calculate Totals
+17 SET ACKCCT=ACKCCT+$PIECE(ACKSTR,U,1)
SET ACKCTT=ACKCTT+$PIECE(ACKSTR,U,2)
+18 SET ACKCUT=ACKCUT+$PIECE(ACKSTR,U,3)
+19 ;
End DoDot:2
+20 if $DATA(DIRUT)
QUIT
+21 SET $PIECE(LN,"-",80)=""
WRITE !,LN
+22 WRITE !," "_XAS," Total: ",?25,ACKCCT,?39,ACKCTT,?55,ACKCUT,!
+23 if $DATA(DIRUT)
QUIT
End DoDot:1
+24 if $DATA(DIRUT)
QUIT
+25 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DIRUT)
QUIT
+26 QUIT
+27 ;
DHD ;
+1 NEW X
+2 if ($EXTRACT(IOST)="C")!(ACKPG>0)
WRITE @IOF
+3 SET ACKPG=ACKPG+1
+4 WRITE "Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG
+5 WRITE !
DO CNTR^ACKQUTL("Audiology & Speech Pathology")
+6 WRITE !
DO CNTR^ACKQUTL("Capitation Report")
+7 IF ACKPASS
WRITE !
DO CNTR^ACKQUTL("for DIVISION: "_ACKDNME)
+8 WRITE !
DO CNTR^ACKQUTL($$XDAT^ACKQUTL(ACKM))
WRITE !
+9 QUIT
+10 ;
HD1 ; Header for all visits
+1 NEW X
+2 WRITE !,?23,"CLINIC",?36,"TELEPHONE",?53,"UNIQUE"
+3 WRITE !," ZIP CODE",?23,"VISITS",?37,"VISITS",?52,"PATIENTS",?68,"C&P"
+4 DO LINE
QUIT
+5 ;
HD2 ; Head for ICD stats
+1 NEW X
WRITE !,?23,"CLINIC",?36,"TELEPHONE"
+2 WRITE !," ICD",?23,"VISITS",?37,"VISITS",?53,"UNIQUE"
DO LINE
QUIT
+3 ;
HD3 ; Head for CPT stats
+1 NEW X
WRITE !,?23,"CLINIC",?36,"TELEPHONE"
+2 WRITE !," CPT",?23,"VISITS",?37,"VISITS",?53,"UNIQUE"
DO LINE
QUIT
+3 ;
HD4 ; Head for EC stats
+1 NEW X
WRITE !,?23,"CLINIC",?36,"TELEPHONE"
+2 WRITE !," EC",?23,"VISITS",?37,"VISITS",?53,"UNIQUE"
DO LINE
QUIT
+3 ;
LINE SET X=""
SET $PIECE(X,"-",IOM)="-"
WRITE !,X
QUIT
+1 ;
