ABPVDG03.m

ABPVDG03 ;PRINT PRIVATE INSURANCE ELIG I/P ADMIT REPORT; [ 06/02/91  12:47 PM ]

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

START D INIT,HEADING,XTRACT,SUMRY,CLOSE

 Q

 ;

INIT S ABPV("PG")=0,LOC=$P(^DIC(4,ABPV("SITE"),0),"^",1),ZTSK=ABPV("TASK")

 S TITLE="IN-PATIENT ADMISSIONS WITH PRIVATE INSURANCE COVERAGE"

 S A("TITLE")="***  PRIVATE INSURANCE ELIGIBLE REPORT  ***" Q

 ;

HEADING S ABPV("PG")=ABPV("PG")+1

 S A("TM")=$P($H,",",2),A("HR")=A("TM")\3600,A("MIN")=A("TM")#3600\60

 S:A("MIN")<10 A("MIN")="0"_A("MIN") S TME=A("HR")_":"_A("MIN"),A("PDT")=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)

 W @IOF,?80-$L(A("TITLE"))\2,A("TITLE"),!!,A("PDT"),?80-$L(LOC)\2,LOC,?73,"page ",ABPV("PG"),!,TME,?80-$L(TITLE)\2,TITLE S X="(task "_ZTSK_")" W ?80-$L(X),X,!

 S Y=ABPV("BEG") X ^DD("DD") S A("BEG")=Y,Y=ABPV("END") X ^DD("DD") S A("END")=Y S TITLE="For the period "_A("BEG")_" through "_A("END") W ?80-$L(TITLE)\2,TITLE

H5 W !!,"ADMIT DATE",?16,"PATIENT NAME",?38,"CHART #",?47,"INSURANCE CARRIER(S)",! F I=1:1:79 W "-"

 W ! Q

 ;

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

A S A("ADOS")=$O(^%ZTSK(ZTSK,ABPV("SITE"),A("ADOS"))) Q:+A("ADOS")=0!(A("ADOS")>ABPV("END"))

 S ABPV("DOS")=$E(A("ADOS"),4,5)_"/"_$E(A("ADOS"),6,7)_"/"_$E(A("ADOS"),2,3) D:$Y>55 HEADING W !,ABPV("DOS") S A("ADFN")=0

A1 S A("ADFN")=$O(^%ZTSK(ZTSK,ABPV("SITE"),A("ADOS"),A("ADFN"))) G A:+A("ADFN")=0

 S A("SVCS")=1

NAME I $D(^DPT(A("ADFN"),0))=0 S A("NAME")="*****  ERROR  *****" G CHART

 S A("NAME")=$P(^DPT(A("ADFN"),0),"^",1),A("NAME")=$E(A("NAME"),1,20)

CHART I $D(^AUPNPAT(A("ADFN"),41,ABPV("SITE"),0))=0 S A("CHART")="*****  ERROR  *****" G PRINT

 S A("CHART")=$P(^AUPNPAT(A("ADFN"),41,ABPV("SITE"),0),"^",2)

PRINT W ?16,A("NAME"),?38,$J(A("CHART"),7)

PVTINS S ASM("$Y")=$Y,X=0 F I=1:1 S X=$O(^AUPNPRVT(A("ADFN"),11,X)) Q:X="B"!(X="")  S A("PTR")=$P(^AUPNPRVT(A("ADFN"),11,X,0),"^",1) D INSPRT

 I ((X="B"!(X=""))&(I=1)) S A("PRT")="" D INSPRT

 W:ASM("$Y")=$Y ! G A1

INSPRT I A("PTR")="" W ?47,"***** INCOMPLETE *****" D:$Y>55 HEADING W ! Q

 I $D(^AUTNINS(A("PTR"),0))=0 W ?47,"***** INCOMPLETE *****" D:$Y>55 HEADING W ! Q

 W ?47,$P(^AUTNINS(A("PTR"),0),"^",1) D:$Y>55 HEADING W ! Q

 ;

SUMRY W ! F I=1:1:79 W "-"

 S:ABPV("TOTAL")=0 ABPV("%")=0

 S:ABPV("TOTAL")>0 ABPV("%")=(ABPV("HITS")/ABPV("TOTAL"))*100

 W !!,"    TOTAL ADMISSIONS FOR THIS PERIOD: ",$J(ABPV("TOTAL"),6)

 W !,"ADMISSIONS WITH THIRD PARTY COVERAGE: ",$J(ABPV("HITS"),6)

 W !,"    PERCENTAGE PRIVATE INS. COVERAGE: ",$J(ABPV("%"),6,1),"%"

 Q

 ;

CLOSE W @IOF X ^%ZIS("C") K A,ASM,ABPV,LOC,TITLE,X,Y,I Q

ABPVDG03  ;PRINT PRIVATE INSURANCE ELIG I/P ADMIT REPORT; [ 06/02/91  12:47 PM ]

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

START      DO INIT

           DO HEADING

           DO XTRACT

           DO SUMRY

           DO CLOSE

 +1        QUIT 

 +2       ;

INIT       SET ABPV("PG")=0

           SET LOC=$PIECE(^DIC(4,ABPV("SITE"),0),"^",1)

           SET ZTSK=ABPV("TASK")

 +1        SET TITLE="IN-PATIENT ADMISSIONS WITH PRIVATE INSURANCE COVERAGE"

 +2        SET A("TITLE")="***  PRIVATE INSURANCE ELIGIBLE REPORT  ***"

           QUIT 

 +3       ;

HEADING    SET ABPV("PG")=ABPV("PG")+1

 +1        SET A("TM")=$PIECE($HOROLOG,",",2)

           SET A("HR")=A("TM")\3600

           SET A("MIN")=A("TM")#3600\60

 +2        IF A("MIN")<10

               SET A("MIN")="0"_A("MIN")

           SET TME=A("HR")_":"_A("MIN")

           SET A("PDT")=$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)

 +3        WRITE @IOF,?80-$LENGTH(A("TITLE"))\2,A("TITLE"),!!,A("PDT"),?80-$LENGTH(LOC)\2,LOC,?73,"page ",ABPV("PG"),!,TME,?80-$LENGTH(TITLE)\2,TITLE

           SET X="(task "_ZTSK_")"

           WRITE ?80-$LENGTH(X),X,!

 +4        SET Y=ABPV("BEG")

           XECUTE ^DD("DD")

           SET A("BEG")=Y

           SET Y=ABPV("END")

           XECUTE ^DD("DD")

           SET A("END")=Y

           SET TITLE="For the period "_A("BEG")_" through "_A("END")

           WRITE ?80-$LENGTH(TITLE)\2,TITLE

H5         WRITE !!,"ADMIT DATE",?16,"PATIENT NAME",?38,"CHART #",?47,"INSURANCE CARRIER(S)",!

           FOR I=1:1:79

               WRITE "-"

 +1        WRITE !

           QUIT 

 +2       ;

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

A          SET A("ADOS")=$ORDER(^%ZTSK(ZTSK,ABPV("SITE"),A("ADOS")))

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

               QUIT 

 +1        SET ABPV("DOS")=$EXTRACT(A("ADOS"),4,5)_"/"_$EXTRACT(A("ADOS"),6,7)_"/"_$EXTRACT(A("ADOS"),2,3)

           IF $Y>55

               DO HEADING

           WRITE !,ABPV("DOS")

           SET A("ADFN")=0

A1         SET A("ADFN")=$ORDER(^%ZTSK(ZTSK,ABPV("SITE"),A("ADOS"),A("ADFN")))

           IF +A("ADFN")=0

               GOTO A

 +1        SET A("SVCS")=1

NAME       IF $DATA(^DPT(A("ADFN"),0))=0

               SET A("NAME")="*****  ERROR  *****"

               GOTO CHART

 +1        SET A("NAME")=$PIECE(^DPT(A("ADFN"),0),"^",1)

           SET A("NAME")=$EXTRACT(A("NAME"),1,20)

CHART      IF $DATA(^AUPNPAT(A("ADFN"),41,ABPV("SITE"),0))=0

               SET A("CHART")="*****  ERROR  *****"

               GOTO PRINT

 +1        SET A("CHART")=$PIECE(^AUPNPAT(A("ADFN"),41,ABPV("SITE"),0),"^",2)

PRINT      WRITE ?16,A("NAME"),?38,$JUSTIFY(A("CHART"),7)

PVTINS     SET ASM("$Y")=$Y

           SET X=0

           FOR I=1:1

               SET X=$ORDER(^AUPNPRVT(A("ADFN"),11,X))

               IF X="B"!(X="")

                   QUIT 

               SET A("PTR")=$PIECE(^AUPNPRVT(A("ADFN"),11,X,0),"^",1)

               DO INSPRT

 +1        IF ((X="B"!(X=""))&(I=1))

               SET A("PRT")=""

               DO INSPRT

 +2        IF ASM("$Y")=$Y

               WRITE !

           GOTO A1

INSPRT     IF A("PTR")=""

               WRITE ?47,"***** INCOMPLETE *****"

               IF $Y>55

                   DO HEADING

               WRITE !

               QUIT 

 +1        IF $DATA(^AUTNINS(A("PTR"),0))=0

               WRITE ?47,"***** INCOMPLETE *****"

               IF $Y>55

                   DO HEADING

               WRITE !

               QUIT 

 +2        WRITE ?47,$PIECE(^AUTNINS(A("PTR"),0),"^",1)

           IF $Y>55

               DO HEADING

           WRITE !

           QUIT 

 +3       ;

SUMRY      WRITE !

           FOR I=1:1:79

               WRITE "-"

 +1        IF ABPV("TOTAL")=0

               SET ABPV("%")=0

 +2        IF ABPV("TOTAL")>0

               SET ABPV("%")=(ABPV("HITS")/ABPV("TOTAL"))*100

 +3        WRITE !!,"    TOTAL ADMISSIONS FOR THIS PERIOD: ",$JUSTIFY(ABPV("TOTAL"),6)

 +4        WRITE !,"ADMISSIONS WITH THIRD PARTY COVERAGE: ",$JUSTIFY(ABPV("HITS"),6)

 +5        WRITE !,"    PERCENTAGE PRIVATE INS. COVERAGE: ",$JUSTIFY(ABPV("%"),6,1),"%"

 +6        QUIT 

 +7       ;

CLOSE      WRITE @IOF

           XECUTE ^%ZIS("C")

           KILL A,ASM,ABPV,LOC,TITLE,X,Y,I

           QUIT