AGRPTINS.m

AGRPTINS ; IHS/SD/TPF - REPORT OF TOP 'N' INSURERS

 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 ;

 ;RUN A REPORT TO LIST THE TOP INSURERS THAT HAVE OPEN ELIGBILITY

 ;AT A SPECIFIC POINT IN TIME.

 ;I.E. ASK FOR A SPECIFIC POINT IN TIME

 ;GO THROUGH THE PRIVATE ELIGIBILITY,MEDICAID,MEDICARE FILE AND

 ;FIND INSURERS THAT ARE ACTIVE. LET USER CHOOSE TO DISREGARD NON

 ;ACTIVE PATIENTS. ALLOW USER TO CHOOSE HOW MANY TOP INSURERS TO

 ;LIST

 ;

EN ;EP

 S ROUTNAME=$P($T(+1)," ")

 S:$G(AGLINE("EQ"))="" $P(AGLINE("EQ"),"=",81)=""

 D HDR

ASKFAC ;EP - ASK FOR A SPECIFIC FACILITY OR ALL

 K DIR,DTOUT,DUOUT,DIRUT,DIROUT,TARFAC

 S DIR("A")="Check for which Facility: All//"

 S DIR(0)="POA^9999999.06:EMZ"

 D ^DIR

 I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) D EXIT Q

 I X="" S TARFAC="ALL"

 E  S TARFAC=+Y

 K DIR

ASKDT ;EP - ASK FOR THE 'POINT IN TIME'

 W !!

 K DIR,DTOUT,DUOUT,DIRUT,DIROUT

 S DIR("A")="Date for the point in Time want eligibility for"

 S DIR(0)="DO"

 D ^DIR

 G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) ASKFAC

 S TARDATE=Y

 K DIR

ASKACTPT ;EP - ASK WHETHER TO DISREGARD NON-ACTIVE PATIENTS

 K DIR,DTOUT,DUOUT,DIRUT,DIROUT

 S DIR("A")="Want to check if patient is active? "

 S DIR(0)="YOA"

 D ^DIR

 G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) ASKDT

 S NONACT=+Y  ;IF TRUE THEN DO NOT COUNT NON-ACTIVE PATIENTS

 K DIR

ASKENTRY ;EP

 K DIR,DTOUT,DUOUT,DIRUT,DIROUT

 S DIR("A")="How many entries do you want in the list"

 S DIR("B")=20

 S DIR(0)="NO^5:100"

 D ^DIR

 G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) ASKACTPT

 S MAXDISP=+Y

 K DIR

 D NOW^%DTC S Y=% D DD^%DT S REPTIME=Y

 D ASKDEV

 G:POP EN

 I $G(IO("Q")) D QUE Q

 U IO

 S PAGENO=0

 D RUN(TARDATE,NONACT)

 D ^%ZISC

 G EN

RUN(TARDATE,NONACT) ;EP

 ;IF REPTIME IS NULL THEN TASKMAN IS CALLING

 I $G(REPTIME)="" D NOW^%DTC S Y=% D DD^%DT S REPTIME=Y

 K ^XTMP(ROUTNAME,$J)

 D COMPILE(TARDATE,NONACT)

 F GLO="^AUPNMCD","^AUPNMCR","^AUPNRRE" D

 .D GENCOMPL(GLO,TARDATE,NONACT)

 I '$D(^XTMP(ROUTNAME,$J)) W !,"NO INSURANCE MEMBERS FOUND FOR ",$P($G(^DIC(4,TARFAC,0)),U)," FACILITES" H 3 G EN

 D SORTMAX("^XTMP("_ROUTNAME_",$J)")

 D PRINTMAX("^XTMP("_ROUTNAME_",$J,""MAXSORT"")")

 Q

ASKDEV ;EP

 S %ZIS="Q"

 D ^%ZIS

 Q

HDR ;EP

 X ^%ZOSF("UCI") S UCI=$P(Y,",")

 W @IOF

 D CENTER("PATIENT REGISTRATION")

 W !!

 D CENTER($P($G(^DIC(4,DUZ(2),0)),U))

 W !!

 D CENTER("TOP 20 INSURERS REPORT")

 W !!,$$CJ^XLFSTR("*** NOTE:  IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)

 W !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)

 W !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)

 Q

CENTER(X) ;

 S CENTER=IOM/2

 W ?CENTER-($L(X)/2),X

 Q

COMPILE(TARDATE,NONACT,MAXDISP) ;EP - GO THROUGH THE PRVT ELG FILE AND

 ;FIND ALL PATIENTS WITH ACTIVE POLICIES

 N PDFN,INS

 S ELIGCNT=0

 S PDFN=0

 F  S PDFN=$O(^AUPNPRVT(PDFN)) Q:'PDFN  D

 .Q:'$D(^AUPNPAT(PDFN,0))              ;BAD NODE

 .I TARFAC'="ALL" Q:'$D(^AUPNPAT(PDFN,41,TARFAC,0))    ;SKIP FACILITIES NOT PICKED AT 'ASKFAC' PROMPT

 .S STATDT=$P($G(^AUPNPAT(PDFN,41,TARFAC,0)),U,3)  ;INACTIVATED/DELETED FIELD

 .I NONACT I TARDATE=STATDT!(TARDATE>STATDT),(STATDT'="") Q  ;IF THEY WANT TO DISREGARD NOACTIVE PATIENTS AND THE PATIENT IS CONSIDERED INACTIVE THEN QUIT

 .S INS=0

 .F  S INS=$O(^AUPNPRVT(PDFN,11,INS)) Q:'INS  D

 ..S ELIGDT=$P($G(^AUPNPRVT(PDFN,11,INS,0)),U,6)

 ..S EXPDT=$P($G(^AUPNPRVT(PDFN,11,INS,0)),U,7)

 ..S COVTYP=$P($G(^AUPNPRVT(PDFN,11,INS,0)),U,3) S:COVTYP'="" COVTYP=$P($G(^AUTTPIC(COVTYP,0)),U) S:COVTYP="" COVTYP="UNDEF"

 ..I $$ISACTIVE(ELIGDT,EXPDT,TARDATE) D

 ...S INSPTR=$P($G(^AUPNPRVT(PDFN,11,INS,0)),U) S:INSPTR="" INSPTR="UNDEF"

 ...S ELIGCNT=ELIGCNT+1

 ...S ^XTMP(ROUTNAME,$J,INSPTR,COVTYP)=$G(^XTMP(ROUTNAME,$J,INSPTR,COVTYP))+1

 Q

GENCOMPL(GLO,TARDATE,NONACT) ;EP - LETS DO THE OTHER INSURERS. PASS

 ;GLOBAL ROOT

 N PDFN,ELIGDT,EXPDT,ELIGCNT

 S PDFN=0,ELIGCNT=0

 F  S PDFN=$O(@GLO@(PDFN)) Q:PDFN=""!('PDFN)  D

 .Q:'$D(@GLO@(PDFN,11))  ;NO ELIGIBILITY DATES

 .Q:'$D(^AUPNPAT(PDFN,0))              ;NOT EVEN REGISTERED

 .I TARFAC'="ALL" Q:'$D(^AUPNPAT(PDFN,41,TARFAC,0))    ;SKIP FACILITIES NOT PICKED AT 'ASKFAC' PROMPT

 .S STATDT=$P($G(^AUPNPAT(PDFN,41,DUZ(2),0)),U,3)  ;INACTIVATED/DELETED FIELD

 .S DTREC=0

 .F  S DTREC=$O(@GLO@(PDFN,11,DTREC)) Q:'DTREC  D

 ..S ELIGDT=$P($G(@GLO@(PDFN,11,DTREC,0)),U)

 ..S EXPDT=$P($G(@GLO@(PDFN,11,DTREC,0)),U,2)

 ..S COVTYP=$P($G(@GLO@(PDFN,11,DTREC,0)),U,3) S:COVTYP="" COVTYP="UNDEF"

 ..I $$ISACTIVE(ELIGDT,EXPDT,TARDATE) D

 ...S INSPTR=$P($G(@GLO@(PDFN,0)),U,2) S:INSPTR="" INSPTR="UNDEF"

 ...S ELIGCNT=ELIGCNT+1

 ...S ^XTMP(ROUTNAME,$J,INSPTR,COVTYP)=$G(^XTMP(ROUTNAME,$J,INSPTR,COVTYP))+1

 Q

ISACTIVE(EFFDT,ENDDT,TARDATE) ;

 NEW OPENEND

 I EFFDT="",(ENDDT="") Q 0

 S ENDDT=ENDDT  ;TRUE IF ENDING DATE IS AT COB OF ENDING DATE - ANSWER FROM ADRIAN IS IT IS

 ;               IN FORCE FOR ALL OF TODAY

 S OPENEND=ENDDT=""

 I OPENEND I TARDATE=EFFDT!(TARDATE>EFFDT) Q 1

 I TARDATE=EFFDT!(TARDATE=ENDDT) Q 1

 I TARDATE>EFFDT&(TARDATE<ENDDT) Q 1

 Q 0

SORTMAX(GLO) ;EP - GO THROUGH TEMP GLOBAL AND RE-SORT BY MAX

 N INSPTR,COVTYP

 S INSPTR=""

 F  S INSPTR=$O(^XTMP(ROUTNAME,$J,INSPTR)) Q:INSPTR=""!(INSPTR="ZMAXSORT")  D

 .S COVTYP=""

 .F  S COVTYP=$O(^XTMP(ROUTNAME,$J,INSPTR,COVTYP)) Q:COVTYP=""  D

 ..S MAX=$G(^XTMP(ROUTNAME,$J,INSPTR,COVTYP))

 ..S ^XTMP(ROUTNAME,$J,"ZMAXSORT",MAX,INSPTR,COVTYP)=""

 Q

PRINTMAX(GLO) ;EP - PRINT THE MAX COUNTS OUT

 D MAINHDR

 U IO

 N MAX,LINE,ESCAPE

 S ESCAPE=0,LINE=0

 S MAX=""

 F RANK=1:1 S MAX=$O(^XTMP(ROUTNAME,$J,"ZMAXSORT",MAX),-1) Q:MAX=""!(ESCAPE)  D

 .S INSPTR=""

 .F  S INSPTR=$O(^XTMP(ROUTNAME,$J,"ZMAXSORT",MAX,INSPTR)) Q:INSPTR=""!(ESCAPE)  D

 ..S COVTYP=""

 ..F ITEM=1:1 S COVTYP=$O(^XTMP(ROUTNAME,$J,"ZMAXSORT",MAX,INSPTR,COVTYP)) Q:COVTYP=""!(ESCAPE)  D

 ...W:ITEM'=1 !

 ...S LINE=LINE+1

 ...S ESCAPE=LINE>MAXDISP

 ...I ESCAPE,(IOST[("C-")) W ! K DIR S DIR(0)="E" D ^DIR Q

 ...I ESCAPE,(IOST'[("C-")) Q

 ...W !?2,$E($P($G(^AUTNINS(INSPTR,0)),U),1,23)

 ...W ?31,$S(COVTYP="UNDEF":"",1:COVTYP)

 ...W ?62,MAX

 ...;NOTE: HEADER IS 10 LINES

 ...I $Y>(IOSL-10),(IOST[("C-")) W ! K DIR S DIR(0)="E" D ^DIR S ESCAPE=X=U D:'ESCAPE MAINHDR Q

 ...I $Y>(IOSL-10) D MAINHDR

 Q

MAINHDR ;EP

 S PAGENO=PAGENO+1

 W @IOF

 W !,$P($G(^VA(200,DUZ,0)),U)

 D CENTER($P($G(^DIC(4,DUZ(2),0)),U))

 W ?73,"Page ",PAGENO

 W !

 D CENTER("TOP '"_MAXDISP_"' INSURER'S REPORT")

 W !

 D CENTER("as of "_REPTIME)

 W !!

 I NONACT D CENTER("REPORT CONTAINS ACTIVE PATIENTS ONLY")

 W !!

 W !?2,"INSURER",?26,"COVERAGE TYPE",?61,"COUNT"

 W !,$G(AGLINE("EQ"))

 Q

EXIT ;EP - CLEANUP VARS

 K CENTER,COVTYP,DIR,DTREC,EFFDT,ELIGCNT,ELIGDT,ENDDT,ESCAPE,EXPDT,GLO,TARFAC,AGLINE,TARDATE,NONACT,PAGENO,ROUTNAME

 Q

QUE ;EP

 K IO("Q")

 S ZTRTN="RUN^AGRPTINS(TARDATE,NONACT)",ZTDESC="REPORT OF TOP "_MAXDISP_" INSURERS"

 S ZTSAVE("ROUTNAME")=""

 S ZTSAVE("AGLINE")=""

 S ZTSAVE("TARFAC")=""

 S ZTSAVE("TARDATE")=""

 S ZTSAVE("NONACT")=""

 S ZTSAVE("MAXDISP")=""

 S ZTSAVE("PAGENO")=0

 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED AS TASK # "_ZTSK_" !",!

 Q

AGRPTINS  ; IHS/SD/TPF - REPORT OF TOP 'N' INSURERS

 +1       ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 +2       ;

 +3       ;RUN A REPORT TO LIST THE TOP INSURERS THAT HAVE OPEN ELIGBILITY

 +4       ;AT A SPECIFIC POINT IN TIME.

 +5       ;I.E. ASK FOR A SPECIFIC POINT IN TIME

 +6       ;GO THROUGH THE PRIVATE ELIGIBILITY,MEDICAID,MEDICARE FILE AND

 +7       ;FIND INSURERS THAT ARE ACTIVE. LET USER CHOOSE TO DISREGARD NON

 +8       ;ACTIVE PATIENTS. ALLOW USER TO CHOOSE HOW MANY TOP INSURERS TO

 +9       ;LIST

 +10      ;

EN        ;EP

 +1        SET ROUTNAME=$PIECE($TEXT(+1)," ")

 +2        IF $GET(AGLINE("EQ"))=""

               SET $PIECE(AGLINE("EQ"),"=",81)=""

 +3        DO HDR

ASKFAC    ;EP - ASK FOR A SPECIFIC FACILITY OR ALL

 +1        KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT,TARFAC

 +2        SET DIR("A")="Check for which Facility: All//"

 +3        SET DIR(0)="POA^9999999.06:EMZ"

 +4        DO ^DIR

 +5        IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))

               DO EXIT

               QUIT 

 +6        IF X=""

               SET TARFAC="ALL"

 +7       IF '$TEST

               SET TARFAC=+Y

 +8        KILL DIR

ASKDT     ;EP - ASK FOR THE 'POINT IN TIME'

 +1        WRITE !!

 +2        KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT

 +3        SET DIR("A")="Date for the point in Time want eligibility for"

 +4        SET DIR(0)="DO"

 +5        DO ^DIR

 +6        IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))

               GOTO ASKFAC

 +7        SET TARDATE=Y

 +8        KILL DIR

ASKACTPT  ;EP - ASK WHETHER TO DISREGARD NON-ACTIVE PATIENTS

 +1        KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT

 +2        SET DIR("A")="Want to check if patient is active? "

 +3        SET DIR(0)="YOA"

 +4        DO ^DIR

 +5        IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))

               GOTO ASKDT

 +6       ;IF TRUE THEN DO NOT COUNT NON-ACTIVE PATIENTS

           SET NONACT=+Y

 +7        KILL DIR

ASKENTRY  ;EP

 +1        KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT

 +2        SET DIR("A")="How many entries do you want in the list"

 +3        SET DIR("B")=20

 +4        SET DIR(0)="NO^5:100"

 +5        DO ^DIR

 +6        IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))

               GOTO ASKACTPT

 +7        SET MAXDISP=+Y

 +8        KILL DIR

 +9        DO NOW^%DTC

           SET Y=%

           DO DD^%DT

           SET REPTIME=Y

 +10       DO ASKDEV

 +11       IF POP

               GOTO EN

 +12       IF $GET(IO("Q"))

               DO QUE

               QUIT 

 +13       USE IO

 +14       SET PAGENO=0

 +15       DO RUN(TARDATE,NONACT)

 +16       DO ^%ZISC

 +17       GOTO EN

RUN(TARDATE,NONACT) ;EP

 +1       ;IF REPTIME IS NULL THEN TASKMAN IS CALLING

 +2        IF $GET(REPTIME)=""

               DO NOW^%DTC

               SET Y=%

               DO DD^%DT

               SET REPTIME=Y

 +3        KILL ^XTMP(ROUTNAME,$JOB)

 +4        DO COMPILE(TARDATE,NONACT)

 +5        FOR GLO="^AUPNMCD","^AUPNMCR","^AUPNRRE"

               Begin DoDot:1

 +6                DO GENCOMPL(GLO,TARDATE,NONACT)

               End DoDot:1

 +7        IF '$DATA(^XTMP(ROUTNAME,$JOB))

               WRITE !,"NO INSURANCE MEMBERS FOUND FOR ",$PIECE($GET(^DIC(4,TARFAC,0)),U)," FACILITES"

               HANG 3

               GOTO EN

 +8        DO SORTMAX("^XTMP("_ROUTNAME_",$J)")

 +9        DO PRINTMAX("^XTMP("_ROUTNAME_",$J,""MAXSORT"")")

 +10       QUIT 

ASKDEV    ;EP

 +1        SET %ZIS="Q"

 +2        DO ^%ZIS

 +3        QUIT 

HDR       ;EP

 +1        XECUTE ^%ZOSF("UCI")

           SET UCI=$PIECE(Y,",")

 +2        WRITE @IOF

 +3        DO CENTER("PATIENT REGISTRATION")

 +4        WRITE !!

 +5        DO CENTER($PIECE($GET(^DIC(4,DUZ(2),0)),U))

 +6        WRITE !!

 +7        DO CENTER("TOP 20 INSURERS REPORT")

 +8        WRITE !!,$$CJ^XLFSTR("*** NOTE:  IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)

 +9        WRITE !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)

 +10       WRITE !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)

 +11       QUIT 

CENTER(X) ;

 +1        SET CENTER=IOM/2

 +2        WRITE ?CENTER-($LENGTH(X)/2),X

 +3        QUIT 

COMPILE(TARDATE,NONACT,MAXDISP) ;EP - GO THROUGH THE PRVT ELG FILE AND

 +1       ;FIND ALL PATIENTS WITH ACTIVE POLICIES

 +2        NEW PDFN,INS

 +3        SET ELIGCNT=0

 +4        SET PDFN=0

 +5        FOR 

               SET PDFN=$ORDER(^AUPNPRVT(PDFN))

               IF 'PDFN

                   QUIT 

               Begin DoDot:1

 +6       ;BAD NODE

                   IF '$DATA(^AUPNPAT(PDFN,0))

                       QUIT 

 +7       ;SKIP FACILITIES NOT PICKED AT 'ASKFAC' PROMPT

                   IF TARFAC'="ALL"

                       IF '$DATA(^AUPNPAT(PDFN,41,TARFAC,0))

                           QUIT 

 +8       ;INACTIVATED/DELETED FIELD

                   SET STATDT=$PIECE($GET(^AUPNPAT(PDFN,41,TARFAC,0)),U,3)

 +9       ;IF THEY WANT TO DISREGARD NOACTIVE PATIENTS AND THE PATIENT IS CONSIDERED INACTIVE THEN QUIT

                   IF NONACT

                       IF TARDATE=STATDT!(TARDATE>STATDT)

                           IF (STATDT'="")

                               QUIT 

 +10               SET INS=0

 +11               FOR 

                       SET INS=$ORDER(^AUPNPRVT(PDFN,11,INS))

                       IF 'INS

                           QUIT 

                       Begin DoDot:2

 +12                       SET ELIGDT=$PIECE($GET(^AUPNPRVT(PDFN,11,INS,0)),U,6)

 +13                       SET EXPDT=$PIECE($GET(^AUPNPRVT(PDFN,11,INS,0)),U,7)

 +14                       SET COVTYP=$PIECE($GET(^AUPNPRVT(PDFN,11,INS,0)),U,3)

                           IF COVTYP'=""

                               SET COVTYP=$PIECE($GET(^AUTTPIC(COVTYP,0)),U)

                           IF COVTYP=""

                               SET COVTYP="UNDEF"

 +15                       IF $$ISACTIVE(ELIGDT,EXPDT,TARDATE)

                               Begin DoDot:3

 +16                               SET INSPTR=$PIECE($GET(^AUPNPRVT(PDFN,11,INS,0)),U)

                                   IF INSPTR=""

                                       SET INSPTR="UNDEF"

 +17                               SET ELIGCNT=ELIGCNT+1

 +18                               SET ^XTMP(ROUTNAME,$JOB,INSPTR,COVTYP)=$GET(^XTMP(ROUTNAME,$JOB,INSPTR,COVTYP))+1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +19       QUIT 

GENCOMPL(GLO,TARDATE,NONACT) ;EP - LETS DO THE OTHER INSURERS. PASS

 +1       ;GLOBAL ROOT

 +2        NEW PDFN,ELIGDT,EXPDT,ELIGCNT

 +3        SET PDFN=0

           SET ELIGCNT=0

 +4        FOR 

               SET PDFN=$ORDER(@GLO@(PDFN))

               IF PDFN=""!('PDFN)

                   QUIT 

               Begin DoDot:1

 +5       ;NO ELIGIBILITY DATES

                   IF '$DATA(@GLO@(PDFN,11))

                       QUIT 

 +6       ;NOT EVEN REGISTERED

                   IF '$DATA(^AUPNPAT(PDFN,0))

                       QUIT 

 +7       ;SKIP FACILITIES NOT PICKED AT 'ASKFAC' PROMPT

                   IF TARFAC'="ALL"

                       IF '$DATA(^AUPNPAT(PDFN,41,TARFAC,0))

                           QUIT 

 +8       ;INACTIVATED/DELETED FIELD

                   SET STATDT=$PIECE($GET(^AUPNPAT(PDFN,41,DUZ(2),0)),U,3)

 +9                SET DTREC=0

 +10               FOR 

                       SET DTREC=$ORDER(@GLO@(PDFN,11,DTREC))

                       IF 'DTREC

                           QUIT 

                       Begin DoDot:2

 +11                       SET ELIGDT=$PIECE($GET(@GLO@(PDFN,11,DTREC,0)),U)

 +12                       SET EXPDT=$PIECE($GET(@GLO@(PDFN,11,DTREC,0)),U,2)

 +13                       SET COVTYP=$PIECE($GET(@GLO@(PDFN,11,DTREC,0)),U,3)

                           IF COVTYP=""

                               SET COVTYP="UNDEF"

 +14                       IF $$ISACTIVE(ELIGDT,EXPDT,TARDATE)

                               Begin DoDot:3

 +15                               SET INSPTR=$PIECE($GET(@GLO@(PDFN,0)),U,2)

                                   IF INSPTR=""

                                       SET INSPTR="UNDEF"

 +16                               SET ELIGCNT=ELIGCNT+1

 +17                               SET ^XTMP(ROUTNAME,$JOB,INSPTR,COVTYP)=$GET(^XTMP(ROUTNAME,$JOB,INSPTR,COVTYP))+1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +18       QUIT 

ISACTIVE(EFFDT,ENDDT,TARDATE) ;

 +1        NEW OPENEND

 +2        IF EFFDT=""

               IF (ENDDT="")

                   QUIT 0

 +3       ;TRUE IF ENDING DATE IS AT COB OF ENDING DATE - ANSWER FROM ADRIAN IS IT IS

           SET ENDDT=ENDDT

 +4       ;               IN FORCE FOR ALL OF TODAY

 +5        SET OPENEND=ENDDT=""

 +6        IF OPENEND

               IF TARDATE=EFFDT!(TARDATE>EFFDT)

                   QUIT 1

 +7        IF TARDATE=EFFDT!(TARDATE=ENDDT)

               QUIT 1

 +8        IF TARDATE>EFFDT&(TARDATE<ENDDT)

               QUIT 1

 +9        QUIT 0

SORTMAX(GLO) ;EP - GO THROUGH TEMP GLOBAL AND RE-SORT BY MAX

 +1        NEW INSPTR,COVTYP

 +2        SET INSPTR=""

 +3        FOR 

               SET INSPTR=$ORDER(^XTMP(ROUTNAME,$JOB,INSPTR))

               IF INSPTR=""!(INSPTR="ZMAXSORT")

                   QUIT 

               Begin DoDot:1

 +4                SET COVTYP=""

 +5                FOR 

                       SET COVTYP=$ORDER(^XTMP(ROUTNAME,$JOB,INSPTR,COVTYP))

                       IF COVTYP=""

                           QUIT 

                       Begin DoDot:2

 +6                        SET MAX=$GET(^XTMP(ROUTNAME,$JOB,INSPTR,COVTYP))

 +7                        SET ^XTMP(ROUTNAME,$JOB,"ZMAXSORT",MAX,INSPTR,COVTYP)=""

                       End DoDot:2

               End DoDot:1

 +8        QUIT 

PRINTMAX(GLO) ;EP - PRINT THE MAX COUNTS OUT

 +1        DO MAINHDR

 +2        USE IO

 +3        NEW MAX,LINE,ESCAPE

 +4        SET ESCAPE=0

           SET LINE=0

 +5        SET MAX=""

 +6        FOR RANK=1:1

               SET MAX=$ORDER(^XTMP(ROUTNAME,$JOB,"ZMAXSORT",MAX),-1)

               IF MAX=""!(ESCAPE)

                   QUIT 

               Begin DoDot:1

 +7                SET INSPTR=""

 +8                FOR 

                       SET INSPTR=$ORDER(^XTMP(ROUTNAME,$JOB,"ZMAXSORT",MAX,INSPTR))

                       IF INSPTR=""!(ESCAPE)

                           QUIT 

                       Begin DoDot:2

 +9                        SET COVTYP=""

 +10                       FOR ITEM=1:1

                               SET COVTYP=$ORDER(^XTMP(ROUTNAME,$JOB,"ZMAXSORT",MAX,INSPTR,COVTYP))

                               IF COVTYP=""!(ESCAPE)

                                   QUIT 

                               Begin DoDot:3

 +11                               IF ITEM'=1

                                       WRITE !

 +12                               SET LINE=LINE+1

 +13                               SET ESCAPE=LINE>MAXDISP

 +14                               IF ESCAPE

                                       IF (IOST[("C-"))

                                           WRITE !

                                           KILL DIR

                                           SET DIR(0)="E"

                                           DO ^DIR

                                           QUIT 

 +15                               IF ESCAPE

                                       IF (IOST'[("C-"))

                                           QUIT 

 +16                               WRITE !?2,$EXTRACT($PIECE($GET(^AUTNINS(INSPTR,0)),U),1,23)

 +17                               WRITE ?31,$SELECT(COVTYP="UNDEF":"",1:COVTYP)

 +18                               WRITE ?62,MAX

 +19      ;NOTE: HEADER IS 10 LINES

 +20                               IF $Y>(IOSL-10)

                                       IF (IOST[("C-"))

                                           WRITE !

                                           KILL DIR

                                           SET DIR(0)="E"

                                           DO ^DIR

                                           SET ESCAPE=X=U

                                           IF 'ESCAPE

                                               DO MAINHDR

                                           QUIT 

 +21                               IF $Y>(IOSL-10)

                                       DO MAINHDR

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +22       QUIT 

MAINHDR   ;EP

 +1        SET PAGENO=PAGENO+1

 +2        WRITE @IOF

 +3        WRITE !,$PIECE($GET(^VA(200,DUZ,0)),U)

 +4        DO CENTER($PIECE($GET(^DIC(4,DUZ(2),0)),U))

 +5        WRITE ?73,"Page ",PAGENO

 +6        WRITE !

 +7        DO CENTER("TOP '"_MAXDISP_"' INSURER'S REPORT")

 +8        WRITE !

 +9        DO CENTER("as of "_REPTIME)

 +10       WRITE !!

 +11       IF NONACT

               DO CENTER("REPORT CONTAINS ACTIVE PATIENTS ONLY")

 +12       WRITE !!

 +13       WRITE !?2,"INSURER",?26,"COVERAGE TYPE",?61,"COUNT"

 +14       WRITE !,$GET(AGLINE("EQ"))

 +15       QUIT 

EXIT      ;EP - CLEANUP VARS

 +1        KILL CENTER,COVTYP,DIR,DTREC,EFFDT,ELIGCNT,ELIGDT,ENDDT,ESCAPE,EXPDT,GLO,TARFAC,AGLINE,TARDATE,NONACT,PAGENO,ROUTNAME

 +2        QUIT 

QUE       ;EP

 +1        KILL IO("Q")

 +2        SET ZTRTN="RUN^AGRPTINS(TARDATE,NONACT)"

           SET ZTDESC="REPORT OF TOP "_MAXDISP_" INSURERS"

 +3        SET ZTSAVE("ROUTNAME")=""

 +4        SET ZTSAVE("AGLINE")=""

 +5        SET ZTSAVE("TARFAC")=""

 +6        SET ZTSAVE("TARDATE")=""

 +7        SET ZTSAVE("NONACT")=""

 +8        SET ZTSAVE("MAXDISP")=""

 +9        SET ZTSAVE("PAGENO")=0

 +10       DO ^%ZTLOAD

           IF $DATA(ZTSK)

               WRITE !,"REQUEST QUEUED AS TASK # "_ZTSK_" !",!

 +11       QUIT