ACKQDWLP.m

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 ---ACKQDWLP   9793     printed  Mar 13, 2025@21:37: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,":"