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