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

ABMEHGRV.m

Go to the documentation of this file. 
  1. ABMEHGRV ; IHS/ASDST/DMJ - GET ANCILLARY SVCS REVENUE CODE INFO ;   
  1.  ;;2.6;IHS 3P BILLING SYSTEM;**6,7,11,13,21,22,23,27**;NOV 12, 2009;Build 486
  1.  ;Original;DMJ;01/26/96 4:02 PM
  1.  ; IHS/ASDS/DMJ - 09/06/00 - V2.4 Patch 3 (no NOIS)
  1.  ;
  1.  ;IHS/SD/SDR 2.5 p8 task 6 Added code for new ambulance multiple 47
  1.  ;IHS/SD/SDR 2.5 p10 IM20395 Split out lines bundled by rev codes
  1.  ;IHS/SD/SDR 2.5 p11 ambulance and pt stmt.  Made change to getting ambulance line items.  Found it wasn't
  1.  ;   working right when they were doing new pt stmt in patch 11.
  1.  ;
  1.  ;IHS/SD/SDR 2.6 CSV
  1.  ;IHS/SD/SDR 2.6*6 line item control number
  1.  ;IHS/SD/SDR 2.6*13 HEAT117086 removed code to put T1015 as top line; doesn't work here.
  1.  ;IHS/SD/SDR 2.6*21 HEAT205579 code to put T1015 as top line in 837P file.
  1.  ;IHS/SD/SDR 2.6*22 HEAT335246 Made it so if the insurer is setup to print the NDC it will do flat rate and itemized on a claim, with either the default CPT
  1.  ;  printing with the flat rate or the flat rate printing on the first line item.
  1.  ;IHS/SD/SDR 2.6*23 HEAT247169 Added code to check subfile 43 if visit type is 997.
  1.  ;IHS/SD/SDR 2.6*27 CR10326 Correction so coordinating dx will print when billing flat rate; moved line down and made it a single dot
  1.  ;
  1. START ;START HERE
  1.  K ABM,ABMRV
  1.  D P1
  1.  ;D FLP
  1.  Q
  1.  ;
  1. P1 ;EP - SET UP ABMRV ARRAY
  1.  ; 21 - Med/Surg
  1.  ; 23 - Pharmacy
  1.  ; 25 - Room and Board
  1.  ; 27 - Medical Procedures
  1.  ; 33 - Dental
  1.  ; 35 - Radiology
  1.  ; 37 - Laboratory
  1.  ; 39 - Anesthesia
  1.  ; 43 - Miscellaneous Services
  1.  ; 45 - Supplies
  1.  ; 47 - Ambulance
  1.  ; 
  1.  ; if not flat rate .....
  1.  D FRATE^ABMDF11
  1.  ;I '$D(ABMP("FLAT")) D  ;abm*2.6*22 IHS/SD/SDR HEAT335246
  1.  I '$D(ABMP("FLAT"))!(($D(ABMP("FLAT")))&($P($G(^ABMNINS(DUZ(2),ABMP("INS"),0)),U,14)="Y")) D  ;abm*2.6*22 IHS/SD/SDR HEAT335246
  1.  .N I
  1.  .F I=21,23,25,27,33,35,37,39,43,45,47 D
  1.  ..; dont get pharmacy if RX bill status is unbillable
  1.  ..I $P($G(^AUTNINS(ABMP("INS"),2)),"^",3)="U",I=23 Q
  1.  ..;this will make only viewable pages in CE show on bill, not everything
  1.  ..I ABMP("VTYP")=998,((I'=33)&(I'=43)) Q  ;dental
  1.  ..;I ABMP("VTYP")=997,(I'=23) Q  ;pharmacy  ;abm*2.6*23 IHS/SD/SDR HEAT247169
  1.  ..I ABMP("VTYP")=997,((I'=23)&(I'=43)) Q  ;pharmacy  ;abm*2.6*23 IHS/SD/SDR HEAT247169
  1.  ..I ABMP("VTYP")=996,(I'=37) Q  ;lab
  1.  ..I ABMP("VTYP")=995,(I'=35) Q  ;rad
  1.  ..I ABMP("CLIN")="A3",((I'=43)&(I'=47)) Q  ;ambulance
  1.  ..I ABMP("CLIN")'="A3",(I=47) Q
  1.  ..K ABM
  1.  ..D @(I_"^ABMEHGR2")  ; get ancillary services revenue code info
  1.  ;
  1.  ;start new code abm*2.6*11 HEAT117086
  1.  ;I ABMP("ITYPE")="D" D  ;abm*2.6*13 HEAT135507
  1.  ;start new abm*2.6*21 IHS/SD/SDR HEAT205579
  1.  I (($P($G(^AUTNINS(ABMP("INS"),0)),U)="ARBOR HEALTH PLAN")!($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="D"))&($D(ABMRV)) D
  1.  .S ABMIS=$O(ABMRV(0))
  1.  .S ABMJS=$O(ABMRV(ABMIS,0))
  1.  .S ABMKS=$O(ABMRV(ABMIS,ABMJS,0))
  1.  .S ABMI=0
  1.  .F  S ABMI=$O(ABMRV(ABMI)) Q:'ABMI  D
  1.  ..S ABMJ=0
  1.  ..F  S ABMJ=$O(ABMRV(ABMI,ABMJ)) Q:'ABMJ  D
  1.  ...S ABMK=0
  1.  ...F  S ABMK=$O(ABMRV(ABMI,ABMJ,ABMK)) Q:'ABMK  D
  1.  ....I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,2)'="T1015" Q
  1.  ....S ABMTMP("TMP")=$G(ABMRV(ABMIS,ABMJS,ABMKS))
  1.  ....S ABMRV(ABMIS,ABMJS,ABMKS)=$G(ABMRV(ABMI,ABMJ,ABMK))
  1.  ....S ABMRV(ABMI,ABMJ,ABMK)=$G(ABMTMP("TMP"))
  1.  K ABMI,ABMJ,ABMK,ABMTMP
  1.  ;end new abm*2.6*21 IHS/SD/SDR HEAT205579
  1.  ;end new code HEAT117086
  1.  ;
  1.  I $P($G(^DIC(40.7,$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),0)),U,10),0)),U,2)="A3" D
  1.  .S ABMODMOD=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,14)_$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,16)
  1.  .S I=0
  1.  .F  S I=$O(ABMRV(I)) Q:'I  D
  1.  ..S J=""
  1.  ..S J=$O(ABMRV(I,J)) Q:J=""  D
  1.  ...S K=0
  1.  ...F  S K=$O(ABMRV(I,J,K)) Q:K=""  D
  1.  ....I $P(ABMRV(I,J,K),U,3)="Q" S ABMQLFLG=1
  1.  .S I=0
  1.  .F  S I=$O(ABMRV(I)) Q:'I  D
  1.  ..S J=""
  1.  ..F  S J=$O(ABMRV(I,J)) Q:J=""  D
  1.  ...S K=0
  1.  ...F  S K=$O(ABMRV(I,J,K)) Q:K=""  D
  1.  ....I $G(ABMQLFLG)=1,($P(ABMRV(I,J,K),U,3)'="QL") S $P(ABMRV(I,J,K),U,3)=""
  1.  ....I $G(ABMQLFLG)'=1 S $P(ABMRV(I,J,K),U,3)=$S($P($G(ABMRV(I,J,K)),U,3)="":ABMODMOD,1:$P(ABMRV(I,J,K),U,3)_":"_ABMODMOD)
  1.  K ABMQLFLG
  1.  ;
  1.  ; if flat rate ....
  1.  I $D(ABMP("FLAT")) D
  1.  .I (($P($G(^ABMNINS(DUZ(2),ABMP("INS"),0)),U,14)="Y")&(+$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)=0)) Q  ;print the NDC and there's no default CPT  ;abm*2.6*22 IHS/SD/SDR HEAT335246
  1.  .N I
  1.  .F I=1:1:3 S ABM(I)=$P(ABMP("FLAT"),"^",I)
  1.  .S ABMRV(1,1,1)=+ABM(2)_"^^^^"_ABM(3)_"^"_(ABM(1)*ABM(3))_"^^"_ABM(1)
  1.  .;S $P(ABMRV(1,1,1),U,12)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),2)),U,9)  ;abm*2.6*6 line item control number  ;abm*2.6*7 HEAT38591
  1.  .S $P(ABMRV(1,1,1),U,38)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),2)),U,9)  ;abm*2.6*7 HEAT38591
  1.  .S ABMCPT=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",16) I ABMCPT D
  1.  ..S ABMCPT=$P($$CPT^ABMCVAPI(ABMCPT,ABMP("VDT")),U,2)  ;CSV-c
  1.  ..S $P(ABMRV(1,1,1),U,2)=ABMCPT
  1.  ..;S $P(ABMRV(1,1,1),U,11)=1  ;abm*2.6*27 IHS/SD/SDR CR10326
  1.  ..K ABMCDX
  1.  ..Q:$G(ABMP("EXP"))'=11
  1.  ..S $P(ABMRV(+ABM(2),"TOT"),U,2)=ABMCPT
  1.  .S $P(ABMRV(1,1,1),U,11)=1  ;coor dx - default to 1  ;abm*2.6*27 IHS/SD/SDR CR10326 - moved down from above to make a single dot
  1.  .S ABM(4)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),6)),U,6)
  1.  .I ABM(4),ABMP("VTYP")=111 S $P(ABMRV(1,1,1),U,7)=(ABM(4)*ABM(1))
  1.  .;start old code abm*2.6*11 HEAT105003
  1.  .;I ABMP("VTYP")=831 D
  1.  .;.K ABMRV(+ABM(2),0),ABM("831SET")
  1.  .;.N I
  1.  .;.F I=21,27,35 D @(I_"^ABMEHGR2")
  1.  .;.S I=0
  1.  .;.F  S I=$O(ABMRV(I)) Q:'I  D
  1.  .;..N J
  1.  .;..S J=0
  1.  .;..F  S J=$O(ABMRV(I,J)) Q:'J  D
  1.  .;...S K=0
  1.  .;...F  S K=$O(ABMRV(I,J,K)) Q:K=""  D
  1.  .;....S $P(ABMRV(I,J,K),U,6)=0
  1.  .;....S:'$G(ABM("831SET")) $P(ABMRV(I,J,K),U,6)=$P(ABMP("FLAT"),U),ABM("831SET")=1
  1.  .;end old code HEAT105003
  1.  K ABMCPT
  1.  Q
  1.  ;
  1. FLP ;FORMAT LOOP
  1.  F J=5,6,7 S ABM("TOT",J)=0
  1.  S I=0
  1.  F  S I=$O(ABMRV(I)) Q:'I  D
  1.  .D TOT
  1.  .F J=1:1:9 D FMT
  1.  .S ABMRV(I)=$TR(ABMRV(I),"^")
  1.  S ABMRV(9999)="0001^^^^"_ABM("TOT",5)_"^"_ABM("TOT",6)_"^"_ABM("TOT",7)
  1.  S ABMRV(9999,0)=ABMRV(9999)
  1.  S I=9999
  1.  F J=1:1:9 D FMT
  1.  S ABMRV(9999)=$TR(ABMRV(9999),"^")
  1.  K ABM
  1.  Q
  1.  ;
  1. FMT ;Format
  1.  S ABM(J)=$P(ABMRV(I),"^",J)
  1.  I J>4&(J<8) S ABM("TOT",J)=ABM("TOT",J)+ABM(J)
  1.  S ABM("FSTR")=$P("4NR^5^2^2^7NR^10NRJ2^10NRJ2^4^12","^",J)
  1.  S ABM(J)=$$FMT^ABMERUTL(ABM(J),ABM("FSTR"))
  1.  S $P(ABMRV(I),"^",J)=ABM(J)
  1.  Q
  1.  ;
  1. TOT ;TOTAL TO REVENUE CODE
  1.  S J=-1
  1.  F  S J=$O(ABMRV(I,J)) Q:J=""  D
  1.  .S $P(ABMRV(I),U)=I
  1.  .F K=2,3,4 S $P(ABMRV(I),"^",K)=""
  1.  .F K=5,6,7 S $P(ABMRV(I),"^",K)=$P(ABMRV(I),"^",K)+$P(ABMRV(I,J),"^",K)
  1.  Q