ABMDF4 ; IHS/ASDST/DMJ - ADA-90 Dental Export Routine ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;08/15/96 1:11 PM
;
; IHS/DSD/DMJ - NOIS XFA-0698-200102
; Meds showing up on split bill for ADA & HCFA. Modified to
; show meds on HCFA only also add code so claim generator will
; not bomb if auto approve is turned on and Y2K fix to print 4
; digit year in 3 birthdate fields.
; IHS/DSD/DMJ - 5/10/1999 - NOIS XAA-0599-200017 Patch 1
; Itemized bills printing flat rate in batches at line BODY+4
; IHS/ASDS/LSL - 05/01/01 - V2.4 Patch 9 - NOIS HQW-0900-100053
; Modified to allow use of dental prefix code on the ADA-90 form
; as well.
;
; IHS/SD/EFG - V2.5 P8 - IM16385
; Check for dental and misc services
; IHS/SD/SDR - v2.5 p10 - IM20395
; Split out lines bundled by rev code
; IHS/SD/SDR - v2.5 p12 - IM24844
; Fix for <UNDEF>BODY+78^ABMDF4
;
; IHS/SD/SDR - v2.6 CSV
;
; *********************************************************************
;
K ABM
S U="^"
S ABMP("EXP")=4 ; Export Mode
D TXST^ABMDFUTL ; Create entry in 3P TX STATUS
S ABMY("N")=0 ; Initialize active insurer
; Print a form for every bill within an active insurer
F S ABMY("N")=$O(ABMY(ABMY("N"))) Q:'ABMY("N") D
.S ABMP("BDFN")=""
.F S ABMP("BDFN")=$O(ABMY(ABMY("N"),ABMP("BDFN"))) Q:'ABMP("BDFN") D
..D ENT
..S DIE="^ABMDBILL(DUZ(2),"
..S DA=ABMP("BDFN")
..S DR=".04////B;.16////A;.17////"_ABMP("XMIT")
..D ^ABMDDIE
..Q:$D(ABM("DIE-FAIL"))
;
D TXUPDT^ABMDFUTL ; Update 3P TX STATUS
;
XIT ;
K ABM,ABMF,ABMV
Q
;
ENT ;EP for getting data and printing form
K ABMF
Q:'$D(^ABMDBILL(DUZ(2),ABMP("BDFN"),0)) ; Quit if no bill data
Q:'$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,0))&('$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),43,0))) ;Quit if no dental or misc data
D ENT^ABMDF4A,BODY
Q
;
BODY ;
; For each dental entry in the bill file, find and print data
S ABMX("INS")=ABMP("INS") ; IEN to INSURER
K ABMP("FLAT") D FRATE^ABMDE2X1 ; find Flat Rate
S (ABM("C"),ABM,ABM("TCHRG"),ABM("I"),ABM("YTOT"))=0
; BOX 30
F S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM)) Q:'ABM S ABM(0)=^(ABM,0) D Q:$D(DUOUT)
.D RESET:ABM("I")=0
.;
.S ABM("F")=ABM("F")+1 ; Increment line counter
.I $P(ABM(0),U,5) D
..S ABMOPS=$P(ABM(0),U,5) ; IEN to DENTAL OPERATIVE SITE
..S ABMF(ABM("F"))=$P($G(^ADEOPS(ABMOPS,88)),U) ; Tooth Mnemonic
..S:ABMF(ABM("F"))["D" ABMF(ABM("F"))=$P($G(^ADEOPS(ABMOPS,0)),U,4) ; Tooth synonym
.S $P(ABMF(ABM("F")),U,2)=$P(ABM(0),U,6) ; Tooth Surface
.S $P(ABMF(ABM("F")),U,3)=$P(^AUTTADA(+ABM(0),0),U,2) ; Service Desc
.S $P(ABMF(ABM("F")),U,4)=$E($P(ABM(0),U,7),4,5) ; Date of serv. MM
.S $P(ABMF(ABM("F")),U,5)=$E($P(ABM(0),U,7),6,7) ; Date of serv. DD
.S $P(ABMF(ABM("F")),U,6)=$E($P(ABM(0),U,7),2,3) ; Date of serv. YY
.S $P(ABMF(ABM("F")),U,7)=$P(^AUTTADA(+ABM(0),0),U) ; Procedure #
.S ABMDENP=$P($G(^ABMDREC(ABMP("INS"),0)),U,2) ; Dent remap
.S:ABMDENP="" ABMDENP=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,11)
.S:ABMDENP="" ABMDENP=$P($G(^ABMDPARM(DUZ(2),1,3)),U,11)
.S:ABMDENP]"" $P(ABMF(ABM("F")),U,7)=ABMDENP_$P(ABMF(ABM("F")),U,7)
.S ABM("CHRG")=+$P(ABM(0),U,8)*(+$P(ABM(0),U,9))
.S $P(ABMF(ABM("F")),U,8)=$S(+$G(ABMP("FLAT")):"",1:ABM("CHRG"))
.S ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG") ; Fee
.;
.S ABM("I")=ABM("I")+1 ; Increment line counter
.I ABM("I")=14 D
..Q:'$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM))
..S ABM("MORE")=1
..D ^ABMDF4X ; Print form
..S ABM("I")=0
;
N ABMRV
D 43^ABMERGR2 ;obtain misc services data in ABMRV array
S ABMRCD=-1
F S ABMRCD=$O(ABMRV(ABMRCD)) Q:ABMRCD="" D
.S ABMED=""
.F S ABMED=$O(ABMRV(ABMRCD,ABMED)) Q:ABMED="" D Q:$D(DUOUT)
..S ABMCNTR=0
..F S ABMCNTR=$O(ABMRV(ABMRCD,ABMED,ABMCNTR)) Q:ABMCNTR="" D
...D RESET:ABM("I")=0
...S ABM("F")=ABM("F")+1
...S ABMMS=$P($$CPT^ABMCVAPI($O(^ICPT("B",ABMED,"")),ABMP("VDT")),U,3) ;CPT name ;CSV-c
...S ABMMSDT=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,10) ;date
...S ABMMSQTY=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,5) ;quantity
...S ABMMSCHG=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6) ;charge
...I ABMMSDT]"" D
....S $P(ABMF(ABM("F")),U,3)=ABMMS
....S $P(ABMF(ABM("F")),U,4)=$E(ABMMSDT,4,5)
....S $P(ABMF(ABM("F")),U,5)=$E(ABMMSDT,6,7)
....S $P(ABMF(ABM("F")),U,6)=$E(ABMMSDT,2,3)
...S $P(ABMF(ABM("F")),U,7)=$P($G(ABMRV(ABMRCD,ABMED)),U,2)
...S $P(ABMF(ABM("F")),U,8)=ABMMSCHG
...S ABM("TCHRG")=ABM("TCHRG")+ABMMSCHG
...S ABM("I")=ABM("I")+1
...I ABM("I")=10 D
....Q:($O(ABMRV(ABMRCD,ABMED))=""&($O(ABMRV(ABMRCD))=""))
....S ABM("MORE")=1
....D ^ABMDF4X ;print form
....S ABM("I")=0
; Put RX data on dental form
N ABMRV
D 23^ABMERGR2 ; Obtain RX data in ABMRV array
S ABMRCD=-1
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
..F S ABMCNTR=$O(ABMRV(ABMRCD,ABMED,ABMCNTR)) Q:ABMCNTR="" D
...D RESET:ABM("I")=0
...S ABM("F")=ABM("F")+1
...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
...S ABMRXCHG=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6) ; Charge
...S $P(ABMF(ABM("F")),U)=$E(ABMRX,1,3)
...S $P(ABMF(ABM("F")),U,2)=$E(ABMRX,4,8)
...S $P(ABMF(ABM("F")),U,3)=$E(ABMRX,9,99)
...I ABMRXDT]"" D
....S $P(ABMF(ABM("F")),U,4)=$E(ABMRXDT,4,5)
....S $P(ABMF(ABM("F")),U,5)=$E(ABMRXDT,6,7)
....S $P(ABMF(ABM("F")),U,6)=$E(ABMRXDT,2,3)
...S $P(ABMF(ABM("F")),U,7)="QTY "_ABMRXQTY
...S $P(ABMF(ABM("F")),U,8)=ABMRXCHG
...S ABM("TCHRG")=ABM("TCHRG")+ABMRXCHG
...S ABM("I")=ABM("I")+1
...I ABM("I")=14 D
....Q:($O(ABMRV(ABMRCD,ABMED))=""&($O(ABMRV(ABMRCD))=""))
....S ABM("MORE")=1
....D ^ABMDF4X ; Print form
....S ABM("I")=0
;
D TAIL:ABM("I")
Q
;
RESET ; Reset line numbers for BODY
F ABM("F")=35:1:48 K ABMF(ABM("F"))
S ABM("F")=34
Q
;
TAIL ;END OF FORM
I +$G(ABMP("FLAT")) S ABM("TCHRG")=+ABMP("FLAT")
S $P(ABMF(57),U,4)=ABM("TCHRG") ; Total fee charged
S ABM("YTOT")=ABM("TCHRG")
D YTOT^ABMDFUTL
S (ABM("I"),ABM("TCHRG"))=0
D ^ABMDF4X ; Print form
Q
ABMDF4 ; IHS/ASDST/DMJ - ADA-90 Dental Export Routine ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;08/15/96 1:11 PM
+3 ;
+4 ; IHS/DSD/DMJ - NOIS XFA-0698-200102
+5 ; Meds showing up on split bill for ADA & HCFA. Modified to
+6 ; show meds on HCFA only also add code so claim generator will
+7 ; not bomb if auto approve is turned on and Y2K fix to print 4
+8 ; digit year in 3 birthdate fields.
+9 ; IHS/DSD/DMJ - 5/10/1999 - NOIS XAA-0599-200017 Patch 1
+10 ; Itemized bills printing flat rate in batches at line BODY+4
+11 ; IHS/ASDS/LSL - 05/01/01 - V2.4 Patch 9 - NOIS HQW-0900-100053
+12 ; Modified to allow use of dental prefix code on the ADA-90 form
+13 ; as well.
+14 ;
+15 ; IHS/SD/EFG - V2.5 P8 - IM16385
+16 ; Check for dental and misc services
+17 ; IHS/SD/SDR - v2.5 p10 - IM20395
+18 ; Split out lines bundled by rev code
+19 ; IHS/SD/SDR - v2.5 p12 - IM24844
+20 ; Fix for <UNDEF>BODY+78^ABMDF4
+21 ;
+22 ; IHS/SD/SDR - v2.6 CSV
+23 ;
+24 ; *********************************************************************
+25 ;
+26 KILL ABM
+27 SET U="^"
+28 ; Export Mode
SET ABMP("EXP")=4
+29 ; Create entry in 3P TX STATUS
DO TXST^ABMDFUTL
+30 ; Initialize active insurer
SET ABMY("N")=0
+31 ; Print a form for every bill within an active insurer
+32 FOR
SET ABMY("N")=$ORDER(ABMY(ABMY("N")))
IF 'ABMY("N")
QUIT
Begin DoDot:1
+33 SET ABMP("BDFN")=""
+34 FOR
SET ABMP("BDFN")=$ORDER(ABMY(ABMY("N"),ABMP("BDFN")))
IF 'ABMP("BDFN")
QUIT
Begin DoDot:2
+35 DO ENT
+36 SET DIE="^ABMDBILL(DUZ(2),"
+37 SET DA=ABMP("BDFN")
+38 SET DR=".04////B;.16////A;.17////"_ABMP("XMIT")
+39 DO ^ABMDDIE
+40 IF $DATA(ABM("DIE-FAIL"))
QUIT
End DoDot:2
End DoDot:1
+41 ;
+42 ; Update 3P TX STATUS
DO TXUPDT^ABMDFUTL
+43 ;
XIT ;
+1 KILL ABM,ABMF,ABMV
+2 QUIT
+3 ;
ENT ;EP for getting data and printing form
+1 KILL ABMF
+2 ; Quit if no bill data
IF '$DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),0))
QUIT
+3 ;Quit if no dental or misc data
IF '$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,0))&('$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),43,0)))
QUIT
+4 DO ENT^ABMDF4A
DO BODY
+5 QUIT
+6 ;
BODY ;
+1 ; For each dental entry in the bill file, find and print data
+2 ; IEN to INSURER
SET ABMX("INS")=ABMP("INS")
+3 ; find Flat Rate
KILL ABMP("FLAT")
DO FRATE^ABMDE2X1
+4 SET (ABM("C"),ABM,ABM("TCHRG"),ABM("I"),ABM("YTOT"))=0
+5 ; BOX 30
+6 FOR
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM))
IF 'ABM
QUIT
SET ABM(0)=^(ABM,0)
Begin DoDot:1
+7 IF ABM("I")=0
DO RESET
+8 ;
+9 ; Increment line counter
SET ABM("F")=ABM("F")+1
+10 IF $PIECE(ABM(0),U,5)
Begin DoDot:2
+11 ; IEN to DENTAL OPERATIVE SITE
SET ABMOPS=$PIECE(ABM(0),U,5)
+12 ; Tooth Mnemonic
SET ABMF(ABM("F"))=$PIECE($GET(^ADEOPS(ABMOPS,88)),U)
+13 ; Tooth synonym
IF ABMF(ABM("F"))["D"
SET ABMF(ABM("F"))=$PIECE($GET(^ADEOPS(ABMOPS,0)),U,4)
End DoDot:2
+14 ; Tooth Surface
SET $PIECE(ABMF(ABM("F")),U,2)=$PIECE(ABM(0),U,6)
+15 ; Service Desc
SET $PIECE(ABMF(ABM("F")),U,3)=$PIECE(^AUTTADA(+ABM(0),0),U,2)
+16 ; Date of serv. MM
SET $PIECE(ABMF(ABM("F")),U,4)=$EXTRACT($PIECE(ABM(0),U,7),4,5)
+17 ; Date of serv. DD
SET $PIECE(ABMF(ABM("F")),U,5)=$EXTRACT($PIECE(ABM(0),U,7),6,7)
+18 ; Date of serv. YY
SET $PIECE(ABMF(ABM("F")),U,6)=$EXTRACT($PIECE(ABM(0),U,7),2,3)
+19 ; Procedure #
SET $PIECE(ABMF(ABM("F")),U,7)=$PIECE(^AUTTADA(+ABM(0),0),U)
+20 ; Dent remap
SET ABMDENP=$PIECE($GET(^ABMDREC(ABMP("INS"),0)),U,2)
+21 IF ABMDENP=""
SET ABMDENP=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,11)
+22 IF ABMDENP=""
SET ABMDENP=$PIECE($GET(^ABMDPARM(DUZ(2),1,3)),U,11)
+23 IF ABMDENP]""
SET $PIECE(ABMF(ABM("F")),U,7)=ABMDENP_$PIECE(ABMF(ABM("F")),U,7)
+24 SET ABM("CHRG")=+$PIECE(ABM(0),U,8)*(+$PIECE(ABM(0),U,9))
+25 SET $PIECE(ABMF(ABM("F")),U,8)=$SELECT(+$GET(ABMP("FLAT")):"",1:ABM("CHRG"))
+26 ; Fee
SET ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
+27 ;
+28 ; Increment line counter
SET ABM("I")=ABM("I")+1
+29 IF ABM("I")=14
Begin DoDot:2
+30 IF '$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM))
QUIT
+31 SET ABM("MORE")=1
+32 ; Print form
DO ^ABMDF4X
+33 SET ABM("I")=0
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+34 ;
+35 NEW ABMRV
+36 ;obtain misc services data in ABMRV array
DO 43^ABMERGR2
+37 SET ABMRCD=-1
+38 FOR
SET ABMRCD=$ORDER(ABMRV(ABMRCD))
IF ABMRCD=""
QUIT
Begin DoDot:1
+39 SET ABMED=""
+40 FOR
SET ABMED=$ORDER(ABMRV(ABMRCD,ABMED))
IF ABMED=""
QUIT
Begin DoDot:2
+41 SET ABMCNTR=0
+42 FOR
SET ABMCNTR=$ORDER(ABMRV(ABMRCD,ABMED,ABMCNTR))
IF ABMCNTR=""
QUIT
Begin DoDot:3
+43 IF ABM("I")=0
DO RESET
+44 SET ABM("F")=ABM("F")+1
+45 ;CPT name ;CSV-c
SET ABMMS=$PIECE($$CPT^ABMCVAPI($ORDER(^ICPT("B",ABMED,"")),ABMP("VDT")),U,3)
+46 ;date
SET ABMMSDT=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,10)
+47 ;quantity
SET ABMMSQTY=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,5)
+48 ;charge
SET ABMMSCHG=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6)
+49 IF ABMMSDT]""
Begin DoDot:4
+50 SET $PIECE(ABMF(ABM("F")),U,3)=ABMMS
+51 SET $PIECE(ABMF(ABM("F")),U,4)=$EXTRACT(ABMMSDT,4,5)
+52 SET $PIECE(ABMF(ABM("F")),U,5)=$EXTRACT(ABMMSDT,6,7)
+53 SET $PIECE(ABMF(ABM("F")),U,6)=$EXTRACT(ABMMSDT,2,3)
End DoDot:4
+54 SET $PIECE(ABMF(ABM("F")),U,7)=$PIECE($GET(ABMRV(ABMRCD,ABMED)),U,2)
+55 SET $PIECE(ABMF(ABM("F")),U,8)=ABMMSCHG
+56 SET ABM("TCHRG")=ABM("TCHRG")+ABMMSCHG
+57 SET ABM("I")=ABM("I")+1
+58 IF ABM("I")=10
Begin DoDot:4
+59 IF ($ORDER(ABMRV(ABMRCD,ABMED))=""&($ORDER(ABMRV(ABMRCD))=""))
QUIT
+60 SET ABM("MORE")=1
+61 ;print form
DO ^ABMDF4X
+62 SET ABM("I")=0
End DoDot:4
End DoDot:3
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
+63 ; Put RX data on dental form
+64 NEW ABMRV
+65 ; Obtain RX data in ABMRV array
DO 23^ABMERGR2
+66 SET ABMRCD=-1
+67 FOR
SET ABMRCD=$ORDER(ABMRV(ABMRCD))
IF ABMRCD=""
QUIT
Begin DoDot:1
+68 SET ABMED=0
+69 FOR
SET ABMED=$ORDER(ABMRV(ABMRCD,ABMED))
IF '+ABMED
QUIT
Begin DoDot:2
+70 SET ABMCNTR=0
+71 FOR
SET ABMCNTR=$ORDER(ABMRV(ABMRCD,ABMED,ABMCNTR))
IF ABMCNTR=""
QUIT
Begin DoDot:3
+72 IF ABM("I")=0
DO RESET
+73 SET ABM("F")=ABM("F")+1
+74 ; NDC# name
SET ABMRX=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,9)
+75 ; date/time
SET ABMRXDT=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,10)
+76 ; Quantity
SET ABMRXQTY=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,5)
+77 ; Charge
SET ABMRXCHG=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6)
+78 SET $PIECE(ABMF(ABM("F")),U)=$EXTRACT(ABMRX,1,3)
+79 SET $PIECE(ABMF(ABM("F")),U,2)=$EXTRACT(ABMRX,4,8)
+80 SET $PIECE(ABMF(ABM("F")),U,3)=$EXTRACT(ABMRX,9,99)
+81 IF ABMRXDT]""
Begin DoDot:4
+82 SET $PIECE(ABMF(ABM("F")),U,4)=$EXTRACT(ABMRXDT,4,5)
+83 SET $PIECE(ABMF(ABM("F")),U,5)=$EXTRACT(ABMRXDT,6,7)
+84 SET $PIECE(ABMF(ABM("F")),U,6)=$EXTRACT(ABMRXDT,2,3)
End DoDot:4
+85 SET $PIECE(ABMF(ABM("F")),U,7)="QTY "_ABMRXQTY
+86 SET $PIECE(ABMF(ABM("F")),U,8)=ABMRXCHG
+87 SET ABM("TCHRG")=ABM("TCHRG")+ABMRXCHG
+88 SET ABM("I")=ABM("I")+1
+89 IF ABM("I")=14
Begin DoDot:4
+90 IF ($ORDER(ABMRV(ABMRCD,ABMED))=""&($ORDER(ABMRV(ABMRCD))=""))
QUIT
+91 SET ABM("MORE")=1
+92 ; Print form
DO ^ABMDF4X
+93 SET ABM("I")=0
End DoDot:4
End DoDot:3
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
+94 ;
+95 IF ABM("I")
DO TAIL
+96 QUIT
+97 ;
RESET ; Reset line numbers for BODY
+1 FOR ABM("F")=35:1:48
KILL ABMF(ABM("F"))
+2 SET ABM("F")=34
+3 QUIT
+4 ;
TAIL ;END OF FORM
+1 IF +$GET(ABMP("FLAT"))
SET ABM("TCHRG")=+ABMP("FLAT")
+2 ; Total fee charged
SET $PIECE(ABMF(57),U,4)=ABM("TCHRG")
+3 SET ABM("YTOT")=ABM("TCHRG")
+4 DO YTOT^ABMDFUTL
+5 SET (ABM("I"),ABM("TCHRG"))=0
+6 ; Print form
DO ^ABMDF4X
+7 QUIT
