- 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
