Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABMDF26

ABMDF26.m

Go to the documentation of this file. 
  1. ABMDF26 ; IHS/ASDST/DMJ - ADA-99 Dental Export Routine V2000 ;  
  1.  ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
  1.  ;Original;TMD;09/12/95 8:48 AM
  1.  ;
  1.  ; IHS/SD/SDR - v2.5 p8 - IM12857/IM13525
  1.  ;    Created new export mode for ADA-99 v2000 format
  1.  ;
  1.  ; IHS/SD/SDR - v2.5 p10 - IM20395
  1.  ;   Split out lines bundled by rev code
  1.  ;    
  1.  K ABM
  1.  S U="^"
  1.  S ABMP("EXP")=26                ; Export mode
  1.  D TXST^ABMDFUTL                 ; Create entry in 3P TX STATUS
  1.  S ABMY("N")=0                   ; Initialize active insurer
  1.  ; Print a form for every bill within an active insurer
  1.  F  S ABMY("N")=$O(ABMY(ABMY("N"))) Q:'ABMY("N")  D
  1.  .S ABMP("BDFN")=""             ; Initialize bill IEN
  1.  .F  S ABMP("BDFN")=$O(ABMY(ABMY("N"),ABMP("BDFN"))) Q:'ABMP("BDFN")  D
  1.  ..D ENT
  1.  ..S DIE="^ABMDBILL(DUZ(2),"
  1.  ..S DA=ABMP("BDFN")
  1.  ..S DR=".04////B;.16////A;.17////"_ABMP("XMIT")
  1.  ..D ^ABMDDIE
  1.  ..Q:$D(ABM("DIE-FAIL"))
  1.  ;
  1.  D TXUPDT^ABMDFUTL               ; Update 3P TX STATUS
  1.  ;
  1. XIT ;
  1.  K ABM,ABMF,ABMV
  1.  Q
  1.  ;
  1. ENT ;EP for getting data and printing form
  1.  K ABMF
  1.  Q:'$D(^ABMDBILL(DUZ(2),ABMP("BDFN"),0))     ; Quit if no bill data
  1.  Q:'$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,0))  ; Quit if no dental data
  1.  D ENT^ABMDF26A,BODY
  1.  Q
  1.  ;
  1. BODY ;
  1.  ; For each dental entry in the bill file, find and print data.
  1.  S ABMX("INS")=ABMP("INS")       ; IEN to INSURER
  1.  K ABMP("FLAT")
  1.  D FRATE^ABMDE2X1                ; find Flat Rate
  1.  S (ABM("C"),ABM,ABM("TCHRG"),ABM("I"),ABM("YTOT"))=0
  1.  F  S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM)) Q:'ABM  D  Q:$D(DUOUT)
  1.  .S ABM(0)=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM,0))
  1.  .D RESET:ABM("I")=0
  1.  .S ABM("F")=ABM("F")+1         ; Increment line counter
  1.  .I $P(ABM(0),U,5) D
  1.  ..S ABMOPS=$P(ABM(0),U,5)     ; IEN to DENTAL OPERATIVE SITE
  1.  ..S $P(ABMF(ABM("F")),U,4)=$P($G(^ADEOPS(ABMOPS,88)),U)    ; Tooth mnemonic (d)
  1.  ..S:ABMF(ABM("F"))["D" $P(ABMF(ABM("F")),U,4)=$P($G(^ADEOPS(ABMOPS,0)),U,4) ; Tooth synonym
  1.  .S $P(ABMF(ABM("F")),U,5)=$P(ABM(0),U,6)                 ; Tooth surf
  1.  .S $P(ABMF(ABM("F")),U,9)=$P(^AUTTADA(+ABM(0),0),U,2)    ; Svc desc
  1.  .S $P(ABMF(ABM("F")),U)=$E($P(ABM(0),U,7),4,5)           ; DOS MM
  1.  .S $P(ABMF(ABM("F")),U,2)=$E($P(ABM(0),U,7),6,7)         ; DOS DD
  1.  .S $P(ABMF(ABM("F")),U,3)=($E($P(ABM(0),U,7),1,3)+1700)  ; DOS YYYY
  1.  .S $P(ABMF(ABM("F")),U,7)=$P(^AUTTADA(+ABM(0),0),U)      ; Procedure #
  1.  .S ABMDENP=$P($G(^ABMDREC(ABMP("INS"),0)),U,2)           ; Dent remap
  1.  .S:ABMDENP="" ABMDENP=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,11)
  1.  .S:ABMDENP="" ABMDENP=$P($G(^ABMDPARM(DUZ(2),1,3)),U,11)
  1.  .S:ABMDENP]"" $P(ABMF(ABM("F")),U,7)=ABMDENP_$P(ABMF(ABM("F")),U,7)
  1.  .S ABM("CHRG")=+$P(ABM(0),U,8)
  1.  .S $P(ABMF(ABM("F")),U,10)=$S(+$G(ABMP("FLAT")):"",1:ABM("CHRG"))
  1.  .S ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")                 ; Proc fee
  1.  .;
  1.  .S ABM("I")=ABM("I")+1         ; Increment line counter
  1.  .I ABM("I")=10 D
  1.  ..Q:'$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM))
  1.  ..S ABM("MORE")=1
  1.  ..D ^ABMDF26X                 ; Print form
  1.  ..S ABM("I")=0
  1.  ;
  1.  ; Put RX data on dental form
  1.  N ABMRV
  1.  D 23^ABMERGR2    ; Obtain RX data in ABMRV array
  1.  S ABMRCD=-1
  1.  F  S ABMRCD=$O(ABMRV(ABMRCD)) Q:ABMRCD=""  D
  1.  .S ABMED=0
  1.  .F  S ABMED=$O(ABMRV(ABMRCD,ABMED)) Q:'+ABMED  D  Q:$D(DUOUT)
  1.  ..S ABMCNTR=0
  1.  ..F  S ABMCNTR=$O(ABMRV(ABMRCD,ABMED,ABMCNTR)) Q:ABMCNTR=""  D
  1.  ...D RESET:ABM("I")=0
  1.  ...S ABM("F")=ABM("F")+1
  1.  ...S ABMRX=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,9)     ; NDC# name
  1.  ...S ABMRXDT=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,10)  ; date/time
  1.  ...S ABMRXQTY=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,5)  ; Quantity
  1.  ...S ABMRXCHG=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6)  ; Charge
  1.  ...S $P(ABMF(ABM("F")),U,4)=$E(ABMRX,1,3)
  1.  ...S $P(ABMF(ABM("F")),U,5)=$E(ABMRX,4,8)
  1.  ...S $P(ABMF(ABM("F")),U,9)=$E(ABMRX,9,99)
  1.  ...I ABMRXDT]"" D
  1.  ....S $P(ABMF(ABM("F")),U)=$E(ABMRXDT,4,5)
  1.  ....S $P(ABMF(ABM("F")),U,2)=$E(ABMRXDT,6,7)
  1.  ....S $P(ABMF(ABM("F")),U,3)=$E(ABMRXDT,1,3)+1700
  1.  ...S $P(ABMF(ABM("F")),U,8)=ABMRXQTY
  1.  ...S $P(ABMF(ABM("F")),U,10)=ABMRXCHG
  1.  ...S ABM("TCHRG")=ABM("TCHRG")+ABMRXCHG
  1.  ...S ABM("I")=ABM("I")+1
  1.  ...I ABM("I")=10 D
  1.  ....Q:($O(ABMRV(ABMRCD,ABMED))=""&($O(ABMRV(ABMRCD))=""))
  1.  ....S ABM("MORE")=1
  1.  ....D ^ABMDF26X                         ; Print form
  1.  ....S ABM("I")=0
  1.  ;
  1.  D TAIL:ABM("I")
  1.  Q
  1.  ;
  1. RESET ;
  1.  ; Reset line numbers for BODY
  1.  F ABM("F")=41:1:48 K ABMF(ABM("F"))
  1.  S ABM("F")=40
  1.  Q
  1.  ;
  1. TAIL ;END OF FORM
  1.  I +$G(ABMP("FLAT")) S ABM("TCHRG")=+ABMP("FLAT")
  1.  S $P(ABMF(50),U)=ABM("TCHRG")   ; Total fee charged on bill
  1.  S ABM("YTOT")=ABM("TCHRG")
  1.  D YTOT^ABMDFUTL
  1.  S (ABM("I"),ABM("TCHRG"))=0
  1.  D ^ABMDF26X                     ; Print form
  1.  Q