ACHS3PPB ; IHS/ITSC/TPF/PMF - PRINT CHS THIRD PARTY PAYMENT REPORT - INDIVIDUAL PAT ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**16**;JUN 11, 2001
;ACHS*3.1*16 IHS.OIT.FCJ FIXED LOOP AND EXIT PROBLEM
;
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
P1 ;
S ACHSPAT=""
;ACHS*3.1*16 IHS.OIT.FCJ ADDED DUOUT TEST TO NXT LINE
F S ACHSPAT=$O(^TMP("ACHS3PP",$J,ACHSPAT)) Q:ACHSPAT="" D G:$D(DUOUT) END
.I $D(^TMP("ACHS3PP",$J,ACHSPAT,0)) D HEADER D NODATA
.S ACHSPAGE=0
.D HEADER
.D GETPAT
D TOTL ;ACHS*3.1*16 IHS.OIT.FCJ ADDED LINE
Q
GETPAT ;
I '$D(ACHSPAT(0)) D
.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(^DPT(ACHSPAT,0)),U,2),1:"NO HRN")
.D HEADER1
D P2
Q
;
P2 ;
S ACHSDOC=""
D HEADER2
;
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)
.S ACHSIDT=$E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
.S S=$P(Z,U,5)
.S ACHSSERV=$S(S=1:"HOSP",S=2:"DENT",S=3:"OUTP",1:"UNKN")
.S ACHSOBL=$P(Z,U,2)
.S ACHS3PP=$P(Z,U,3)
.S ACHSIHSP=$P(Z,U,4)
.S C=C+1,ACHSDOCS=C
.D PDATA
D SUBTOTL ;ACHS*3.1*16 IHS.OIT.FCJ REMOVED . AND CHANGED TO SUBTOTAL
Q
;
PDATA ;Prints Data
I ACHSRTYP["D" D
. 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)
;
I IOST["P-"&($Y>56) D HEADER
I IOST["C-",'$D(IO("S")),$Y>24 G END:'$$DIR^XBDIR("E") 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
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 !! G END:'$$DIR^XBDIR("E")
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 !! G END:'$$DIR^XBDIR("E")
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,1),ACHSPATP=$P(ACHSPATP,",",2)_" "_$P(ACHSPATP,",",1)
W !!!,"NO DATA FOR SPECIFIED FISCAL YEAR FOR ",ACHSPATP
K ^TMP("ACHS3PP",$J,ACHSPAT)
W !!!!
I '$$DIR^XBDIR("E") D END Q
D:IOST["C-"&'$D(IO("S")) ^ACHS3PPQ
Q
;
ACHS3PPB ; IHS/ITSC/TPF/PMF - PRINT CHS THIRD PARTY PAYMENT REPORT - INDIVIDUAL PAT ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**16**;JUN 11, 2001
+2 ;ACHS*3.1*16 IHS.OIT.FCJ FIXED LOOP AND EXIT PROBLEM
+3 ;
+4 DO BRPT^ACHSFU
+5 SET (ACHSOBL,ACHSOBLS,ACHSOBLT,ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDOCS)=0
+6 SET (ACHSDOCT,ACHSIHSP,ACHSIHSS,ACHSIHST,C,ACHSPAGE,ACHS43ST,ACHS57ST)=0
+7 SET (ACHS64ST,ACHS0ST,ACHS43T,ACHS57T,ACHS64T,ACHS0T)=0
+8 KILL ACHSPATP
P1 ;
+1 SET ACHSPAT=""
+2 ;ACHS*3.1*16 IHS.OIT.FCJ ADDED DUOUT TEST TO NXT LINE
+3 FOR
SET ACHSPAT=$ORDER(^TMP("ACHS3PP",$JOB,ACHSPAT))
IF ACHSPAT=""
QUIT
Begin DoDot:1
+4 IF $DATA(^TMP("ACHS3PP",$JOB,ACHSPAT,0))
DO HEADER
DO NODATA
+5 SET ACHSPAGE=0
+6 DO HEADER
+7 DO GETPAT
End DoDot:1
IF $DATA(DUOUT)
GOTO END
+8 ;ACHS*3.1*16 IHS.OIT.FCJ ADDED LINE
DO TOTL
+9 QUIT
GETPAT ;
+1 IF '$DATA(ACHSPAT(0))
Begin DoDot:1
+2 SET ACHSPATP=$SELECT($DATA(^DPT(ACHSPAT,0)):$PIECE($GET(^DPT(ACHSPAT,0)),U),1:"NO NAME")
+3 SET ACHSHRN=$SELECT($DATA(^AUPNPAT(ACHSPAT,41,DUZ(2),0)):$PIECE($GET(^DPT(ACHSPAT,0)),U,2),1:"NO HRN")
+4 DO HEADER1
End DoDot:1
+5 DO P2
+6 QUIT
+7 ;
P2 ;
+1 SET ACHSDOC=""
+2 DO HEADER2
+3 ;
+4 FOR
SET ACHSDOC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSPAT,ACHSDOC))
IF ACHSDOC=""
QUIT
Begin DoDot:1
+5 SET Z=$GET(^TMP("ACHS3PP",$JOB,ACHSPAT,ACHSDOC))
+6 SET D=$PIECE(Z,U,1)
+7 SET ACHSIDT=$EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+8 SET S=$PIECE(Z,U,5)
+9 SET ACHSSERV=$SELECT(S=1:"HOSP",S=2:"DENT",S=3:"OUTP",1:"UNKN")
+10 SET ACHSOBL=$PIECE(Z,U,2)
+11 SET ACHS3PP=$PIECE(Z,U,3)
+12 SET ACHSIHSP=$PIECE(Z,U,4)
+13 SET C=C+1
SET ACHSDOCS=C
+14 DO PDATA
End DoDot:1
+15 ;ACHS*3.1*16 IHS.OIT.FCJ REMOVED . AND CHANGED TO SUBTOTAL
DO SUBTOTL
+16 QUIT
+17 ;
PDATA ;Prints Data
+1 IF ACHSRTYP["D"
Begin DoDot:1
+2 WRITE !?1,ACHSDOC,?22,ACHSSERV,?30,ACHSIDT,?40
+3 SET X=ACHSOBL
SET X2=2
+4 DO COMMA^%DTC
+5 WRITE $JUSTIFY(X,12),?53
+6 SET X=ACHSIHSP
SET X2=2
+7 DO COMMA^%DTC
+8 WRITE $JUSTIFY(X,12),?65
+9 SET X=ACHS3PP
SET X2=2
+10 DO COMMA^%DTC
+11 WRITE $JUSTIFY(X,11)
End DoDot:1
+12 ;
+13 IF IOST["P-"&($Y>56)
DO HEADER
+14 IF IOST["C-"
IF '$DATA(IO("S"))
IF $Y>24
IF '$$DIR^XBDIR("E")
GOTO END
DO HEADER
+15 SET ACHSOBLS=ACHSOBLS+ACHSOBL
SET ACHS3PPS=ACHS3PPS+ACHS3PP
SET ACHSIHSS=ACHSIHSS+ACHSIHSP
+16 IF ACHSSER=4
Begin DoDot:1
+17 IF S=1
SET ACHS43ST=ACHS43ST+1
+18 IF S=2
SET ACHS57ST=ACHS57ST+1
+19 IF S=3
SET ACHS64ST=ACHS64ST+1
+20 IF S'=1&(S'=2)&(S'=3)
SET ACHS0ST=ACHS0ST+1
End DoDot:1
+21 ;
+22 SET ACHSFLG=1
+23 QUIT
+24 ;
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 ;
+12 IF ACHSOBLS>0&(ACHSIHSS>0)
WRITE !!
SET Z=(ACHSIHSS/ACHSOBLS)*100
WRITE "PERCENTAGES OF PAYMENT TO OBLIGATED",?59,$EXTRACT(Z,1,5)_"%"
+13 ;
+14 IF ACHSOBLS>0&(ACHS3PPS>0)
SET X=(ACHS3PPS/ACHSOBLS)*100
WRITE ?71,$EXTRACT(X,1,5)_"%"
+15 ;
+16 IF ACHSSER=4
WRITE !?5,"*HOSP - ",ACHS43ST,"*",?25,"*DENT - ",ACHS57ST,"*",?45,"*OUTP - ",ACHS64ST,"*",?65,"*UNKN - ",ACHS0ST,"*"
+17 ;
+18 SET ACHS43T=ACHS43T+ACHS43ST
SET ACHS57T=ACHS57T+ACHS57ST
SET ACHS64T=ACHS64T+ACHS64ST
SET ACHS0T=ACHS0T+ACHS0ST
+19 ;
+20 SET ACHSOBLT=ACHSOBLT+ACHSOBLS
SET ACHSIHST=ACHSIHST+ACHSIHSS
SET ACHS3PPT=ACHS3PPT+ACHS3PPS
SET ACHSDOCT=ACHSDOCT+ACHSDOCS
+21 ;
+22 KILL DIR
+23 IF IOST["C-"
IF '$DATA(IO("S"))
WRITE !!
IF '$$DIR^XBDIR("E")
GOTO END
+24 SET (C,ACHSOBLS,ACHSIHSS,ACHS3PPS,ACHSDOCS,ACHSFLG,ACHS43ST,ACHS57ST,ACHS64ST,ACHS0ST)=0
+25 QUIT
+26 ;
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 ;
+12 IF ACHSOBLT>0&(ACHSIHST>0)
WRITE !!
SET Z=(ACHSIHST/ACHSOBLT)*100
WRITE "PERCENTAGES OF PAYMENT TO OBLIGATED",?59,$EXTRACT(Z,1,5)_"%"
+13 ;
+14 IF ACHSOBLT>0&(ACHS3PPT>0)
SET X=(ACHS3PPT/ACHSOBLT)*100
WRITE ?71,$EXTRACT(X,1,5)_"%"
+15 ;
+16 IF ACHSSER=4
WRITE !?5,"*HOSP - ",ACHS43T,"*",?25,"*DENT - ",ACHS57T,"*",?45,"*OUTP - ",ACHS64T,"*",?65,"*UNKN - ",ACHS0T,"*"
+17 ;
+18 KILL DIR
+19 IF IOST["C-"
IF '$DATA(IO("S"))
WRITE !!
IF '$$DIR^XBDIR("E")
GOTO END
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 SET Y=$$HTE^XLFDT($HOROLOG)
SET ACHSDAT=$PIECE(Y,"@",1)
SET ACHSTIM=$PIECE(Y,"@",2)
+5 WRITE !,"*",ACHSDAT
+6 SET X=$$LOC^ACHS
+7 WRITE ?((80/2)-($LENGTH(X)/2)),X
+8 WRITE ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*"
+9 WRITE !!
+10 SET X="3rd Party Payment Report - Page "
+11 WRITE ?((80/2)-($LENGTH(X)/2)),X_ACHSPAGE
+12 WRITE !
+13 SET X="For FISCAL YEAR: "
+14 WRITE ?((80/2)-($LENGTH(X)/2)),X_ACHSFY
+15 WRITE !,$$REPEAT^XLFSTR("*",80)
+16 QUIT
+17 ;
+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,1)
SET ACHSPATP=$PIECE(ACHSPATP,",",2)_" "_$PIECE(ACHSPATP,",",1)
+2 WRITE !!!,"NO DATA FOR SPECIFIED FISCAL YEAR FOR ",ACHSPATP
+3 KILL ^TMP("ACHS3PP",$JOB,ACHSPAT)
+4 WRITE !!!!
+5 IF '$$DIR^XBDIR("E")
DO END
QUIT
+6 IF IOST["C-"&'$DATA(IO("S"))
DO ^ACHS3PPQ
+7 QUIT
+8 ;
