ABMDF34 ; IHS/SD/SDR - ADA-2012 Dental Export Routine ;
;;2.6;IHS 3P BILLING SYSTEM;**14,16,19**;NOV 12, 2009;Build 300
;IHS/SD/SDR - 2.6*14 - HEAT136149 - Fixed box 34 to print 'B' for ICD9 codes.
;IHS/SD/SDR - 2.6*14 Updated DX^ABMCVAPI call to be numeric
;IHS/SD/SDR - 2.6*16 HEAT231506 - Added code for 'AB' to print for ICD10.
;IHS/SD/AML - 2.6*19 - HEAT181886 - Change coor. dx from numeric to alpha
;
;************************************************************************************
K ABM
S U="^"
S ABMP("EXP")=34 ; 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")="" ; Initialize bill IEN
.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 and misc data
D ENT^ABMDF34A,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
;
;S $P(ABMF(36),U)="09" ;(34) ;abm*2.6*14 HEAT136149
;S $P(ABMF(36),U)="B" ;(34) ;abm*2.6*14 HEAT136149 ;abm*2.6*16 IHS/SD/SDR HEAT231506
S $P(ABMF(36),U)=$S($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),0)),U,21)=10:"AB",1:"B") ;(34) ;abm*2.6*14 HEAT136149 ;abm*2.6*16 IHS/SD/SDR HEAT231506
;(34a)
F S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM)) Q:'ABM D Q:(ABM("C")=4)
.S ABM("C")=+$G(ABM("C"))+1
.S ABM("X")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM,""))
.;S ABM("DX")=$P($$DX^ABMCVAPI($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U),ABMP("VDT")),U,2) ;abm*2.6*14 updated API call
.S ABM("DX")=$P($$DX^ABMCVAPI(+$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U),ABMP("VDT")),U,2) ;abm*2.6*14 updated API call
.I ABM=1 S $P(ABMF(37),U)=ABM("DX")
.I ABM=2 S $P(ABMF(38),U)=ABM("DX")
.I ABM=3 S $P(ABMF(37),U,2)=ABM("DX")
.I ABM=4 S $P(ABMF(38),U,2)=ABM("DX")
S (ABM,ABM("C"),ABM("X"),ABM("DX"))=0
F S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM)) Q:'ABM D Q:$D(DUOUT)
.S ABM(0)=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM,0))
.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 $P(ABMF(ABM("F")),U,4)=$P($G(^ADEOPS(ABMOPS,88)),U) ; Tooth mnemonic (d) (27)
.;
.; Procedure date (24)
.S $P(ABMF(ABM("F")),U)=$P(ABM(0),U,7) ; DOS (24)
.S $P(ABMF(ABM("F")),U,2)=$P(ABM(0),U,11) ;Area of Oral Cavity (25)
.S $P(ABMF(ABM("F")),U,3)=$P(ABM(0),U,12) ;Tooth system (26)
.;
.S $P(ABMF(ABM("F")),U,5)=$P(ABM(0),U,6) ; Tooth surface (28)
.S $P(ABMF(ABM("F")),U,9)=$P(^AUTTADA(+ABM(0),0),U,2) ; Svc desc (30)
.S $P(ABMF(ABM("F")),U,6)=$P(^AUTTADA(+ABM(0),0),U) ; Procedure # (29)
.;S $P(ABMF(ABM("F")),U,7)=$P(ABM(0),U,4) ;Coor. DX (29a) ;abm*2.6*19 IHS/SD/AML HEAT181886 Translate numeric corres DX to alpha
.;start new abm*2.6*19 IHS/SD/AML HEAT181886 translate numeric corres DX to alpha
.S ABMCORDX=$P(ABM(0),U,4)
.S ABMCORDX=$P(ABMCORDX,",",1,4)
.F ABMTMP=1:1:$L(ABMCORDX,",") D
..S $P(ABMCORDX,",",ABMTMP)=$P("A^B^C^D^","^",$P(ABMCORDX,",",ABMTMP))
.S $P(ABMF(ABM("F")),U,7)=$TR(ABMCORDX,",") ;Coor. DX (29a)
.;end new abm*2.6*19 HEAT181886
.S $P(ABMF(ABM("F")),U,8)=$P(ABM(0),U,9) ;Qty(29b)
.;
.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,6)=ABMDENP_$P(ABMF(ABM("F")),U,6)
.;
.S ABM("CHRG")=+$P(ABM(0),U,8)
.S $P(ABMF(ABM("F")),U,10)=$S(+$G(ABMP("FLAT")):"",1:ABM("CHRG"))*($S($P(ABM(0),U,9):$P(ABM(0),U,9),1:1)) ;Proc fee (31)
.S ABM("TCHRG")=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),2)),U) ; Total fee (33)
.;
.S ABM("I")=ABM("I")+1 ; Increment line counter
.I ABM("I")=10 D
..Q:'$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM))
..S ABM("MORE")=1
..D ^ABMDF34X ; Print form
..S ABM("I")=0
;
OTHER ;
; Other charges on page 3?
I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,21)'="" D
.S $P(ABMF(36),U,2)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,21) ;Other charges (32)
.S ABM("TCHRG")=ABM("TCHRG")+$P(ABMF(36),U,2) ;add to total charges (33)
;
;Put misc services on dental form
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)=ABMMSDT
...S $P(ABMF(ABM("F")),U,6)=ABMED
...S $P(ABMF(ABM("F")),U,8)=ABMMSQTY
...S $P(ABMF(ABM("F")),U,9)=ABMMS
...S $P(ABMF(ABM("F")),U,10)=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 ^ABMDF34X
....S ABM("I")=0
;
; Put RX data on dental form
RXDATA 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,4)=$E(ABMRX,1,3)
...S $P(ABMF(ABM("F")),U,5)=$E(ABMRX,4,8)
...S $P(ABMF(ABM("F")),U,7)=$E(ABMRX,9,99)
...I ABMRXDT]"" S $P(ABMF(ABM("F")),U)=ABMRXDT
...S $P(ABMF(ABM("F")),U,8)=ABMRXCHG
...S ABM("TCHRG")=ABM("TCHRG")+ABMRXCHG
...S ABM("I")=ABM("I")+1
...I ABM("I")=10 D
....Q:($O(ABMRV(ABMRCD,ABMED))=""&($O(ABMRV(ABMRCD))=""))
....S ABM("MORE")=1
....D ^ABMDF34X ; Print form
....S ABM("I")=0
;
D TAIL:ABM("I")
Q
;
RESET ;
; Reset line numbers for BODY
F ABM("F")=25:1:35 K ABMF(ABM("F"))
S ABM("F")=25
Q
;
TAIL ;END OF FORM
I +$G(ABMP("FLAT")) S ABM("TCHRG")=+ABMP("FLAT")
S $P(ABMF(38),U,3)=ABM("TCHRG") ; Total fee charged on bill
S ABM("YTOT")=ABM("TCHRG")
D YTOT^ABMDFUTL
S (ABM("I"),ABM("TCHRG"))=0
D ^ABMDF34X ; Print form
Q
ABMDF34 ; IHS/SD/SDR - ADA-2012 Dental Export Routine ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**14,16,19**;NOV 12, 2009;Build 300
+2 ;IHS/SD/SDR - 2.6*14 - HEAT136149 - Fixed box 34 to print 'B' for ICD9 codes.
+3 ;IHS/SD/SDR - 2.6*14 Updated DX^ABMCVAPI call to be numeric
+4 ;IHS/SD/SDR - 2.6*16 HEAT231506 - Added code for 'AB' to print for ICD10.
+5 ;IHS/SD/AML - 2.6*19 - HEAT181886 - Change coor. dx from numeric to alpha
+6 ;
+7 ;************************************************************************************
+8 KILL ABM
+9 SET U="^"
+10 ; Export mode
SET ABMP("EXP")=34
+11 ; Create entry in 3P TX STATUS
DO TXST^ABMDFUTL
+12 ; Initialize active insurer
SET ABMY("N")=0
+13 ; Print a form for every bill within an active insurer
+14 FOR
SET ABMY("N")=$ORDER(ABMY(ABMY("N")))
IF 'ABMY("N")
QUIT
Begin DoDot:1
+15 ; Initialize bill IEN
SET ABMP("BDFN")=""
+16 FOR
SET ABMP("BDFN")=$ORDER(ABMY(ABMY("N"),ABMP("BDFN")))
IF 'ABMP("BDFN")
QUIT
Begin DoDot:2
+17 DO ENT
+18 SET DIE="^ABMDBILL(DUZ(2),"
+19 SET DA=ABMP("BDFN")
+20 SET DR=".04////B;.16////A;.17////"_ABMP("XMIT")
+21 DO ^ABMDDIE
+22 IF $DATA(ABM("DIE-FAIL"))
QUIT
End DoDot:2
End DoDot:1
+23 ;
+24 ; Update 3P TX STATUS
DO TXUPDT^ABMDFUTL
+25 ;
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 and misc data
IF '$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,0))&('$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),43,0)))
QUIT
+4 DO ENT^ABMDF34A
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 KILL ABMP("FLAT")
+4 ; find Flat Rate
DO FRATE^ABMDE2X1
+5 SET (ABM("C"),ABM,ABM("TCHRG"),ABM("I"),ABM("YTOT"))=0
+6 ;
+7 ;S $P(ABMF(36),U)="09" ;(34) ;abm*2.6*14 HEAT136149
+8 ;S $P(ABMF(36),U)="B" ;(34) ;abm*2.6*14 HEAT136149 ;abm*2.6*16 IHS/SD/SDR HEAT231506
+9 ;(34) ;abm*2.6*14 HEAT136149 ;abm*2.6*16 IHS/SD/SDR HEAT231506
SET $PIECE(ABMF(36),U)=$SELECT($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),0)),U,21)=10:"AB",1:"B")
+10 ;(34a)
+11 FOR
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM))
IF 'ABM
QUIT
Begin DoDot:1
+12 SET ABM("C")=+$GET(ABM("C"))+1
+13 SET ABM("X")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM,""))
+14 ;S ABM("DX")=$P($$DX^ABMCVAPI($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U),ABMP("VDT")),U,2) ;abm*2.6*14 updated API call
+15 ;abm*2.6*14 updated API call
SET ABM("DX")=$PIECE($$DX^ABMCVAPI(+$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U),ABMP("VDT")),U,2)
+16 IF ABM=1
SET $PIECE(ABMF(37),U)=ABM("DX")
+17 IF ABM=2
SET $PIECE(ABMF(38),U)=ABM("DX")
+18 IF ABM=3
SET $PIECE(ABMF(37),U,2)=ABM("DX")
+19 IF ABM=4
SET $PIECE(ABMF(38),U,2)=ABM("DX")
End DoDot:1
IF (ABM("C")=4)
QUIT
+20 SET (ABM,ABM("C"),ABM("X"),ABM("DX"))=0
+21 FOR
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM))
IF 'ABM
QUIT
Begin DoDot:1
+22 SET ABM(0)=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM,0))
+23 IF ABM("I")=0
DO RESET
+24 ; Increment line counter
SET ABM("F")=ABM("F")+1
+25 IF $PIECE(ABM(0),U,5)
Begin DoDot:2
+26 ; IEN to DENTAL OPERATIVE SITE
SET ABMOPS=$PIECE(ABM(0),U,5)
+27 ; Tooth mnemonic (d) (27)
SET $PIECE(ABMF(ABM("F")),U,4)=$PIECE($GET(^ADEOPS(ABMOPS,88)),U)
End DoDot:2
+28 ;
+29 ; Procedure date (24)
+30 ; DOS (24)
SET $PIECE(ABMF(ABM("F")),U)=$PIECE(ABM(0),U,7)
+31 ;Area of Oral Cavity (25)
SET $PIECE(ABMF(ABM("F")),U,2)=$PIECE(ABM(0),U,11)
+32 ;Tooth system (26)
SET $PIECE(ABMF(ABM("F")),U,3)=$PIECE(ABM(0),U,12)
+33 ;
+34 ; Tooth surface (28)
SET $PIECE(ABMF(ABM("F")),U,5)=$PIECE(ABM(0),U,6)
+35 ; Svc desc (30)
SET $PIECE(ABMF(ABM("F")),U,9)=$PIECE(^AUTTADA(+ABM(0),0),U,2)
+36 ; Procedure # (29)
SET $PIECE(ABMF(ABM("F")),U,6)=$PIECE(^AUTTADA(+ABM(0),0),U)
+37 ;S $P(ABMF(ABM("F")),U,7)=$P(ABM(0),U,4) ;Coor. DX (29a) ;abm*2.6*19 IHS/SD/AML HEAT181886 Translate numeric corres DX to alpha
+38 ;start new abm*2.6*19 IHS/SD/AML HEAT181886 translate numeric corres DX to alpha
+39 SET ABMCORDX=$PIECE(ABM(0),U,4)
+40 SET ABMCORDX=$PIECE(ABMCORDX,",",1,4)
+41 FOR ABMTMP=1:1:$LENGTH(ABMCORDX,",")
Begin DoDot:2
+42 SET $PIECE(ABMCORDX,",",ABMTMP)=$PIECE("A^B^C^D^","^",$PIECE(ABMCORDX,",",ABMTMP))
End DoDot:2
+43 ;Coor. DX (29a)
SET $PIECE(ABMF(ABM("F")),U,7)=$TRANSLATE(ABMCORDX,",")
+44 ;end new abm*2.6*19 HEAT181886
+45 ;Qty(29b)
SET $PIECE(ABMF(ABM("F")),U,8)=$PIECE(ABM(0),U,9)
+46 ;
+47 ; Dent remap
SET ABMDENP=$PIECE($GET(^ABMDREC(ABMP("INS"),0)),U,2)
+48 IF ABMDENP=""
SET ABMDENP=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,11)
+49 IF ABMDENP=""
SET ABMDENP=$PIECE($GET(^ABMDPARM(DUZ(2),1,3)),U,11)
+50 IF ABMDENP]""
SET $PIECE(ABMF(ABM("F")),U,6)=ABMDENP_$PIECE(ABMF(ABM("F")),U,6)
+51 ;
+52 SET ABM("CHRG")=+$PIECE(ABM(0),U,8)
+53 ;Proc fee (31)
SET $PIECE(ABMF(ABM("F")),U,10)=$SELECT(+$GET(ABMP("FLAT")):"",1:ABM("CHRG"))*($SELECT($PIECE(ABM(0),U,9):$PIECE(ABM(0),U,9),1:1))
+54 ; Total fee (33)
SET ABM("TCHRG")=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),2)),U)
+55 ;
+56 ; Increment line counter
SET ABM("I")=ABM("I")+1
+57 IF ABM("I")=10
Begin DoDot:2
+58 IF '$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM))
QUIT
+59 SET ABM("MORE")=1
+60 ; Print form
DO ^ABMDF34X
+61 SET ABM("I")=0
End DoDot:2
End DoDot:1
IF $DATA(DUOUT)
QUIT
+62 ;
OTHER ;
+1 ; Other charges on page 3?
+2 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,21)'=""
Begin DoDot:1
+3 ;Other charges (32)
SET $PIECE(ABMF(36),U,2)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,21)
+4 ;add to total charges (33)
SET ABM("TCHRG")=ABM("TCHRG")+$PIECE(ABMF(36),U,2)
End DoDot:1
+5 ;
+6 ;Put misc services on dental form
+7 NEW ABMRV
+8 ;obtain misc services data in ABMRV array
DO 43^ABMERGR2
+9 SET ABMRCD=-1
+10 FOR
SET ABMRCD=$ORDER(ABMRV(ABMRCD))
IF ABMRCD=""
QUIT
Begin DoDot:1
+11 SET ABMED=""
+12 FOR
SET ABMED=$ORDER(ABMRV(ABMRCD,ABMED))
IF ABMED=""
QUIT
Begin DoDot:2
+13 SET ABMCNTR=0
+14 FOR
SET ABMCNTR=$ORDER(ABMRV(ABMRCD,ABMED,ABMCNTR))
IF ABMCNTR=""
QUIT
Begin DoDot:3
+15 IF ABM("I")=0
DO RESET
+16 SET ABM("F")=ABM("F")+1
+17 ;CPT name ;CSV-c
SET ABMMS=$PIECE($$CPT^ABMCVAPI($ORDER(^ICPT("B",ABMED,"")),ABMP("VDT")),U,3)
+18 ;date
SET ABMMSDT=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,10)
+19 ;quantity
SET ABMMSQTY=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,5)
+20 ;charge
SET ABMMSCHG=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6)
+21 IF ABMMSDT]""
Begin DoDot:4
+22 SET $PIECE(ABMF(ABM("F")),U)=ABMMSDT
End DoDot:4
+23 SET $PIECE(ABMF(ABM("F")),U,6)=ABMED
+24 SET $PIECE(ABMF(ABM("F")),U,8)=ABMMSQTY
+25 SET $PIECE(ABMF(ABM("F")),U,9)=ABMMS
+26 SET $PIECE(ABMF(ABM("F")),U,10)=ABMMSCHG
+27 SET ABM("I")=ABM("I")+1
+28 IF ABM("I")=10
Begin DoDot:4
+29 IF ($ORDER(ABMRV(ABMRCD,ABMED))=""&($ORDER(ABMRV(ABMRCD))=""))
QUIT
+30 SET ABM("MORE")=1
+31 DO ^ABMDF34X
+32 SET ABM("I")=0
End DoDot:4
End DoDot:3
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
+33 ;
+34 ; Put RX data on dental form
RXDATA NEW ABMRV
+1 ; Obtain RX data in ABMRV array
DO 23^ABMERGR2
+2 SET ABMRCD=-1
+3 FOR
SET ABMRCD=$ORDER(ABMRV(ABMRCD))
IF ABMRCD=""
QUIT
Begin DoDot:1
+4 SET ABMED=0
+5 FOR
SET ABMED=$ORDER(ABMRV(ABMRCD,ABMED))
IF '+ABMED
QUIT
Begin DoDot:2
+6 SET ABMCNTR=0
+7 FOR
SET ABMCNTR=$ORDER(ABMRV(ABMRCD,ABMED,ABMCNTR))
IF ABMCNTR=""
QUIT
Begin DoDot:3
+8 IF ABM("I")=0
DO RESET
+9 SET ABM("F")=ABM("F")+1
+10 ; NDC# name
SET ABMRX=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,9)
+11 ; date/time
SET ABMRXDT=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,10)
+12 ; Quantity
SET ABMRXQTY=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,5)
+13 ; Charge
SET ABMRXCHG=$PIECE(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6)
+14 SET $PIECE(ABMF(ABM("F")),U,4)=$EXTRACT(ABMRX,1,3)
+15 SET $PIECE(ABMF(ABM("F")),U,5)=$EXTRACT(ABMRX,4,8)
+16 SET $PIECE(ABMF(ABM("F")),U,7)=$EXTRACT(ABMRX,9,99)
+17 IF ABMRXDT]""
SET $PIECE(ABMF(ABM("F")),U)=ABMRXDT
+18 SET $PIECE(ABMF(ABM("F")),U,8)=ABMRXCHG
+19 SET ABM("TCHRG")=ABM("TCHRG")+ABMRXCHG
+20 SET ABM("I")=ABM("I")+1
+21 IF ABM("I")=10
Begin DoDot:4
+22 IF ($ORDER(ABMRV(ABMRCD,ABMED))=""&($ORDER(ABMRV(ABMRCD))=""))
QUIT
+23 SET ABM("MORE")=1
+24 ; Print form
DO ^ABMDF34X
+25 SET ABM("I")=0
End DoDot:4
End DoDot:3
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
+26 ;
+27 IF ABM("I")
DO TAIL
+28 QUIT
+29 ;
RESET ;
+1 ; Reset line numbers for BODY
+2 FOR ABM("F")=25:1:35
KILL ABMF(ABM("F"))
+3 SET ABM("F")=25
+4 QUIT
+5 ;
TAIL ;END OF FORM
+1 IF +$GET(ABMP("FLAT"))
SET ABM("TCHRG")=+ABMP("FLAT")
+2 ; Total fee charged on bill
SET $PIECE(ABMF(38),U,3)=ABM("TCHRG")
+3 SET ABM("YTOT")=ABM("TCHRG")
+4 DO YTOT^ABMDFUTL
+5 SET (ABM("I"),ABM("TCHRG"))=0
+6 ; Print form
DO ^ABMDF34X
+7 QUIT
