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

ABMDES4.m

Go to the documentation of this file. 
  1. ABMDES4 ; IHS/ASDST/DMJ - ADA Form Dental Charge Summary ;   
  1.  ;;2.6;IHS 3P BILLING SYSTEM;**11,14**;NOV 12, 2009;Build 238
  1.  ;
  1.  ; IHS/SD/EFG - V2.5 P8 - IM16385
  1.  ;   Fix header wrapping; include misc services
  1.  ; IHS/SD/SDR - v2.5 p10 - IM20395
  1.  ;   Split out lines bundled by rev code
  1.  ; IHS/SD/SDR - v2.5 p10 - IM21581
  1.  ;   Added active insurer print to summary
  1.  ;
  1.  ; IHS/SD/SDR - v2.6 CSV
  1.  ;IHS/SD/SDR - 2.6*14 5/8/14 - HEAT163277 - Made change for RX multiple so charges would be counted in total sooner
  1.  ;
  1.  N ABM
  1.  Q:'$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,0))&('$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),43,0)))
  1.  D HD
  1.  G XIT:$D(DUOUT)
  1.  D WRT
  1.  Q:$G(ABMQUIET)
  1.  F  W ! Q:$Y+4>IOSL
  1.  S DIR(0)="E"
  1.  D ^DIR
  1.  K DIR
  1.  ;
  1. XIT ;
  1.  K DUOUT
  1.  Q
  1.  ;
  1. HD ;
  1.  ; SCREEN HEADER
  1.  Q:$G(ABMQUIET)
  1.  W $$EN^ABMVDF("IOF")
  1.  W !?15,"***** ADA FORM DENTAL CHARGE SUMMARY *****"
  1.  W !!,"Active Insurer: ",$P($G(^AUTNINS(ABMP("INS"),0)),U),!
  1.  W !!?2,"Tooth",?9,"Surface",?20,"Description of Service",?52,"Date",?60,"ADA Code",?73,"Fee"
  1.  W !,"-------------------------------------------------------------------------------"
  1.  Q
  1.  ;
  1. WRT ;
  1.  ;start new code abm*2.6*11 HEAT117086
  1.  S ABM("TCHRG")=0
  1.  S ABM=0
  1.  I '$G(ABMQUIET) W !
  1.  F  S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),43,ABM)) Q:'ABM  S ABM(0)=^(ABM,0)  D
  1.  .I $P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)'="T1015" Q  ;CSV-c
  1.  .S ABM("CHRG")=$P(ABM(0),U,4)
  1.  .S ABM("CHRG")=ABM("CHRG")*$P($G(ABM(0)),U,3)
  1.  .S ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
  1.  .Q:$G(ABMQUIET)
  1.  .I $Y+5>IOSL D HD Q:$D(DUOUT)
  1.  .W !
  1.  .W ?18,$E($P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,3),1,30)  ;CSV-c
  1.  .W ?50,$$HDT^ABMDUTL($P(ABM(0),U,7))
  1.  .W ?62,$P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)  ;CSV-c
  1.  .W ?70,$J($FN(ABM("CHRG"),",",2),8)
  1.  ;end new code HEAT117086
  1.  ;
  1.  ;S (ABM("C"),ABM,ABM("TCHRG"))=0  ;abm*2.6*11 HEAT117086
  1.  S (ABM("C"),ABM)=0  ;abm*2.6*11 HEAT117086
  1.  F  S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,ABM)) Q:'ABM  S ABM(0)=^(ABM,0) D  Q:$D(DUOUT)
  1.  .S ABM("CHRG")=$P(ABM(0),U,8)
  1.  .S ABM("CHRG")=ABM("CHRG")*$P($G(ABM(0)),U,9)
  1.  .S ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
  1.  .Q:$G(ABMQUIET)
  1.  .I $Y+5>IOSL D HD Q:$D(DUOUT)
  1.  .W !
  1.  .I $P(ABM(0),U,5) D
  1.  ..S ABMOPS=$P(ABM(0),U,5)
  1.  ..S ABMTMP=$P($G(^ADEOPS(ABMOPS,88)),U)
  1.  ..S:ABMTMP["D" ABMTMP=$P($G(^ADEOPS(ABMOPS,0)),U,4)
  1.  ..W ?2,ABMTMP
  1.  .W ?9,$P(ABM(0),U,6)
  1.  .W ?18,$E($P(^AUTTADA(+ABM(0),0),U,2),1,30)
  1.  .W ?50,$$HDT^ABMDUTL($P(ABM(0),U,7))
  1.  .W ?62,$P(^AUTTADA(+ABM(0),0),U)
  1.  .W ?70,$J($FN(ABM("CHRG"),",",2),8)
  1.  ;
  1.  S ABM=0
  1.  I '$G(ABMQUIET) W !
  1.  F  S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),43,ABM)) Q:'ABM  S ABM(0)=^(ABM,0)  D
  1.  .I $P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)="T1015" Q  ;CSV-c  ;abm*2.6*11 HEAT117086
  1.  .S ABM("CHRG")=$P(ABM(0),U,4)
  1.  .S ABM("CHRG")=ABM("CHRG")*$P($G(ABM(0)),U,3)
  1.  .S ABM("TCHRG")=ABM("TCHRG")+ABM("CHRG")
  1.  .Q:$G(ABMQUIET)
  1.  .I $Y+5>IOSL D HD Q:$D(DUOUT)
  1.  .W !
  1.  .W ?18,$E($P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,3),1,30)  ;CSV-c
  1.  .W ?50,$$HDT^ABMDUTL($P(ABM(0),U,7))
  1.  .W ?62,$P($$CPT^ABMCVAPI(+ABM(0),ABMP("VDT")),U,2)  ;CSV-c
  1.  .W ?70,$J($FN(ABM("CHRG"),",",2),8)
  1.  ;
  1.  ; Include RX charges
  1.  I '$G(ABMQUIET) W !
  1.  N ABMRV
  1.  S DA=0
  1.  F  S DA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA)) Q:'DA  D
  1.  .F J=1:1:5 S ABM(J)=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0),U,J)
  1.  .S ABMCNTR=+$O(ABMRV(+ABM(2),ABM(1),0))
  1.  .S $P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U)=ABM(2)  ; revenue code IEN
  1.  .S $P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,5)=$P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,5)+ABM(3)  ; cumulative units
  1.  .S ABM(6)=ABM(3)*ABM(4)+ABM(5)  ; units * units cost + dispense fee
  1.  .S ABM(6)=$J(ABM(6),1,2)
  1.  .S $P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,6)=$P(ABMRV(+ABM(2),ABM(1),ABMCNTR),U,6)+ABM(6)   ; cumulative charges
  1.  .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
  1.  ;
  1.  ;S ABMRCD=0  ;abm*2.6*14 HEAT163277
  1.  S ABMRCD=-1  ;abm*2.6*14 HEAT163277
  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  ;abm*2.6*14 HEAT163277
  1.  ..S ABMCNTR=-1  ;abm*2.6*14 HEAT163277
  1.  ..F  S ABMCNTR=$O(ABMRV(ABMRCD,ABMED,ABMCNTR)) Q:ABMCNTR=""  D
  1.  ...S ABMRXCHG=$P(ABMRV(ABMRCD,ABMED,ABMCNTR),U,6)  ;Charge
  1.  ...S ABM("TCHRG")=ABM("TCHRG")+ABMRXCHG
  1.  ...Q:$G(ABMQUIET)
  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.  ...I $Y+5>IOSL D HD Q:$D(DUOUT)
  1.  ...W !
  1.  ...W ?2,$E(ABMRX,1,48)
  1.  ...W ?50,$$HDT^ABMDUTL(ABMRXDT)
  1.  ...W ?62,"QTY "_ABMRXQTY
  1.  ...W ?70,$J($FN(ABMRXCHG,",",2),8)
  1.  ;
  1.  I '$G(ABMQUIET) D
  1.  .W !?71,"========"
  1.  .W !?10,"TOTAL CHARGE",?69,$J($FN(ABM("TCHRG"),",",2),9)
  1.  I $D(ABMP("FLAT")) D
  1.  .S ABM("TCHRG")=$P(ABMP("FLAT"),U)
  1.  .Q:$G(ABMQUIET)
  1.  .W !!?49,"Flat Rate Applied:",?69,$J($FN(ABM("TCHRG"),",",2),9)
  1.  S:ABM("TCHRG") ABMP("EXP",ABMP("EXP"))=ABM("TCHRG")
  1.  Q