Routine: ACHS3PPP

ACHS3PPP ; IHS/ITSC/TPF/PMF - PRINT THIRD PARTY PAYMENT REPORT (ALL PATS) ;

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**16**;JUN 11, 2001

 D BRPT^ACHSFU

 I $D(^TMP("ACHS3PP",$J,ACHSFAC,0)) S ACHSPAGE=0 D HEADER G NODATA

 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

 S ACHSFAC=""

 I (ACHSRTYP="T")!(ACHSRTYP="P") G ^ACHS3PPT       ;ACHS*3.1*16 IHS.OIT.FCJ ADDED LINE FOR INS REP

P1 ;

 S ACHSFAC=$O(^TMP("ACHS3PP",$J,ACHSFAC))

 G:ACHSFAC="" TOTL

 S ACHSDOC=""

 S ACHSPAGE=0

 D HEADER

P2 ;

 S ACHSDOC=$O(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC))

 G:ACHSDOC="" TOTL

 S Z=$G(^TMP("ACHS3PP",$J,ACHSFAC,ACHSDOC))

GETPAT ;

 I '$D(ACHSPAT(0)) 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) S ACHSHRN=$S($P(Z,U,8):$P(Z,U,8),1:"NO HRN") D PATHEAD

 I ACHSFLG=0 D HEADER1

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 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 G END:'$$DIR^XBDIR("E") S ACHSFLG=0 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

.Q

 G P2

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,ACHSPAGE,DIR,I,X,X2,Y,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T

 K ACHS64ST,ACHS64T,ACHSSER

 K ^TMP("ACHS3PP",$J)

HEADER ;Prints Heading

 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

HEADER1 ;

 W !!?1,"# DOCS #"

 W:ACHSRTYP["D" ?15,"SERV",?23,"ISSUE DT"

 W ?41,"$ OBLIGD $",?55,"$ IHS PMT $",?70,"$ 3P PMT $",!

PATHEAD ;

 W !!?1,"Patient: ",ACHSPAT,"      Chart #: ",ACHSHRN

 G GETIDT

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

ACHS3PPP  ; IHS/ITSC/TPF/PMF - PRINT THIRD PARTY PAYMENT REPORT (ALL PATS) ;

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**16**;JUN 11, 2001

 +2       ;

 +3        DO BRPT^ACHSFU

 +4        IF $DATA(^TMP("ACHS3PP",$JOB,ACHSFAC,0))

               SET ACHSPAGE=0

               DO HEADER

               GOTO NODATA

 +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        SET ACHSFAC=""

 +9       ;ACHS*3.1*16 IHS.OIT.FCJ ADDED LINE FOR INS REP

           IF (ACHSRTYP="T")!(ACHSRTYP="P")

               GOTO ^ACHS3PPT

P1        ;

 +1        SET ACHSFAC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC))

 +2        IF ACHSFAC=""

               GOTO TOTL

 +3        SET ACHSDOC=""

 +4        SET ACHSPAGE=0

 +5        DO HEADER

P2        ;

 +1        SET ACHSDOC=$ORDER(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC))

 +2        IF ACHSDOC=""

               GOTO TOTL

 +3        SET Z=$GET(^TMP("ACHS3PP",$JOB,ACHSFAC,ACHSDOC))

GETPAT    ;

 +1        IF '$DATA(ACHSPAT(0))

               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)

               SET ACHSHRN=$SELECT($PIECE(Z,U,8):$PIECE(Z,U,8),1:"NO HRN")

               DO PATHEAD

 +2        IF ACHSFLG=0

               DO HEADER1

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 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

 +5       ;Prints Data

 +6        IF ACHSRTYP["D"

               Begin DoDot:1

 +7                WRITE !?1,ACHSDOC,?15,ACHSSERV,?23,ACHSIDT,?40

 +8                SET X=ACHSOBL

                   SET X2=2

 +9                DO COMMA^%DTC

 +10               WRITE $JUSTIFY(X,12),?55

 +11               SET X=ACHSIHSP

                   SET X2=2

 +12               DO COMMA^%DTC

 +13               WRITE $JUSTIFY(X,12),?68

 +14               SET X=ACHS3PP

                   SET X2=2

 +15               DO COMMA^%DTC

 +16               WRITE $JUSTIFY(X,12)

 +17               QUIT

               End DoDot:1

 +18       IF IOST["P-"

               IF $Y>ACHSBM

                   SET ACHSFLG=0

                   DO HEADER

 +19       IF IOST["C-"

               IF '$DATA(IO("S"))

                   IF $Y>ACHSBM

                       IF '$$DIR^XBDIR("E")

                           GOTO END

                       SET ACHSFLG=0

                       DO HEADER

 +20       SET ACHSOBLS=ACHSOBLS+ACHSOBL

           SET ACHS3PPS=ACHS3PPS+ACHS3PP

           SET ACHSIHSS=ACHSIHSS+ACHSIHSP

 +21       IF ACHSSER=4

               Begin DoDot:1

 +22               IF S=1

                       SET ACHS43ST=ACHS43ST+1

 +23               IF S=2

                       SET ACHS57ST=ACHS57ST+1

 +24               IF S=3

                       SET ACHS64ST=ACHS64ST+1

 +25               IF S'=1&(S'=2)&(S'=3)

                       SET ACHS0ST=ACHS0ST+1

 +26               QUIT

               End DoDot:1

 +27       GOTO P2

 +28      ;

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,ACHSPAGE,DIR,I,X,X2,Y,ACHSOT,ACHS43ST,ACHS43T,ACHS57ST,ACHS57T

 +7        KILL ACHS64ST,ACHS64T,ACHSSER

 +8        KILL ^TMP("ACHS3PP",$JOB)

 +9        QUIT

 +10      ;

HEADER    ;Prints Heading

 +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      ;

HEADER1   ;

 +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: ",ACHSPAT,"      Chart #: ",ACHSHRN

 +2        GOTO GETIDT

 +3       ;

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       ;

ACHS3PPP.m