ACHS3PP2 ; IHS/ITSC/PMF - PRINT CHS THIRD PARTY PAYMENT REPORT - INDIVIDUAL PAT ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
;TPF THIS IS A REWRITE OF ACHSPPB
;CALLED FROM ACHS3PP1
;
D BRPT^ACHSFU
;
S (ACHSOBL,ACHSOBLS,ACHSOBLT,ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDOCS)=0
S (ACHSDOCT,ACHSIHSP,ACHSIHSS,ACHSIHST,C,ACHSPAGE,ACHS43ST,ACHS57ST)=0
S (ACHS64ST,ACHS0ST,ACHS43T,ACHS57T,ACHS64T,ACHS0T)=0
K ACHSPATP
;
;BEGIN INDIV. PATIENT LOOP
S ACHSPAT=""
F S ACHSPAT=$O(^TMP("ACHS3PP",$J,ACHSPAT)) Q:ACHSPAT="" D
.S ACHSPAGE=0
.D:'$O(^TMP("ACHS3PP",$J,ACHSPAT,0)) HEADER,NODATA
.D HEADER
.D GETPAT
D TOTL
Q
GETPAT ;
;I '$D(ACHSPAT(0))
;
S ACHSPATP=$S($D(^DPT(ACHSPAT,0)):$P($G(^DPT(ACHSPAT,0)),U),1:"NO NAME")
S ACHSHRN=$S($D(^AUPNPAT(ACHSPAT,41,DUZ(2),0)):$P($G(^AUPNPAT(ACHSPAT,41,DUZ(2),0)),U,2),1:"NO HRN") D HEADER1
D HEADER2
;
S ACHSDOC=0
F S ACHSDOC=$O(^TMP("ACHS3PP",$J,ACHSPAT,ACHSDOC)) Q:ACHSDOC="" D
.S Z=$G(^TMP("ACHS3PP",$J,ACHSPAT,ACHSDOC))
.S D=$P(Z,U,1),ACHSIDT=$E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
.S S=$P(Z,U,5),ACHSSERV=$S(S=1:"HOSP",S=2:"DENT",S=3:"OUTP",1:"UNKN")
.S ACHSOBL=$P(Z,U,2),ACHS3PP=$P(Z,U,3),ACHSIHSP=$P(Z,U,4)
.S C=C+1,ACHSDOCS=C
PDATA .;Print the Data
.I ACHSRTYP["D" D DETAIL
.;
.I IOST["P-"&($Y>56) D HEADER
.I IOST["C-",'$D(IO("S")),$Y>24 D HEADER D
..I '$$DIR^XBDIR("E") D END Q
..D HEADER
.S ACHSOBLS=ACHSOBLS+ACHSOBL,ACHS3PPS=ACHS3PPS+ACHS3PP,ACHSIHSS=ACHSIHSS+ACHSIHSP
.I ACHSSER=4 D
.. S:S=1 ACHS43ST=ACHS43ST+1
.. S:S=2 ACHS57ST=ACHS57ST+1
.. S:S=3 ACHS64ST=ACHS64ST+1
.. I S'=1&(S'=2)&(S'=3) S ACHS0ST=ACHS0ST+1
.S ACHSFLG=1
D SUBTOTL
Q
;
DETAIL ;DETAIL LINE
W !?1,ACHSDOC,?22,ACHSSERV,?30,ACHSIDT,?40
S X=ACHSOBL,X2=2
D COMMA^%DTC
W $J(X,12),?53
S X=ACHSIHSP,X2=2
D COMMA^%DTC
W $J(X,12),?65
S X=ACHS3PP,X2=2
D COMMA^%DTC
W $J(X,11)
Q
SUBTOTL ;
W !,$$REPEAT^XLFSTR("-",80),!?1,"SUBTOTAL",?4,$J(ACHSDOCS,4)
S X=ACHSOBLS,X2="2$"
D COMMA^%DTC
W ?40,$J(X,12)
S X=ACHSIHSS,X2="2$"
D COMMA^%DTC
W ?53,$J(X,12)
S X=ACHS3PPS,X2="2$"
D COMMA^%DTC
W ?65,$J(X,12)
I ACHSOBLS>0&(ACHSIHSS>0) W !! S Z=(ACHSIHSS/ACHSOBLS)*100 W "PERCENTAGES OF PAYMENT TO OBLIGATED",?59,$E(Z,1,5)_"%"
I ACHSOBLS>0&(ACHS3PPS>0) S X=(ACHS3PPS/ACHSOBLS)*100 W ?71,$E(X,1,5)_"%"
I ACHSSER=4 W !?5,"*HOSP - ",ACHS43ST,"*",?25,"*DENT - ",ACHS57ST,"*",?45,"*OUTP - ",ACHS64ST,"*",?65,"*UNKN - ",ACHS0ST,"*"
S ACHS43T=ACHS43T+ACHS43ST,ACHS57T=ACHS57T+ACHS57ST,ACHS64T=ACHS64T+ACHS64ST,ACHS0T=ACHS0T+ACHS0ST
S ACHSOBLT=ACHSOBLT+ACHSOBLS,ACHSIHST=ACHSIHST+ACHSIHSS,ACHS3PPT=ACHS3PPT+ACHS3PPS,ACHSDOCT=ACHSDOCT+ACHSDOCS
K DIR
I IOST["C-",'$D(IO("S")) W !! I '$$DIR^XBDIR("E") D END Q
S (C,ACHSOBLS,ACHSIHSS,ACHS3PPS,ACHSDOCS,ACHSFLG,ACHS43ST,ACHS57ST,ACHS64ST,ACHS0ST)=0
Q
;
TOTL ;
W !!!!,$$REPEAT^XLFSTR("=",80),!!?1,"TOTAL",?9,$J(ACHSDOCT,4)
S X=ACHSOBLT,X2="2$"
D COMMA^%DTC
W ?40,$J(X,12)
S X=ACHSIHST,X2="2$"
D COMMA^%DTC
W ?53,$J(X,12)
S X=ACHS3PPT,X2="2$"
D COMMA^%DTC
W ?65,$J(X,12)
I ACHSOBLT>0&(ACHSIHST>0) W !! S Z=(ACHSIHST/ACHSOBLT)*100 W "PERCENTAGES OF PAYMENT TO OBLIGATED",?59,$E(Z,1,5)_"%"
I ACHSOBLT>0&(ACHS3PPT>0) S X=(ACHS3PPT/ACHSOBLT)*100 W ?71,$E(X,1,5)_"%"
I ACHSSER=4 W !?5,"*HOSP - ",ACHS43T,"*",?25,"*DENT - ",ACHS57T,"*",?45,"*OUTP - ",ACHS64T,"*",?65,"*UNKN - ",ACHS0T,"*"
K DIR
I IOST["C-",'$D(IO("S")) W !! I '$$DIR^XBDIR("E") D END Q
Q
;
END ;Close device, kill variables, quit
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
K ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDAT,ACHSDOC,ACHSDOCS,ACHSDOCT
K ACHSHRN,ACHSIDT,ACHSIHSP,ACHSIHSS,ACHSIHST,ACHSQIO
K ACHSOBL,ACHSOBLS,ACHSOBLT,ACHSPAT,ACHSSERV,ACHSTIM,ACHSUSR,C,Z,S,D,P
K ACHSFLG,ACHSOST,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
K ACHS64ST,ACHS64,ACHSPAGE,DIR,I,X,X2,Y,^TMP("ACHS3PP",$J)
Q
;
U IO
W @IOF
S ACHSPAGE=ACHSPAGE+1
;
S Y=$$HTE^XLFDT($H),ACHSDAT=$P(Y,"@",1),ACHSTIM=$P(Y,"@",2)
W !,"*",ACHSDAT
S X=$$LOC^ACHS
W ?((80/2)-($L(X)/2)),X
W ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*"
W !!
S X="3rd Party Payment Report - Page "
W ?((80/2)-($L(X)/2)),X_ACHSPAGE
W !
S X="For FISCAL YEAR: "
W ?((80/2)-($L(X)/2)),X_ACHSFY
W !,$$REPEAT^XLFSTR("*",80)
Q
;
W !!?5,"PATIENT NAME: ",ACHSPATP,?62,"CHART#: ",ACHSHRN
Q
;
W !!?1,"DOCUMENT #"
W:ACHSRTYP["D" ?22,"SERV",?30,"ISSUE DT"
W ?42,"$ OBLIGD $",?55,"$ IHS PMT $",?69,"$ 3P PMT $"
Q
;
NODATA ;
S ACHSPATP=$P($G(^DPT(ACHSPAT,0)),U)
S ACHSPATP=$P(ACHSPATP,",",2)_" "_$P(ACHSPATP,",",1)
W !!!,"NO DATA FOR SPECIFIED FISCAL YEAR FOR ",ACHSPATP
K ^TMP("ACHS3PP",$J,ACHSPAT)
W !!!!
D:'$$DIR^XBDIR("E") END
I $D(^TMP("ACHS3PP",$J)) Q
D:IOST["C-"&'$D(IO("S")) ^ACHS3PP5
Q
;
ACHS3PP2 ; IHS/ITSC/PMF - PRINT CHS THIRD PARTY PAYMENT REPORT - INDIVIDUAL PAT ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 ;TPF THIS IS A REWRITE OF ACHSPPB
+4 ;CALLED FROM ACHS3PP1
+5 ;
+6 DO BRPT^ACHSFU
+7 ;
+8 SET (ACHSOBL,ACHSOBLS,ACHSOBLT,ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDOCS)=0
+9 SET (ACHSDOCT,ACHSIHSP,ACHSIHSS,ACHSIHST,C,ACHSPAGE,ACHS43ST,ACHS57ST)=0
+10 SET (ACHS64ST,ACHS0ST,ACHS43T,ACHS57T,ACHS64T,ACHS0T)=0
+11 KILL ACHSPATP
+12 ;
+13 ;BEGIN INDIV. PATIENT LOOP
+14 SET ACHSPAT=""
+15 FOR
SET ACHSPAT=$ORDER(^TMP("ACHS3PP",$JOB,ACHSPAT))
IF ACHSPAT=""
QUIT
Begin DoDot:1
+16 SET ACHSPAGE=0
+17 IF '$ORDER(^TMP("ACHS3PP",$JOB,ACHSPAT,0))
DO HEADER
DO NODATA
+18 DO HEADER
+19 DO GETPAT
End DoDot:1
+20 DO TOTL
+21 QUIT
GETPAT ;
+1 ;I '$D(ACHSPAT(0))
+2 ;
+3 SET ACHSPATP=$SELECT($DATA(^DPT(ACHSPAT,0)):$PIECE($GET(^DPT(ACHSPAT,0)),U),1:"NO NAME")
+4 SET ACHSHRN=$SELECT($DATA(^AUPNPAT(ACHSPAT,41,DUZ(2),0)):$PIECE($GET(^AUPNPAT(ACHSPAT,41,DUZ(2),0)),U,2),1:"NO HRN")
DO HEADER1
+5 DO HEADER2
+6 ;
+7 SET ACHSDOC=0
+8 FOR
SET ACHSDOC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSPAT,ACHSDOC))
IF ACHSDOC=""
QUIT
Begin DoDot:1
+9 SET Z=$GET(^TMP("ACHS3PP",$JOB,ACHSPAT,ACHSDOC))
+10 SET D=$PIECE(Z,U,1)
SET ACHSIDT=$EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+11 SET S=$PIECE(Z,U,5)
SET ACHSSERV=$SELECT(S=1:"HOSP",S=2:"DENT",S=3:"OUTP",1:"UNKN")
+12 SET ACHSOBL=$PIECE(Z,U,2)
SET ACHS3PP=$PIECE(Z,U,3)
SET ACHSIHSP=$PIECE(Z,U,4)
+13 SET C=C+1
SET ACHSDOCS=C
PDATA ;Print the Data
+1 IF ACHSRTYP["D"
DO DETAIL
+2 ;
+3 IF IOST["P-"&($Y>56)
DO HEADER
+4 IF IOST["C-"
IF '$DATA(IO("S"))
IF $Y>24
DO HEADER
Begin DoDot:2
+5 IF '$$DIR^XBDIR("E")
DO END
QUIT
+6 DO HEADER
End DoDot:2
+7 SET ACHSOBLS=ACHSOBLS+ACHSOBL
SET ACHS3PPS=ACHS3PPS+ACHS3PP
SET ACHSIHSS=ACHSIHSS+ACHSIHSP
+8 IF ACHSSER=4
Begin DoDot:2
+9 IF S=1
SET ACHS43ST=ACHS43ST+1
+10 IF S=2
SET ACHS57ST=ACHS57ST+1
+11 IF S=3
SET ACHS64ST=ACHS64ST+1
+12 IF S'=1&(S'=2)&(S'=3)
SET ACHS0ST=ACHS0ST+1
End DoDot:2
+13 SET ACHSFLG=1
End DoDot:1
+14 DO SUBTOTL
+15 QUIT
+16 ;
DETAIL ;DETAIL LINE
+1 WRITE !?1,ACHSDOC,?22,ACHSSERV,?30,ACHSIDT,?40
+2 SET X=ACHSOBL
SET X2=2
+3 DO COMMA^%DTC
+4 WRITE $JUSTIFY(X,12),?53
+5 SET X=ACHSIHSP
SET X2=2
+6 DO COMMA^%DTC
+7 WRITE $JUSTIFY(X,12),?65
+8 SET X=ACHS3PP
SET X2=2
+9 DO COMMA^%DTC
+10 WRITE $JUSTIFY(X,11)
+11 QUIT
SUBTOTL ;
+1 WRITE !,$$REPEAT^XLFSTR("-",80),!?1,"SUBTOTAL",?4,$JUSTIFY(ACHSDOCS,4)
+2 SET X=ACHSOBLS
SET X2="2$"
+3 DO COMMA^%DTC
+4 WRITE ?40,$JUSTIFY(X,12)
+5 SET X=ACHSIHSS
SET X2="2$"
+6 DO COMMA^%DTC
+7 WRITE ?53,$JUSTIFY(X,12)
+8 SET X=ACHS3PPS
SET X2="2$"
+9 DO COMMA^%DTC
+10 WRITE ?65,$JUSTIFY(X,12)
+11 IF ACHSOBLS>0&(ACHSIHSS>0)
WRITE !!
SET Z=(ACHSIHSS/ACHSOBLS)*100
WRITE "PERCENTAGES OF PAYMENT TO OBLIGATED",?59,$EXTRACT(Z,1,5)_"%"
+12 IF ACHSOBLS>0&(ACHS3PPS>0)
SET X=(ACHS3PPS/ACHSOBLS)*100
WRITE ?71,$EXTRACT(X,1,5)_"%"
+13 IF ACHSSER=4
WRITE !?5,"*HOSP - ",ACHS43ST,"*",?25,"*DENT - ",ACHS57ST,"*",?45,"*OUTP - ",ACHS64ST,"*",?65,"*UNKN - ",ACHS0ST,"*"
+14 SET ACHS43T=ACHS43T+ACHS43ST
SET ACHS57T=ACHS57T+ACHS57ST
SET ACHS64T=ACHS64T+ACHS64ST
SET ACHS0T=ACHS0T+ACHS0ST
+15 SET ACHSOBLT=ACHSOBLT+ACHSOBLS
SET ACHSIHST=ACHSIHST+ACHSIHSS
SET ACHS3PPT=ACHS3PPT+ACHS3PPS
SET ACHSDOCT=ACHSDOCT+ACHSDOCS
+16 KILL DIR
+17 IF IOST["C-"
IF '$DATA(IO("S"))
WRITE !!
IF '$$DIR^XBDIR("E")
DO END
QUIT
+18 SET (C,ACHSOBLS,ACHSIHSS,ACHS3PPS,ACHSDOCS,ACHSFLG,ACHS43ST,ACHS57ST,ACHS64ST,ACHS0ST)=0
+19 QUIT
+20 ;
TOTL ;
+1 WRITE !!!!,$$REPEAT^XLFSTR("=",80),!!?1,"TOTAL",?9,$JUSTIFY(ACHSDOCT,4)
+2 SET X=ACHSOBLT
SET X2="2$"
+3 DO COMMA^%DTC
+4 WRITE ?40,$JUSTIFY(X,12)
+5 SET X=ACHSIHST
SET X2="2$"
+6 DO COMMA^%DTC
+7 WRITE ?53,$JUSTIFY(X,12)
+8 SET X=ACHS3PPT
SET X2="2$"
+9 DO COMMA^%DTC
+10 WRITE ?65,$JUSTIFY(X,12)
+11 IF ACHSOBLT>0&(ACHSIHST>0)
WRITE !!
SET Z=(ACHSIHST/ACHSOBLT)*100
WRITE "PERCENTAGES OF PAYMENT TO OBLIGATED",?59,$EXTRACT(Z,1,5)_"%"
+12 IF ACHSOBLT>0&(ACHS3PPT>0)
SET X=(ACHS3PPT/ACHSOBLT)*100
WRITE ?71,$EXTRACT(X,1,5)_"%"
+13 IF ACHSSER=4
WRITE !?5,"*HOSP - ",ACHS43T,"*",?25,"*DENT - ",ACHS57T,"*",?45,"*OUTP - ",ACHS64T,"*",?65,"*UNKN - ",ACHS0T,"*"
+14 KILL DIR
+15 IF IOST["C-"
IF '$DATA(IO("S"))
WRITE !!
IF '$$DIR^XBDIR("E")
DO END
QUIT
+16 QUIT
+17 ;
END ;Close device, kill variables, quit
+1 DO ^%ZISC
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 KILL ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDAT,ACHSDOC,ACHSDOCS,ACHSDOCT
+4 KILL ACHSHRN,ACHSIDT,ACHSIHSP,ACHSIHSS,ACHSIHST,ACHSQIO
+5 KILL ACHSOBL,ACHSOBLS,ACHSOBLT,ACHSPAT,ACHSSERV,ACHSTIM,ACHSUSR,C,Z,S,D,P
+6 KILL ACHSFLG,ACHSOST,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
+7 KILL ACHS64ST,ACHS64,ACHSPAGE,DIR,I,X,X2,Y,^TMP("ACHS3PP",$JOB)
+8 QUIT
+9 ;
+1 USE IO
+2 WRITE @IOF
+3 SET ACHSPAGE=ACHSPAGE+1
+4 ;
+5 SET Y=$$HTE^XLFDT($HOROLOG)
SET ACHSDAT=$PIECE(Y,"@",1)
SET ACHSTIM=$PIECE(Y,"@",2)
+6 WRITE !,"*",ACHSDAT
+7 SET X=$$LOC^ACHS
+8 WRITE ?((80/2)-($LENGTH(X)/2)),X
+9 WRITE ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*"
+10 WRITE !!
+11 SET X="3rd Party Payment Report - Page "
+12 WRITE ?((80/2)-($LENGTH(X)/2)),X_ACHSPAGE
+13 WRITE !
+14 SET X="For FISCAL YEAR: "
+15 WRITE ?((80/2)-($LENGTH(X)/2)),X_ACHSFY
+16 WRITE !,$$REPEAT^XLFSTR("*",80)
+17 QUIT
+18 ;
+1 WRITE !!?5,"PATIENT NAME: ",ACHSPATP,?62,"CHART#: ",ACHSHRN
+2 QUIT
+3 ;
+1 WRITE !!?1,"DOCUMENT #"
+2 IF ACHSRTYP["D"
WRITE ?22,"SERV",?30,"ISSUE DT"
+3 WRITE ?42,"$ OBLIGD $",?55,"$ IHS PMT $",?69,"$ 3P PMT $"
+4 QUIT
+5 ;
NODATA ;
+1 SET ACHSPATP=$PIECE($GET(^DPT(ACHSPAT,0)),U)
+2 SET ACHSPATP=$PIECE(ACHSPATP,",",2)_" "_$PIECE(ACHSPATP,",",1)
+3 WRITE !!!,"NO DATA FOR SPECIFIED FISCAL YEAR FOR ",ACHSPATP
+4 KILL ^TMP("ACHS3PP",$JOB,ACHSPAT)
+5 WRITE !!!!
+6 IF '$$DIR^XBDIR("E")
DO END
+7 IF $DATA(^TMP("ACHS3PP",$JOB))
QUIT
+8 IF IOST["C-"&'$DATA(IO("S"))
DO ^ACHS3PP5
+9 QUIT
+10 ;
