ABPVDG02.m

ABPVDG02 ;TALLY PRIVATE INSURANCE ELIG I/P ADMIT REPORT; [ 06/02/91  12:44 PM ]

 ;;2.0;FACILITY PVT-INS TRACKING;*0*;IHS-OKC/KJR;AUGUST 7, 1991

START D INIT,XTRACT,ZTLOAD

 Q

 ;

INIT S ABPV("TOTAL")=0,ABPV("HITS")=0,ABPV("TASK")=ZTSK Q

 ;

XTRACT S A("ADOS")=ABPV("BEG")-1

A S A("ADOS")=$O(^DPT("AA",A("ADOS")))

 Q:+A("ADOS")=0!(A("ADOS")>ABPV("END"))

 S A("ADFN")=0

A1 S A("ADFN")=$O(^DPT("AA",A("ADOS"),A("ADFN"))) G A:+A("ADFN")=0

 S ABPV("TOTAL")=ABPV("TOTAL")+1

 I $D(^AUPNPRVT(A("ADFN"),0))=0 G A1

 S ABPV("HITS")=ABPV("HITS")+1

 S ^%ZTSK(ZTSK,ABPV("SITE"),A("ADOS"),A("ADFN"))=""

 G A1

 ;

ZTLOAD S ZTRTN="^ABPVDG03",ZTDTH=$H,ZTIO=ABPV("IO"),ZTSAVE("ABPV(")=""

 S ZTDESC="PRINT PVT INS ELIGIBLE IN-PATIENT ADMISSIONS"

 D ^%ZTLOAD

ZTLEND K ABPV,%ZIS,%IS,ZRTN,ZTDTH,ZTDESC,ZTSAVE,ZTSK,A,X,Y,DIC,DIE,DA

 K DR,ZTIO,R,I

 Q

ABPVDG02  ;TALLY PRIVATE INSURANCE ELIG I/P ADMIT REPORT; [ 06/02/91  12:44 PM ]

 +1       ;;2.0;FACILITY PVT-INS TRACKING;*0*;IHS-OKC/KJR;AUGUST 7, 1991

START      DO INIT

           DO XTRACT

           DO ZTLOAD

 +1        QUIT 

 +2       ;

INIT       SET ABPV("TOTAL")=0

           SET ABPV("HITS")=0

           SET ABPV("TASK")=ZTSK

           QUIT 

 +1       ;

XTRACT     SET A("ADOS")=ABPV("BEG")-1

A          SET A("ADOS")=$ORDER(^DPT("AA",A("ADOS")))

 +1        IF +A("ADOS")=0!(A("ADOS")>ABPV("END"))

               QUIT 

 +2        SET A("ADFN")=0

A1         SET A("ADFN")=$ORDER(^DPT("AA",A("ADOS"),A("ADFN")))

           IF +A("ADFN")=0

               GOTO A

 +1        SET ABPV("TOTAL")=ABPV("TOTAL")+1

 +2        IF $DATA(^AUPNPRVT(A("ADFN"),0))=0

               GOTO A1

 +3        SET ABPV("HITS")=ABPV("HITS")+1

 +4        SET ^%ZTSK(ZTSK,ABPV("SITE"),A("ADOS"),A("ADFN"))=""

 +5        GOTO A1

 +6       ;

ZTLOAD     SET ZTRTN="^ABPVDG03"

           SET ZTDTH=$HOROLOG

           SET ZTIO=ABPV("IO")

           SET ZTSAVE("ABPV(")=""

 +1        SET ZTDESC="PRINT PVT INS ELIGIBLE IN-PATIENT ADMISSIONS"

 +2        DO ^%ZTLOAD

ZTLEND     KILL ABPV,%ZIS,%IS,ZRTN,ZTDTH,ZTDESC,ZTSAVE,ZTSK,A,X,Y,DIC,DIE,DA

 +1        KILL DR,ZTIO,R,I

 +2        QUIT