ABMDES4 ; IHS/ASDST/DMJ - ADA Form Dental Charge Summary ;
;;2.6;IHS 3P BILLING SYSTEM;**11,14**;NOV 12, 2009;Build 238
;
; IHS/SD/EFG - V2.5 P8 - IM16385
; Fix header wrapping; include misc services
; IHS/SD/SDR - v2.5 p10 - IM20395
; Split out lines bundled by rev code
; IHS/SD/SDR - v2.5 p10 - IM21581
; Added active insurer print to summary
;
; IHS/SD/SDR - v2.6 CSV
;IHS/SD/SDR - 2.6*14 5/8/14 - HEAT163277 - Made change for RX multiple so charges would be counted in total sooner
;
N ABM
Q:'$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,0))&('$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),43,0)))
D HD
G XIT:$D(DUOUT)
D WRT
Q:$G(ABMQUIET)
F W ! Q:$Y+4>IOSL
S DIR(0)="E"
D ^DIR
K DIR
;
XIT ;
K DUOUT
Q
;
HD ;
; SCREEN HEADER
Q:$G(ABMQUIET)
W $$EN^ABMVDF("IOF")
W !?15,"***** ADA FORM DENTAL CHARGE SUMMARY *****"
W !!,"Active Insurer: ",$P($G(^AUTNINS(ABMP("INS"),0)),U),!
W !!?2,"Tooth",?9,"Surface",?20,"Description of Service",?52,"Date",?60,"ADA Code",?73,"Fee"
W !,"-------------------------------------------------------------------------------"
Q
;
WRT ;
;start new code abm*2.6*11 HEAT117086
S ABM("TCHRG")=0
S ABM=0
I '$G(ABMQUIET) W !
F S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),43,ABM)) Q:'ABM S ABM(0)=^(ABM,0) D
.I $P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)'="T1015" Q ;CSV-c
.S ABM("CHRG")=$P(ABM(0),U,4)
.S ABM("CHRG")=ABM("CHRG")*$P($G(ABM(0)),U,3)
.S ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
.Q:$G(ABMQUIET)
.I $Y+5>IOSL D HD Q:$D(DUOUT)
.W !
.W ?18,$E($P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,3),1,30) ;CSV-c
.W ?50,$$HDT^ABMDUTL($P(ABM(0),U,7))
.W ?62,$P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2) ;CSV-c
.W ?70,$J($FN(ABM("CHRG"),",",2),8)
;end new code HEAT117086
;
;S (ABM("C"),ABM,ABM("TCHRG"))=0 ;abm*2.6*11 HEAT117086
S (ABM("C"),ABM)=0 ;abm*2.6*11 HEAT117086
F S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,ABM)) Q:'ABM S ABM(0)=^(ABM,0) D Q:$D(DUOUT)
.S ABM("CHRG")=$P(ABM(0),U,8)
.S ABM("CHRG")=ABM("CHRG")*$P($G(ABM(0)),U,9)
.S ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
.Q:$G(ABMQUIET)
.I $Y+5>IOSL D HD Q:$D(DUOUT)
.W !
.I $P(ABM(0),U,5) D
..S ABMOPS=$P(ABM(0),U,5)
..S ABMTMP=$P($G(^ADEOPS(ABMOPS,88)),U)
..S:ABMTMP["D" ABMTMP=$P($G(^ADEOPS(ABMOPS,0)),U,4)
..W ?2,ABMTMP
.W ?9,$P(ABM(0),U,6)
.W ?18,$E($P(^AUTTADA(+ABM(0),0),U,2),1,30)
.W ?50,$$HDT^ABMDUTL($P(ABM(0),U,7))
.W ?62,$P(^AUTTADA(+ABM(0),0),U)
.W ?70,$J($FN(ABM("CHRG"),",",2),8)
;
S ABM=0
I '$G(ABMQUIET) W !
F S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),43,ABM)) Q:'ABM S ABM(0)=^(ABM,0) D
.I $P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)="T1015" Q ;CSV-c ;abm*2.6*11 HEAT117086
.S ABM("CHRG")=$P(ABM(0),U,4)
.S ABM("CHRG")=ABM("CHRG")*$P($G(ABM(0)),U,3)
.S ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
.Q:$G(ABMQUIET)
.I $Y+5>IOSL D HD Q:$D(DUOUT)
.W !
.W ?18,$E($P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,3),1,30) ;CSV-c
.W ?50,$$HDT^ABMDUTL($P(ABM(0),U,7))
.W ?62,$P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2) ;CSV-c
.W ?70,$J($FN(ABM("CHRG"),",",2),8)
;
; Include RX charges
I '$G(ABMQUIET) W !
N ABMRV
S DA=0
F S DA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA)) Q:'DA D
.F J=1:1:5 S ABM(J)=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0),U,J)
.S ABMCNTR=+$O(ABMRV(+ABM(2),ABM(1),0))
.S $P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U)=ABM(2) ; revenue code IEN
.S $P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,5)=$P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,5)+ABM(3) ; cumulative units
.S ABM(6)=ABM(3)*ABM(4)+ABM(5) ; units * units cost + dispense fee
.S ABM(6)=$J(ABM(6),1,2)
.S $P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,6)=$P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,6)+ABM(6) ; cumulative charges
.S $P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,9)=$P($G(^PSDRUG(ABM(1),2)),U,4)_" "_$P($G(^(0)),U) ; NDC generic name
;
;S ABMRCD=0 ;abm*2.6*14 HEAT163277
S ABMRCD=-1 ;abm*2.6*14 HEAT163277
F S ABMRCD=$O(ABMRV(ABMRCD)) Q:'+ABMRCD D
.S ABMED=0
.F S ABMED=$O(ABMRV(ABMRCD,ABMED)) Q:'+ABMED D Q:$D(DUOUT)
..;S ABMCNTR=0 ;abm*2.6*14 HEAT163277
..S ABMCNTR=-1 ;abm*2.6*14 HEAT163277
..F S ABMCNTR=$O(ABMRV(ABMRCD,ABMED,ABMCNTR)) Q:ABMCNTR="" D
...S ABMRXCHG=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6) ;Charge
...S ABM("TCHRG")=ABM("TCHRG")+ABMRXCHG
...Q:$G(ABMQUIET)
...S ABMRX=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,9) ;NDC# name
...S ABMRXDT=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,10) ;date/time
...S ABMRXQTY=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,5) ;quantity
...I $Y+5>IOSL D HD Q:$D(DUOUT)
...W !
...W ?2,$E(ABMRX,1,48)
...W ?50,$$HDT^ABMDUTL(ABMRXDT)
...W ?62,"QTY "_ABMRXQTY
...W ?70,$J($FN(ABMRXCHG,",",2),8)
;
I '$G(ABMQUIET) D
.W !?71,"========"
.W !?10,"TOTAL CHARGE",?69,$J($FN(ABM("TCHRG"),",",2),9)
I $D(ABMP("FLAT")) D
.S ABM("TCHRG")=$P(ABMP("FLAT"),U)
.Q:$G(ABMQUIET)
.W !!?49,"Flat Rate Applied:",?69,$J($FN(ABM("TCHRG"),",",2),9)
S:ABM("TCHRG") ABMP("EXP",ABMP("EXP"))=ABM("TCHRG")
Q
ABMDES4 ; IHS/ASDST/DMJ - ADA Form Dental Charge Summary ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**11,14**;NOV 12, 2009;Build 238
+2 ;
+3 ; IHS/SD/EFG - V2.5 P8 - IM16385
+4 ; Fix header wrapping; include misc services
+5 ; IHS/SD/SDR - v2.5 p10 - IM20395
+6 ; Split out lines bundled by rev code
+7 ; IHS/SD/SDR - v2.5 p10 - IM21581
+8 ; Added active insurer print to summary
+9 ;
+10 ; IHS/SD/SDR - v2.6 CSV
+11 ;IHS/SD/SDR - 2.6*14 5/8/14 - HEAT163277 - Made change for RX multiple so charges would be counted in total sooner
+12 ;
+13 NEW ABM
+14 IF '$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,0))&('$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),43,0)))
QUIT
+15 DO HD
+16 IF $DATA(DUOUT)
GOTO XIT
+17 DO WRT
+18 IF $GET(ABMQUIET)
QUIT
+19 FOR
WRITE !
IF $Y+4>IOSL
QUIT
+20 SET DIR(0)="E"
+21 DO ^DIR
+22 KILL DIR
+23 ;
XIT ;
+1 KILL DUOUT
+2 QUIT
+3 ;
HD ;
+1 ; SCREEN HEADER
+2 IF $GET(ABMQUIET)
QUIT
+3 WRITE $$EN^ABMVDF("IOF")
+4 WRITE !?15,"***** ADA FORM DENTAL CHARGE SUMMARY *****"
+5 WRITE !!,"Active Insurer: ",$PIECE($GET(^AUTNINS(ABMP("INS"),0)),U),!
+6 WRITE !!?2,"Tooth",?9,"Surface",?20,"Description of Service",?52,"Date",?60,"ADA Code",?73,"Fee"
+7 WRITE !,"-------------------------------------------------------------------------------"
+8 QUIT
+9 ;
WRT ;
+1 ;start new code abm*2.6*11 HEAT117086
+2 SET ABM("TCHRG")=0
+3 SET ABM=0
+4 IF '$GET(ABMQUIET)
WRITE !
+5 FOR
SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),43,ABM))
IF 'ABM
QUIT
SET ABM(0)=^(ABM,0)
Begin DoDot:1
+6 ;CSV-c
IF $PIECE($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)'="T1015"
QUIT
+7 SET ABM("CHRG")=$PIECE(ABM(0),U,4)
+8 SET ABM("CHRG")=ABM("CHRG")*$PIECE($GET(ABM(0)),U,3)
+9 SET ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
+10 IF $GET(ABMQUIET)
QUIT
+11 IF $Y+5>IOSL
DO HD
IF $DATA(DUOUT)
QUIT
+12 WRITE !
+13 ;CSV-c
WRITE ?18,$EXTRACT($PIECE($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,3),1,30)
+14 WRITE ?50,$$HDT^ABMDUTL($PIECE(ABM(0),U,7))
+15 ;CSV-c
WRITE ?62,$PIECE($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)
+16 WRITE ?70,$JUSTIFY($FNUMBER(ABM("CHRG"),",",2),8)
End DoDot:1
+17 ;end new code HEAT117086
+18 ;
+19 ;S (ABM("C"),ABM,ABM("TCHRG"))=0 ;abm*2.6*11 HEAT117086
+20 ;abm*2.6*11 HEAT117086
SET (ABM("C"),ABM)=0
+21 FOR
SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,ABM))
IF 'ABM
QUIT
SET ABM(0)=^(ABM,0)
Begin DoDot:1
+22 SET ABM("CHRG")=$PIECE(ABM(0),U,8)
+23 SET ABM("CHRG")=ABM("CHRG")*$PIECE($GET(ABM(0)),U,9)
+24 SET ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
+25 IF $GET(ABMQUIET)
QUIT
+26 IF $Y+5>IOSL
DO HD
IF $DATA(DUOUT)
QUIT
+27 WRITE !
+28 IF $PIECE(ABM(0),U,5)
Begin DoDot:2
+29 SET ABMOPS=$PIECE(ABM(0),U,5)
+30 SET ABMTMP=$PIECE($GET(^ADEOPS(ABMOPS,88)),U)
+31 IF ABMTMP["D"
SET ABMTMP=$PIECE($GET(^ADEOPS(ABMOPS,0)),U,4)
+32 WRITE ?2,ABMTMP
End DoDot:2
+33 WRITE ?9,$PIECE(ABM(0),U,6)
+34 WRITE ?18,$EXTRACT($PIECE(^AUTTADA(+ABM(0),0),U,2),1,30)
+35 WRITE ?50,$$HDT^ABMDUTL($PIECE(ABM(0),U,7))
+36 WRITE ?62,$PIECE(^AUTTADA(+ABM(0),0),U)
+37 WRITE ?70,$JUSTIFY($FNUMBER(ABM("CHRG"),",",2),8)
End DoDot:1
IF $DATA(DUOUT)
QUIT
+38 ;
+39 SET ABM=0
+40 IF '$GET(ABMQUIET)
WRITE !
+41 FOR
SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),43,ABM))
IF 'ABM
QUIT
SET ABM(0)=^(ABM,0)
Begin DoDot:1
+42 ;CSV-c ;abm*2.6*11 HEAT117086
IF $PIECE($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)="T1015"
QUIT
+43 SET ABM("CHRG")=$PIECE(ABM(0),U,4)
+44 SET ABM("CHRG")=ABM("CHRG")*$PIECE($GET(ABM(0)),U,3)
+45 SET ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
+46 IF $GET(ABMQUIET)
QUIT
+47 IF $Y+5>IOSL
DO HD
IF $DATA(DUOUT)
QUIT
+48 WRITE !
+49 ;CSV-c
WRITE ?18,$EXTRACT($PIECE($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,3),1,30)
+50 WRITE ?50,$$HDT^ABMDUTL($PIECE(ABM(0),U,7))
+51 ;CSV-c
WRITE ?62,$PIECE($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)
+52 WRITE ?70,$JUSTIFY($FNUMBER(ABM("CHRG"),",",2),8)
End DoDot:1
+53 ;
+54 ; Include RX charges
+55 IF '$GET(ABMQUIET)
WRITE !
+56 NEW ABMRV
+57 SET DA=0
+58 FOR
SET DA=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA))
IF 'DA
QUIT
Begin DoDot:1
+59 FOR J=1:1:5
SET ABM(J)=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0),U,J)
+60 SET ABMCNTR=+$ORDER(ABMRV(+ABM(2),ABM(1),0))
+61 ; revenue code IEN
SET $PIECE(ABMRV(+ABM(2),ABM(1),ABMCNTR),U)=ABM(2)
+62 ; cumulative units
SET $PIECE(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,5)=$PIECE(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,5)+ABM(3)
+63 ; units * units cost + dispense fee
SET ABM(6)=ABM(3)*ABM(4)+ABM(5)
+64 SET ABM(6)=$JUSTIFY(ABM(6),1,2)
+65 ; cumulative charges
SET $PIECE(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,6)=$PIECE(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,6)+ABM(6)
+66 ; NDC generic name
SET $PIECE(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,9)=$PIECE($GET(^PSDRUG(ABM(1),2)),U,4)_" "_$PIECE($GET(^(0)),U)
End DoDot:1
+67 ;
+68 ;S ABMRCD=0 ;abm*2.6*14 HEAT163277
+69 ;abm*2.6*14 HEAT163277
SET ABMRCD=-1
+70 FOR
SET ABMRCD=$ORDER(ABMRV(ABMRCD))
IF '+ABMRCD
QUIT
Begin DoDot:1
+71 SET ABMED=0
+72 FOR
SET ABMED=$ORDER(ABMRV(ABMRCD,ABMED))
IF '+ABMED
QUIT
Begin DoDot:2
+73 ;S ABMCNTR=0 ;abm*2.6*14 HEAT163277
+74 ;abm*2.6*14 HEAT163277
SET ABMCNTR=-1
+75 FOR
SET ABMCNTR=$ORDER(ABMRV(ABMRCD,ABMED,ABMCNTR))
IF ABMCNTR=""
QUIT
Begin DoDot:3
+76 ;Charge
SET ABMRXCHG=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6)
+77 SET ABM("TCHRG")=ABM("TCHRG")+ABMRXCHG
+78 IF $GET(ABMQUIET)
QUIT
+79 ;NDC# name
SET ABMRX=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,9)
+80 ;date/time
SET ABMRXDT=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,10)
+81 ;quantity
SET ABMRXQTY=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,5)
+82 IF $Y+5>IOSL
DO HD
IF $DATA(DUOUT)
QUIT
+83 WRITE !
+84 WRITE ?2,$EXTRACT(ABMRX,1,48)
+85 WRITE ?50,$$HDT^ABMDUTL(ABMRXDT)
+86 WRITE ?62,"QTY "_ABMRXQTY
+87 WRITE ?70,$JUSTIFY($FNUMBER(ABMRXCHG,",",2),8)
End DoDot:3
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
+88 ;
+89 IF '$GET(ABMQUIET)
Begin DoDot:1
+90 WRITE !?71,"========"
+91 WRITE !?10,"TOTAL CHARGE",?69,$JUSTIFY($FNUMBER(ABM("TCHRG"),",",2),9)
End DoDot:1
+92 IF $DATA(ABMP("FLAT"))
Begin DoDot:1
+93 SET ABM("TCHRG")=$PIECE(ABMP("FLAT"),U)
+94 IF $GET(ABMQUIET)
QUIT
+95 WRITE !!?49,"Flat Rate Applied:",?69,$JUSTIFY($FNUMBER(ABM("TCHRG"),",",2),9)
End DoDot:1
+96 IF ABM("TCHRG")
SET ABMP("EXP",ABMP("EXP"))=ABM("TCHRG")
+97 QUIT
