ABMDRPX1.m

ABMDRPX1 ; IHS/ASDST/DMJ - Billed CPT List ;

 ;;2.6;IHS Third Party Billing;**1**;NOV 12, 2009

 ;Original;TMD;

 ; IHS/SD/SDR - abm*2.6*1 - HEAT4716 - Allowed room for NDC

 ;

PRINT ;EP for printing data

 W:$D(ABM("PRINT",16)) @ABM("PRINT",16) S ABM("PG")=0 D HDB

 S ABM="" F  S ABM=$O(^TMP("ABM-PX",$J,ABM)) Q:ABM=""  S ABM("T")=^(ABM) D  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)

 .I $Y>(IOSL-5) D HD Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)

 .D WRT

 I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) K ^TMP("ABM-PX",$J,"CL") Q

 S ABM("T")=$G(^TMP("ABM-PX",$J))

 W !?50,"+=======+=============+"

 W !?43,"Total:",?52,$J($FN($P(ABM("T"),U),",",0),5),?60,$J($FN($P(ABM("T"),U,2),",",2),11)

 W !?50,"+=======+=============+"

 K ^TMP("ABM-PX",$J,"CL") Q

 ;

WRT ;W !?1,$S(ABM="ZZZZZ":"",1:ABM),?9,$P(ABM("T"),U,3)  ;abm*2.6*1 HEAT4716

 I ABM["-" W !?1,ABM,?20,$P(ABM("T"),U,3)  ;abm*2.6*1 HEAT4716

 I ABM'["-" W !?1,$S(ABM="ZZZZZ":"",1:ABM),?9,$P(ABM("T"),U,3)  ;abm*2.6*1 HEAT4716

 W ?52,$J($FN($P(ABM("T"),U),",",0),5),?60,$J($FN($P(ABM("T"),U,2),",",2),11)

 W ?74,$J($J(100*$P(ABM("T"),U,2)\$P(^TMP("ABM-PX",$J),U,2),".",1),4),"%"

 Q

 ;

HD D PAZ^ABMDRUTL Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)

HDB S ABM("PG")=ABM("PG")+1,ABM("I")="" D WHD^ABMDRHD

 W !?63,"Amount"

 ;start old code abm*2.6*1 HEAT4716

 ;W !?1,"Code",?17,"Procedure Description",?52,"Count",?63,"Billed",?73,"Percent"

 ;W !,"-------+------------------------------------------+-------+-------------+-------"

 ;end old code start new code HEAT4716

 I $G(ABM("SUB"))=23 D

 .W !?1,"Code",?20,"Procedure Description",?52,"Count",?63,"Billed",?73,"Percent"

 .W !,"-----------------+--------------------------------+-------+-------------+-------"

 I $G(ABM("SUB"))'=23 D

 .W !?1,"Code",?17,"Procedure Description",?52,"Count",?63,"Billed",?73,"Percent"

 .W !,"-------+------------------------------------------+-------+-------------+-------"

 ;end new code HEAT4716

 Q

ABMDRPX1  ; IHS/ASDST/DMJ - Billed CPT List ;

 +1       ;;2.6;IHS Third Party Billing;**1**;NOV 12, 2009

 +2       ;Original;TMD;

 +3       ; IHS/SD/SDR - abm*2.6*1 - HEAT4716 - Allowed room for NDC

 +4       ;

PRINT     ;EP for printing data

 +1        IF $DATA(ABM("PRINT",16))

               WRITE @ABM("PRINT",16)

           SET ABM("PG")=0

           DO HDB

 +2        SET ABM=""

           FOR 

               SET ABM=$ORDER(^TMP("ABM-PX",$JOB,ABM))

               IF ABM=""

                   QUIT 

               SET ABM("T")=^(ABM)

               Begin DoDot:1

 +3                IF $Y>(IOSL-5)

                       DO HD

                       IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)

                           QUIT 

 +4                DO WRT

               End DoDot:1

               IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)

                   QUIT 

 +5        IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))

               KILL ^TMP("ABM-PX",$JOB,"CL")

               QUIT 

 +6        SET ABM("T")=$GET(^TMP("ABM-PX",$JOB))

 +7        WRITE !?50,"+=======+=============+"

 +8        WRITE !?43,"Total:",?52,$JUSTIFY($FNUMBER($PIECE(ABM("T"),U),",",0),5),?60,$JUSTIFY($FNUMBER($PIECE(ABM("T"),U,2),",",2),11)

 +9        WRITE !?50,"+=======+=============+"

 +10       KILL ^TMP("ABM-PX",$JOB,"CL")

           QUIT 

 +11      ;

WRT       ;W !?1,$S(ABM="ZZZZZ":"",1:ABM),?9,$P(ABM("T"),U,3)  ;abm*2.6*1 HEAT4716

 +1       ;abm*2.6*1 HEAT4716

           IF ABM["-"

               WRITE !?1,ABM,?20,$PIECE(ABM("T"),U,3)

 +2       ;abm*2.6*1 HEAT4716

           IF ABM'["-"

               WRITE !?1,$SELECT(ABM="ZZZZZ":"",1:ABM),?9,$PIECE(ABM("T"),U,3)

 +3        WRITE ?52,$JUSTIFY($FNUMBER($PIECE(ABM("T"),U),",",0),5),?60,$JUSTIFY($FNUMBER($PIECE(ABM("T"),U,2),",",2),11)

 +4        WRITE ?74,$JUSTIFY($JUSTIFY(100*$PIECE(ABM("T"),U,2)\$PIECE(^TMP("ABM-PX",$JOB),U,2),".",1),4),"%"

 +5        QUIT 

 +6       ;

HD         DO PAZ^ABMDRUTL

           IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)

               QUIT 

HDB        SET ABM("PG")=ABM("PG")+1

           SET ABM("I")=""

           DO WHD^ABMDRHD

 +1        WRITE !?63,"Amount"

 +2       ;start old code abm*2.6*1 HEAT4716

 +3       ;W !?1,"Code",?17,"Procedure Description",?52,"Count",?63,"Billed",?73,"Percent"

 +4       ;W !,"-------+------------------------------------------+-------+-------------+-------"

 +5       ;end old code start new code HEAT4716

 +6        IF $GET(ABM("SUB"))=23

               Begin DoDot:1

 +7                WRITE !?1,"Code",?20,"Procedure Description",?52,"Count",?63,"Billed",?73,"Percent"

 +8                WRITE !,"-----------------+--------------------------------+-------+-------------+-------"

               End DoDot:1

 +9        IF $GET(ABM("SUB"))'=23

               Begin DoDot:1

 +10               WRITE !?1,"Code",?17,"Procedure Description",?52,"Count",?63,"Billed",?73,"Percent"

 +11               WRITE !,"-------+------------------------------------------+-------+-------------+-------"

               End DoDot:1

 +12      ;end new code HEAT4716

 +13       QUIT