ACHS3PPT ; IHS/OIT/FCJ - PRINT THIRD PARTY PAYMENT REPORT ALL PATIENTS BY INS ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**16**;JUN 11, 2001
;NEW ROUTINE FOR PATCH 16
;
;
S ACHSBM=22
P1 ;
S ACHSFAC="" F S ACHSFAC=$O(^TMP("ACHS3PP",$J,ACHSFAC)) G:ACHSFAC="" TOTL D Q:$D(DUOUT)
.S ACHSINS="",ACHSPAGE=0,ACHSFLG1=0 D HEADER
.F ACHSX="I","U","T" D Q:$D(DUOUT)
..S ACHSFLG=1,ACHSDOC="",ACHSFLG1=1
..S (ACHSINSP,ACHSINSS,ACHSOBLT,ACHS3PPT,ACHSIHST,ACHSINSX,ACHSDOCT)=0
..I ACHSX="T" D P2 Q
..F S ACHSDOC=$O(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSDOC)) Q:ACHSDOC="" D Q:$D(DUOUT)
...S ACHSINST=0
...S Z=$G(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC))
...S Z1=$G(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSDOC))
...S ACHSINS=$S(ACHSX="U":"UNIDENTIFIED INSURANCE",1:"IHS ONLY PAY")
...S (ACHSINSP,ACHSINST)=^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSDOC)
...I ACHSX="I",$P(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC),U,3)>0 Q
...D DETAIL D:ACHSRTYP="P" PRT
..Q:$D(DUOUT)
..S ACHSFLG1=0 D TOT2
Q
P2 ;
S ACHSI="",ACHSINST=0
F S ACHSI=$O(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSI)) Q:ACHSI'?1N.N D Q:$D(DUOUT)
.S ACHSDOC="",ACHSINSP="",ACHSFLG1=1,(ACHSDOCT,ACHSOBLT,ACHSIHST,ACHSINSX)=0
.S ACHSINS=$P(^AUTNINS($P(ACHSI,U),0),U)
.F S ACHSDOC=$O(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSI,ACHSDOC)) Q:ACHSDOC="" D Q:$D(DUOUT)
..S Z=$G(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC))
..S ACHSINSP=^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSI,ACHSDOC)
..S ACHSINST=ACHSINST+$P(^TMP("ACHS3PP",$J,ACHSFAC,ACHSX,ACHSI,ACHSDOC),U)
..D DETAIL D:ACHSRTYP="P" PRT
.Q:$D(DUOUT)
.S ACHSFLG1=0 D TOT2
Q
;
DETAIL ;
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,ACHSFLG=1,ACHSDOCT=ACHSDOCT+1
S ACHSOBLS=ACHSOBLS+ACHSOBL,ACHS3PPS=ACHS3PPS+ACHS3PP,ACHSIHSS=ACHSIHSS+ACHSIHSP,ACHSINSS=ACHSINSS+ACHSINST
S ACHSOBLT=ACHSOBLT+ACHSOBL,ACHS3PPT=ACHS3PPT+ACHS3PP,ACHSIHST=ACHSIHST+ACHSIHSP,ACHSINSX=ACHSINSX+ACHSINSP
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
Q
PRT ;Prints Data
W:ACHSFLG1=1 !!,ACHSINS S ACHSFLG1=0
D
. W !?1,ACHSDOC,?15,ACHSSERV,?23,ACHSIDT,?40
. S X=ACHSOBL,X2=2
. D COMMA^%DTC
. W $J(X,12),?55
. S X=ACHSIHSP,X2=2
. D COMMA^%DTC
. W $J(X,12),?68
. S X=$S(ACHSX="I":ACHS3PP,1:ACHSINSP),X2=2
. D COMMA^%DTC
. W $J(X,12)
I IOST["P-",$Y>ACHSBM S ACHSFLG=0,ACHSFLG1=1 D HEADER
I IOST["C-",'$D(IO("S")),$Y>ACHSBM G END:'$$DIR^XBDIR("E") S ACHSFLG=0,ACHSFLG1=1 D HEADER
Q
;
TOT2 ;
W:ACHSRTYP="P" !!,$$REPEAT^XLFSTR("-",80)
W:ACHSRTYP="T" !!,ACHSINS
W !?1,"TOTAL",?10,$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 ?55,$J(X,12)
S X=$S(ACHSX="I":ACHS3PPT,1:ACHSINSX),X2="2$"
D COMMA^%DTC
W ?68,$J(X,12)
K DIR
I IOST["C-",'$D(IO("S")),$Y>ACHSBM W !! G END:'$$DIR^XBDIR("E") D HEADER
S ACHSFLG1=0 D:ACHSRTYP="P" HEADER
Q
TOTL ;
W !!,$$REPEAT^XLFSTR("-",80),!?1,"TOTAL",?10,$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 ?55,$J(X,12)
S X=ACHS3PPS,X2="2$"
D COMMA^%DTC
W ?68,$J(X,12)
I ACHSOBLS>0&(ACHSIHSS>0) W !! S Z=(ACHSIHSS/ACHSOBLS)*100 W "PERCENTAGE OF PAYMENT TO OBLIGATED",?61,$E(Z,1,5)_"%"
I ACHSOBLS>0&(ACHS3PPS>0) S X=(ACHS3PPS/ACHSOBLS)*100 W ?74,$E(X,1,5)_"%"
I ACHSSER=4 W !?5,"*HOSP - ",ACHS43ST,"*",?25,"*DENT - ",ACHS57ST,"*",?45,"*OUTP - ",ACHS64ST,"*",?65,"*UNKN - ",ACHS0ST,"*"
K DIR
I IOST["C-",'$D(IO("S")) W !! G END:'$$DIR^XBDIR("E")
END ;Close device, kill variables, quit
S:$D(ZTQUEUED) ZTREQ="@"
D ^%ZISC
K ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDAT,ACHSDOC,ACHSDOCS,ACHSDOCT
K ACHSHRN,ACHSIDT,ACHSIHSP,ACHSIHSS,ACHSIHST,ACHSQIO,ACHS0ST
K ACHSOBL,ACHSOBLS,ACHSOBLT,ACHSPAT,ACHSSERP,ACHSSERV,ACHSTIM,ACHSUSR,C,Z,S,D,P
K ACHSFLG,ACHSFLG1,ACHSPAGE,DIR,I,X,X2,Y,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
K ACHS64ST,ACHS64T,ACHSSER
K ACHSI,ACHSINS,ACHSINSS,ACHSINST,ACHSRTYP,ACHSX
K ^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 !
I ACHSSER'=4 S ACHSSERP=$S(ACHSSER=1:"HOSPITAL",ACHSSER=2:"DENTAL",ACHSSER=3:"OUTPATIENT",1:"UNKNOWN") W ?33,"SERVICE: "_ACHSSERP W !
W $$REPEAT^XLFSTR("*",80)
S ACHSFLG=0
;
W !! W:ACHSRTYP["T" "PAYOR"
W:ACHSRTYP["P" ?1,"DOCUMENT #",?15,"SERV",?23,"ISSUE DT"
W ?41,"$ OBLIGD $",?55,"$ IHS PMT $",?70,"$ 3P PMT $"
W:ACHSFLG1=1 !,ACHSINS S ACHSFLG1=0
Q
;
NODATA ;
W !!!,"NO DATA FOR SPECIFIED FISCAL YEAR"
K ^TMP("ACHS3PP",$J)
I $D(ACHSSERP) W " FOR "_ACHSSERP_" SERVICE(S)" W !!!!
I IOST["C-",'$D(IO("S")) G:'$$DIR^XBDIR("E") END G ^ACHS3PPQ
G END
;
ACHS3PPT ; IHS/OIT/FCJ - PRINT THIRD PARTY PAYMENT REPORT ALL PATIENTS BY INS ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**16**;JUN 11, 2001
+2 ;NEW ROUTINE FOR PATCH 16
+3 ;
+4 ;
+5 SET ACHSBM=22
P1 ;
+1 SET ACHSFAC=""
FOR
SET ACHSFAC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC))
IF ACHSFAC=""
GOTO TOTL
Begin DoDot:1
+2 SET ACHSINS=""
SET ACHSPAGE=0
SET ACHSFLG1=0
DO HEADER
+3 FOR ACHSX="I","U","T"
Begin DoDot:2
+4 SET ACHSFLG=1
SET ACHSDOC=""
SET ACHSFLG1=1
+5 SET (ACHSINSP,ACHSINSS,ACHSOBLT,ACHS3PPT,ACHSIHST,ACHSINSX,ACHSDOCT)=0
+6 IF ACHSX="T"
DO P2
QUIT
+7 FOR
SET ACHSDOC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSDOC))
IF ACHSDOC=""
QUIT
Begin DoDot:3
+8 SET ACHSINST=0
+9 SET Z=$GET(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC))
+10 SET Z1=$GET(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSDOC))
+11 SET ACHSINS=$SELECT(ACHSX="U":"UNIDENTIFIED INSURANCE",1:"IHS ONLY PAY")
+12 SET (ACHSINSP,ACHSINST)=^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSDOC)
+13 IF ACHSX="I"
IF $PIECE(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC),U,3)>0
QUIT
+14 DO DETAIL
IF ACHSRTYP="P"
DO PRT
End DoDot:3
IF $DATA(DUOUT)
QUIT
+15 IF $DATA(DUOUT)
QUIT
+16 SET ACHSFLG1=0
DO TOT2
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
IF $DATA(DUOUT)
QUIT
+17 QUIT
P2 ;
+1 SET ACHSI=""
SET ACHSINST=0
+2 FOR
SET ACHSI=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSI))
IF ACHSI'?1N.N
QUIT
Begin DoDot:1
+3 SET ACHSDOC=""
SET ACHSINSP=""
SET ACHSFLG1=1
SET (ACHSDOCT,ACHSOBLT,ACHSIHST,ACHSINSX)=0
+4 SET ACHSINS=$PIECE(^AUTNINS($PIECE(ACHSI,U),0),U)
+5 FOR
SET ACHSDOC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSI,ACHSDOC))
IF ACHSDOC=""
QUIT
Begin DoDot:2
+6 SET Z=$GET(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC))
+7 SET ACHSINSP=^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSI,ACHSDOC)
+8 SET ACHSINST=ACHSINST+$PIECE(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSX,ACHSI,ACHSDOC),U)
+9 DO DETAIL
IF ACHSRTYP="P"
DO PRT
End DoDot:2
IF $DATA(DUOUT)
QUIT
+10 IF $DATA(DUOUT)
QUIT
+11 SET ACHSFLG1=0
DO TOT2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+12 QUIT
+13 ;
DETAIL ;
+1 SET D=$PIECE(Z,U,1)
SET ACHSIDT=$EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+2 SET S=$PIECE(Z,U,5)
SET ACHSSERV=$SELECT(S=1:"HOSP",S=2:"DENT",S=3:"OUTP",1:"UNKN")
+3 SET ACHSOBL=$PIECE(Z,U,2)
SET ACHS3PP=$PIECE(Z,U,3)
SET ACHSIHSP=$PIECE(Z,U,4)
+4 SET C=C+1
SET ACHSDOCS=C
SET ACHSFLG=1
SET ACHSDOCT=ACHSDOCT+1
+5 SET ACHSOBLS=ACHSOBLS+ACHSOBL
SET ACHS3PPS=ACHS3PPS+ACHS3PP
SET ACHSIHSS=ACHSIHSS+ACHSIHSP
SET ACHSINSS=ACHSINSS+ACHSINST
+6 SET ACHSOBLT=ACHSOBLT+ACHSOBL
SET ACHS3PPT=ACHS3PPT+ACHS3PP
SET ACHSIHST=ACHSIHST+ACHSIHSP
SET ACHSINSX=ACHSINSX+ACHSINSP
+7 IF ACHSSER=4
Begin DoDot:1
+8 IF S=1
SET ACHS43ST=ACHS43ST+1
+9 IF S=2
SET ACHS57ST=ACHS57ST+1
+10 IF S=3
SET ACHS64ST=ACHS64ST+1
+11 IF S'=1&(S'=2)&(S'=3)
SET ACHS0ST=ACHS0ST+1
End DoDot:1
+12 QUIT
PRT ;Prints Data
+1 IF ACHSFLG1=1
WRITE !!,ACHSINS
SET ACHSFLG1=0
+2 Begin DoDot:1
+3 WRITE !?1,ACHSDOC,?15,ACHSSERV,?23,ACHSIDT,?40
+4 SET X=ACHSOBL
SET X2=2
+5 DO COMMA^%DTC
+6 WRITE $JUSTIFY(X,12),?55
+7 SET X=ACHSIHSP
SET X2=2
+8 DO COMMA^%DTC
+9 WRITE $JUSTIFY(X,12),?68
+10 SET X=$SELECT(ACHSX="I":ACHS3PP,1:ACHSINSP)
SET X2=2
+11 DO COMMA^%DTC
+12 WRITE $JUSTIFY(X,12)
End DoDot:1
+13 IF IOST["P-"
IF $Y>ACHSBM
SET ACHSFLG=0
SET ACHSFLG1=1
DO HEADER
+14 IF IOST["C-"
IF '$DATA(IO("S"))
IF $Y>ACHSBM
IF '$$DIR^XBDIR("E")
GOTO END
SET ACHSFLG=0
SET ACHSFLG1=1
DO HEADER
+15 QUIT
+16 ;
TOT2 ;
+1 IF ACHSRTYP="P"
WRITE !!,$$REPEAT^XLFSTR("-",80)
+2 IF ACHSRTYP="T"
WRITE !!,ACHSINS
+3 WRITE !?1,"TOTAL",?10,$JUSTIFY(ACHSDOCT,4)
+4 SET X=ACHSOBLT
SET X2="2$"
+5 DO COMMA^%DTC
+6 WRITE ?40,$JUSTIFY(X,12)
+7 SET X=ACHSIHST
SET X2="2$"
+8 DO COMMA^%DTC
+9 WRITE ?55,$JUSTIFY(X,12)
+10 SET X=$SELECT(ACHSX="I":ACHS3PPT,1:ACHSINSX)
SET X2="2$"
+11 DO COMMA^%DTC
+12 WRITE ?68,$JUSTIFY(X,12)
+13 KILL DIR
+14 IF IOST["C-"
IF '$DATA(IO("S"))
IF $Y>ACHSBM
WRITE !!
IF '$$DIR^XBDIR("E")
GOTO END
DO HEADER
+15 SET ACHSFLG1=0
IF ACHSRTYP="P"
DO HEADER
+16 QUIT
TOTL ;
+1 WRITE !!,$$REPEAT^XLFSTR("-",80),!?1,"TOTAL",?10,$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 ?55,$JUSTIFY(X,12)
+8 SET X=ACHS3PPS
SET X2="2$"
+9 DO COMMA^%DTC
+10 WRITE ?68,$JUSTIFY(X,12)
+11 IF ACHSOBLS>0&(ACHSIHSS>0)
WRITE !!
SET Z=(ACHSIHSS/ACHSOBLS)*100
WRITE "PERCENTAGE OF PAYMENT TO OBLIGATED",?61,$EXTRACT(Z,1,5)_"%"
+12 IF ACHSOBLS>0&(ACHS3PPS>0)
SET X=(ACHS3PPS/ACHSOBLS)*100
WRITE ?74,$EXTRACT(X,1,5)_"%"
+13 IF ACHSSER=4
WRITE !?5,"*HOSP - ",ACHS43ST,"*",?25,"*DENT - ",ACHS57ST,"*",?45,"*OUTP - ",ACHS64ST,"*",?65,"*UNKN - ",ACHS0ST,"*"
+14 KILL DIR
+15 IF IOST["C-"
IF '$DATA(IO("S"))
WRITE !!
IF '$$DIR^XBDIR("E")
GOTO END
END ;Close device, kill variables, quit
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 DO ^%ZISC
+3 KILL ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDAT,ACHSDOC,ACHSDOCS,ACHSDOCT
+4 KILL ACHSHRN,ACHSIDT,ACHSIHSP,ACHSIHSS,ACHSIHST,ACHSQIO,ACHS0ST
+5 KILL ACHSOBL,ACHSOBLS,ACHSOBLT,ACHSPAT,ACHSSERP,ACHSSERV,ACHSTIM,ACHSUSR,C,Z,S,D,P
+6 KILL ACHSFLG,ACHSFLG1,ACHSPAGE,DIR,I,X,X2,Y,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
+7 KILL ACHS64ST,ACHS64T,ACHSSER
+8 KILL ACHSI,ACHSINS,ACHSINSS,ACHSINST,ACHSRTYP,ACHSX
+9 KILL ^TMP("ACHS3PP",$JOB)
+10 QUIT
+11 ;
+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 !
+16 IF ACHSSER'=4
SET ACHSSERP=$SELECT(ACHSSER=1:"HOSPITAL",ACHSSER=2:"DENTAL",ACHSSER=3:"OUTPATIENT",1:"UNKNOWN")
WRITE ?33,"SERVICE: "_ACHSSERP
WRITE !
+17 WRITE $$REPEAT^XLFSTR("*",80)
+18 SET ACHSFLG=0
+19 ;
+1 WRITE !!
IF ACHSRTYP["T"
WRITE "PAYOR"
+2 IF ACHSRTYP["P"
WRITE ?1,"DOCUMENT #",?15,"SERV",?23,"ISSUE DT"
+3 WRITE ?41,"$ OBLIGD $",?55,"$ IHS PMT $",?70,"$ 3P PMT $"
+4 IF ACHSFLG1=1
WRITE !,ACHSINS
SET ACHSFLG1=0
+5 QUIT
+6 ;
NODATA ;
+1 WRITE !!!,"NO DATA FOR SPECIFIED FISCAL YEAR"
+2 KILL ^TMP("ACHS3PP",$JOB)
+3 IF $DATA(ACHSSERP)
WRITE " FOR "_ACHSSERP_" SERVICE(S)"
WRITE !!!!
+4 IF IOST["C-"
IF '$DATA(IO("S"))
IF '$$DIR^XBDIR("E")
GOTO END
GOTO ^ACHS3PPQ
+5 GOTO END
+6 ;
