ACHS3PP4 ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
;TPF COPIED AND RE-WRITTEN FROM ACHS3PPP
;
D BRPT^ACHSFU
I $O(^TMP("ACHS3PP",$J,ACHSFAC,0))="" S ACHSPAGE=0 D HEADER,NODATA Q
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
N OK S OK=1
;
S ACHSFAC=""
F S ACHSFAC=$O(^TMP("ACHS3PP",$J,ACHSFAC)) Q:ACHSFAC="" D P2 I 'OK Q
I 'OK D END Q
D TOTL
Q
;
P2 ;
S ACHSDOC="",ACHSPAGE=0 D HEADER
;
F S ACHSDOC=$O(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC)) Q:ACHSDOC="" D Q:'OK
.S Z=$G(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC))
.Q:Z=""
.;
.I $D(ACHSPAT) S P=$S($P(Z,U,7):$P(Z,U,7),1:"NO NAME") S:$D(^DPT(P,0)) ACHSPAT=$P($G(^DPT(P,0)),U,1) S ACHSHRN=$S($P(Z,U,8):$P(Z,U,8),1:"NO HRN") D PATHEAD
. I ACHSFLG=0 D HEADER1
. D GETIDT
Q
;
GETIDT ;
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 S(S)=""
S ACHSOBL=$P(Z,U,2),ACHS3PP=$P(Z,U,3),ACHSIHSP=$P(Z,U,4)
S C=C+1,ACHSDOCS=C,ACHSFLG=1
;Prints Data
I ACHSRTYP["D" 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=ACHS3PP,X2=2
. D COMMA^%DTC
. W $J(X,12)
. Q
I IOST["P-",$Y>ACHSBM S ACHSFLG=0 D HEADER
I IOST["C-",'$D(IO("S")),$Y>ACHSBM D Q:'OK
. S OK=$$DIR^XBDIR("E")
. I 'OK Q
. S ACHSFLG=0 D HEADER
. Q
;
S ACHSOBLS=ACHSOBLS+ACHSOBL,ACHS3PPS=ACHS3PPS+ACHS3PP,ACHSIHSS=ACHSIHSS+ACHSIHSP
I ACHSSER=4 D
. I S=1 S ACHS43ST=ACHS43ST+1 Q
. I S=2 S ACHS57ST=ACHS57ST+1 Q
. I S=3 S ACHS64ST=ACHS64ST+1 Q
. ;I S'=1&(S'=2)&(S'=3) S ACHS0ST=ACHS0ST+1
. S ACHS0ST=ACHS0ST+1
Q
;
TOTL ;
W !!,$$REPEAT^XLFSTR("-",80),!?1,"TOTAL",?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 ?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")
Q
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,ACHSPAGE,DIR,I,X,X2,Y,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
K ACHS64ST,ACHS64T,ACHSSER
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
Q
;
W !!?1,"# DOCS #"
W:ACHSRTYP["D" ?15,"SERV",?23,"ISSUE DT"
W ?41,"$ OBLIGD $",?55,"$ IHS PMT $",?70,"$ 3P PMT $",!
Q
;
PATHEAD ;
W !!?1,"Patient: ",$G(ACHSPAT)," Chart #: ",$G(ACHSHRN)
Q
;
NODATA ;
W !!!,"NO DATA FOR SPECIFIED FISCAL YEAR"
K ^TMP("ACHS3PP",$J)
I $D(ACHSSERP) W " FOR "_$G(ACHSSERP)_" SERVICE(S)" W !!!!
I IOST["C-",'$D(IO("S")) D
.I '$$DIR^XBDIR("E") D END Q
.D ^ACHS3PP5
D END
Q
;
ACHS3PP4 ; IHS/ITSC/PMF - COMPILE CHS THIRD PARTY PAYMENT [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 ;TPF COPIED AND RE-WRITTEN FROM ACHS3PPP
+4 ;
+5 DO BRPT^ACHSFU
+6 IF $ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC,0))=""
SET ACHSPAGE=0
DO HEADER
DO NODATA
QUIT
+7 SET (ACHSOBL,ACHSOBLS,ACHSOBLT,ACHS3PP,ACHS3PPS,ACHS3PPT,ACHSDOCS)=0
+8 SET (ACHSDOCT,ACHSIHSP,ACHSIHSS,ACHSIHST,C,ACHSPAGE,ACHS43ST,ACHS57ST)=0
+9 SET (ACHS64ST,ACHS0ST,ACHS43T,ACHS57T,ACHS64T,ACHS0T)=0
+10 NEW OK
SET OK=1
+11 ;
+12 SET ACHSFAC=""
+13 FOR
SET ACHSFAC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC))
IF ACHSFAC=""
QUIT
DO P2
IF 'OK
QUIT
+14 IF 'OK
DO END
QUIT
+15 DO TOTL
+16 QUIT
+17 ;
P2 ;
+1 SET ACHSDOC=""
SET ACHSPAGE=0
DO HEADER
+2 ;
+3 FOR
SET ACHSDOC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC))
IF ACHSDOC=""
QUIT
Begin DoDot:1
+4 SET Z=$GET(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC))
+5 IF Z=""
QUIT
+6 ;
+7 IF $DATA(ACHSPAT)
SET P=$SELECT($PIECE(Z,U,7):$PIECE(Z,U,7),1:"NO NAME")
IF $DATA(^DPT(P,0))
SET ACHSPAT=$PIECE($GET(^DPT(P,0)),U,1)
SET ACHSHRN=$SELECT($PIECE(Z,U,8):$PIECE(Z,U,8),1:"NO HRN")
DO PATHEAD
+8 IF ACHSFLG=0
DO HEADER1
+9 DO GETIDT
End DoDot:1
IF 'OK
QUIT
+10 QUIT
+11 ;
GETIDT ;
+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 S(S)=""
+4 SET ACHSOBL=$PIECE(Z,U,2)
SET ACHS3PP=$PIECE(Z,U,3)
SET ACHSIHSP=$PIECE(Z,U,4)
+5 SET C=C+1
SET ACHSDOCS=C
SET ACHSFLG=1
+6 ;Prints Data
+7 IF ACHSRTYP["D"
Begin DoDot:1
+8 WRITE !?1,ACHSDOC,?15,ACHSSERV,?23,ACHSIDT,?40
+9 SET X=ACHSOBL
SET X2=2
+10 DO COMMA^%DTC
+11 WRITE $JUSTIFY(X,12),?55
+12 SET X=ACHSIHSP
SET X2=2
+13 DO COMMA^%DTC
+14 WRITE $JUSTIFY(X,12),?68
+15 SET X=ACHS3PP
SET X2=2
+16 DO COMMA^%DTC
+17 WRITE $JUSTIFY(X,12)
+18 QUIT
End DoDot:1
+19 IF IOST["P-"
IF $Y>ACHSBM
SET ACHSFLG=0
DO HEADER
+20 IF IOST["C-"
IF '$DATA(IO("S"))
IF $Y>ACHSBM
Begin DoDot:1
+21 SET OK=$$DIR^XBDIR("E")
+22 IF 'OK
QUIT
+23 SET ACHSFLG=0
DO HEADER
+24 QUIT
End DoDot:1
IF 'OK
QUIT
+25 ;
+26 SET ACHSOBLS=ACHSOBLS+ACHSOBL
SET ACHS3PPS=ACHS3PPS+ACHS3PP
SET ACHSIHSS=ACHSIHSS+ACHSIHSP
+27 IF ACHSSER=4
Begin DoDot:1
+28 IF S=1
SET ACHS43ST=ACHS43ST+1
QUIT
+29 IF S=2
SET ACHS57ST=ACHS57ST+1
QUIT
+30 IF S=3
SET ACHS64ST=ACHS64ST+1
QUIT
+31 ;I S'=1&(S'=2)&(S'=3) S ACHS0ST=ACHS0ST+1
+32 SET ACHS0ST=ACHS0ST+1
End DoDot:1
+33 QUIT
+34 ;
TOTL ;
+1 WRITE !!,$$REPEAT^XLFSTR("-",80),!?1,"TOTAL",?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 ?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
+16 QUIT
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,ACHSPAGE,DIR,I,X,X2,Y,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T
+7 KILL ACHS64ST,ACHS64T,ACHSSER
+8 KILL ^TMP("ACHS3PP",$JOB)
+9 QUIT
+10 ;
+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 QUIT
+20 ;
+1 WRITE !!?1,"# DOCS #"
+2 IF ACHSRTYP["D"
WRITE ?15,"SERV",?23,"ISSUE DT"
+3 WRITE ?41,"$ OBLIGD $",?55,"$ IHS PMT $",?70,"$ 3P PMT $",!
+4 QUIT
+5 ;
PATHEAD ;
+1 WRITE !!?1,"Patient: ",$GET(ACHSPAT)," Chart #: ",$GET(ACHSHRN)
+2 QUIT
+3 ;
NODATA ;
+1 WRITE !!!,"NO DATA FOR SPECIFIED FISCAL YEAR"
+2 KILL ^TMP("ACHS3PP",$JOB)
+3 IF $DATA(ACHSSERP)
WRITE " FOR "_$GET(ACHSSERP)_" SERVICE(S)"
WRITE !!!!
+4 IF IOST["C-"
IF '$DATA(IO("S"))
Begin DoDot:1
+5 IF '$$DIR^XBDIR("E")
DO END
QUIT
+6 DO ^ACHS3PP5
End DoDot:1
+7 DO END
+8 QUIT
+9 ;
