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

ABMP2627.m

Go to the documentation of this file. 
  1. ABMP2627 ; IHS/SD/SDR - 3P BILLING 2.6 Patch 27 POST INSTALL ;  
  1.  ;;2.6;IHS Third Party Billing;**27**;NOV 12, 2009;Build 486
  1.  ;
  1.  ;IHS/SD/SDR 2.6*27 CR8894 Clean up of fee tables to use new method of storing entries
  1.  ;1  UPDATED
  1.  ;11 SURGICAL (CPT CODE)
  1.  ;13 HCPCS CODE
  1.  ;15 RADIOLOGY (CPT CODE)
  1.  ;17 LABORATORY (CPT CODE)
  1.  ;19 MEDICAL (CPT CODE)
  1.  ;21 DENTAL (ADA CODE)
  1.  ;23 ANESTHESIA (CPT CODE)
  1.  ;25 DRUG
  1.  ;31 REVENUE CODE
  1.  ;32 CHARGE MASTER
  1.  ;
  1. POST ;EP
  1.  K ^ABMFTWC  ;this is the fee table working copy, used to save/merge CPTs and then put back into 3P Fee Table (^ABMDFEE)
  1.  D OOO  ;place add/edit fee options out of order for now
  1.  M ^ABMFTMP("ABM-FT")=^ABMDFEE  ;backup of complete 3P Fee Table file
  1.  D FTLST  ;returns ABM("FTLST",ABMFT); find all fee tables currently being reference in 3P Parameters and 3P Insurer file
  1.  D SKIPFT  ;mark fee tables SKIPPED if they aren't on above list
  1.  ;loop thru list and try to fix each fee table
  1.  S ABMFT=0
  1.  F  S ABMFT=$O(ABM("FTLST",ABMFT)) Q:'ABMFT  D
  1.  .K ^ABMDFEE(ABMFT,"C")  ;kill this xref right away; broken pointers can't be fixed but will be re-indexed after process
  1.  .D PROCESS
  1.  D REINDEX  ;re-index all fee tables when done, even though they may not be complete just yet
  1.  D COMPLETE  ;check if any fee tables are completely done and mark them so
  1.  D FTCHK^ABMCUFE  ;checks if all fee tables are complete; if so, activates/deactivates menu accordingly
  1.  D BMES^XPDUTL("Use the CUFE option to review any fees that need user intervention")
  1.  Q
  1. OOO ;
  1.  ;this tag will mark the following options out of order until the P27 CLEANUP is populated COMPLETED or SKIPPED for
  1.  ;   all fee tables
  1.  ;EDFE Fee Schedule Maintenance [ABMD TM FEE MAINT]
  1.  ;DTFE Transfer Drug Prices from Drug File [ABMD TM FEE DRUG]
  1.  ;FIFE Import Foreign Fee Schedule [ABMD TM FEE FOREIGN]
  1.  ;IDFE Increase/Decrease Fee Schedule [ABMD TM FEE PERCENT]
  1.  ;
  1.  F ABMA="ABMD TM FEE MAINT","ABMD TM FEE DRUG","ABMD TM FEE FOREIGN","ABMD TM FEE PERCENT" D
  1.  .S DA=$O(^DIC(19,"B",ABMA,0))
  1.  .S DIE="^DIC(19,"
  1.  .S DR="2////USE 'CUFE' TO CLEANUP FEE TABLE AND REACTIVATE"
  1.  .D ^DIE
  1.  ;
  1.  ;This section will only apply to test sites that install the patch multiple times; if this isn't done the CUFE option could be out of order
  1.  S DA=$O(^DIC(19,"B","ABMD TM CLEANUP FEE TABLE",0))
  1.  S DIE="^DIC(19,"
  1.  S DR="2////@"
  1.  D ^DIE
  1.  Q
  1. FTLST ;EP
  1.  D BMES^XPDUTL("Looking for active fee schedules...")
  1.  K ABM("FTLST")
  1.  ;find all 3P Parameter fee tables
  1.  S ABMDUZ=0
  1.  F  S ABMDUZ=$O(^ABMDPARM(ABMDUZ)) Q:'ABMDUZ  D
  1.  .S ABMIEN=0
  1.  .F  S ABMIEN=$O(^ABMDPARM(ABMDUZ,ABMIEN)) Q:'ABMIEN  D  ;this really should be '1' all the time, but just in case we'll loop thru them
  1.  ..S ABMFT=$P($G(^ABMDPARM(ABMDUZ,ABMIEN,0)),U,9)
  1.  ..I ABMFT="" Q  ;no fee table entered
  1.  ..I $G(^ABMDFEE(ABMFT,0))="" Q  ;there no fee table with that number
  1.  ..S ABM("FTLST",ABMFT)=1
  1.  ;find all 3P Insurer entries
  1.  S ABMDUZ=0
  1.  F  S ABMDUZ=$O(^ABMNINS(ABMDUZ)) Q:'ABMDUZ  D  ;looping thru just in case different from 3P Parm
  1.  .S ABMIEN=0
  1.  .F  S ABMIEN=$O(^ABMNINS(ABMDUZ,ABMIEN)) Q:'ABMIEN  D
  1.  ..S ABMVT=0
  1.  ..F  S ABMVT=$O(^ABMNINS(ABMDUZ,ABMIEN,1,ABMVT)) Q:'ABMVT  D
  1.  ...S ABMFT=$P($G(^ABMNINS(ABMDUZ,ABMIEN,1,ABMVT,0)),U,5)
  1.  ...I ABMFT="" Q  ;no fee table entered
  1.  ...I $G(^ABMDFEE(ABMFT,0))="" Q  ;there no fee table with that number
  1.  ...S ABM("FTLST",ABMFT)=1
  1.  Q
  1. SKIPFT ;EP
  1.  D BMES^XPDUTL("SKIPPED (OLD) inactive fee schedules...")
  1.  S ABMF=0
  1.  F  S ABMF=$O(^ABMDFEE(ABMF)) Q:'ABMF  D
  1.  .I +$G(ABM("FTLST",ABMF))=1 Q  ;don't label fee tables that are on list (active)
  1.  .I $G(^ABMDFEE(ABMF,0))="" Q  ;this is an insurer/parameter reference to a fee table that doesn't exist
  1.  .S DIE="^ABMDFEE("
  1.  .S DA=ABMF
  1.  .S DR=".06////S"
  1.  .D ^DIE
  1.  Q
  1. PROCESS ;EP
  1.  D BMES^XPDUTL("Reviewing fee schedule #"_ABMFT_" entries...")
  1.  S ABMF("FTEDT")=$P($G(^ABMDFEE(ABMFT,0)),U,5)  ;fee table effective date
  1.  F ABMMLT=11,13,15,17,19,23 D  ;only CPT multiples
  1.  .K ^ABMDFEE(ABMFT,ABMMLT,-1)  ;there are a few -1s that should be removed
  1.  .D MES^XPDUTL($S(ABMMLT=11:"Surgical",ABMMLT=13:"HCPCS",ABMMLT=15:"Radiology",ABMMLT=17:"Laboratory",ABMMLT=19:"Medical",ABMMLT=23:"Anesthesia",1:"")_"...")
  1.  .S ABMF("IEN")=0
  1.  .F  S ABMF("IEN")=$O(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"))) Q:'ABMF("IEN")  D
  1.  ..I $G(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),0))="" K ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q  ;there's no zero node so entry is incomplete
  1.  ..I $D(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),1))<1 K ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q  ;there aren't any effective dates associated with CPT so entry is incomplete - skip it
  1.  ..S ABMF("CPT")=$P($G(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),0)),U)  ;this is the CPT pointer or maybe a CPT code
  1.  ..I (($G(ABMF("CPT"))'="")&($G(^ICPT(ABMF("CPT"),0))="")) S ABMF("CPT")=$O(^ICPT("B",ABMF("IEN"),0))
  1.  ..I ABMF("CPT")="" S ABMF("CPT")=$O(^ICPT("B",ABMF("IEN"),0))  ;it's a CPT; lookup CPT to get IEN
  1.  ..I ABMF("CPT")="" K ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q  ;there's no pointer, remove entry and quit
  1.  ..I (($G(^ICPT(ABMF("CPT"),0))="")&($G(^ICPT(ABMF("IEN"),0))="")) K ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q  ;the pointer is bad, there's no CPT at that pointer
  1.  ..;S ABMF("CPT")=$S(($P($G(^ICPT(ABMF("IEN"),0)),U)'=""):$P($G(^ICPT(ABMF("IEN"),0)),U),1:$P($G(^ICPT(ABMF("CPT"),0)),U))  ;actual CPT code
  1.  ..S ABMACPT=$$ACTIVCPT(ABMF("CPT"))
  1.  ..S ABMF("DCPT")=ABMACPT  ;CPT data
  1.  ..I ($P(ABMF("DCPT"),U)<1) K ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q  ;no such CPT so this will contain '-1^NO SUCH ENTRY' or if inactive will contain '0'
  1.  ..S $P(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),0),U)=ABMF("CPT")  ;this is the CPT IEN of whatever entry was found for the CPT
  1.  ..S ABMF("DCPT")=$$DINUM^ABMFOFS($P(ABMF("DCPT"),U,2))  ;DINUM CPT for fee table
  1.  ..S ABMF("DCCNT")=+$G(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT")))+1  ;increment counter
  1.  ..M ^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"))=^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"))  ;merge whole entry into wc global
  1.  ..S ^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"))=ABMF("DCCNT")  ;DINUM CPT counter
  1.  .K ^ABMDFEE(ABMFT,ABMMLT)  ;remove entire multiple
  1.  .S ^ABMDFEE(ABMFT,ABMMLT,0)="^9002274.01"_ABMMLT_"P^^"  ;reset subfile zero node
  1.  ;
  1.  ;
  1.  ;now look thru working copy global and put back as many entries as I can without intervention
  1.  ;anything left in ABMFTWC after this code will need user intervention using the CUFE option
  1.  S ABMMLT=0
  1.  F  S ABMMLT=$O(^ABMFTWC(ABMFT,ABMMLT)) Q:'ABMMLT  D
  1.  .S ABMF("DCPT")=0
  1.  .F  S ABMF("DCPT")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"))) Q:'ABMF("DCPT")  D
  1.  ..;the CPT was only found once - put back in fee table and stop
  1.  ..I $G(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT")))=1 D
  1.  ...S ABMF("CPT")=$P(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,0),U)
  1.  ...;S $P(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,0),U)=$P($$ACTIVCPT(ABMF("CPT")),U)  ;make .01 field active CPT pointer
  1.  ...D MERGE
  1.  ..;if it gets here there are multiple entries for the same CPT; check if dates are same but fees different - that's an issue
  1.  ..K ABMF("FEECK")
  1.  ..S ABMFEEC=0
  1.  ..S ABMF("DCCNT")=0
  1.  ..F  S ABMF("DCCNT")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"))) Q:'ABMF("DCCNT")  D
  1.  ...;
  1.  ...S ABMF("CPTEDIEN")=0
  1.  ...F  S ABMF("CPTEDIEN")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"))) Q:'ABMF("CPTEDIEN")  D
  1.  ....S ABMF("FEEREC")=$G(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"),0))
  1.  ....S ABMF("FEEDT")=$P(ABMF("FEEREC"),U)  ;fee eff dt
  1.  ....S ABMF("FEE")=$P(ABMF("FEEREC"),U,2)  ;fee
  1.  ....I ($D(ABMF("FEECK",ABMF("FEEDT")))>0)&($G(ABMF("FEECK",ABMF("FEEDT")))'=ABMF("FEE")) D  Q  ;if I find an eff dt with a different fee
  1.  .....S ^ABMFTWC(ABMFT,"FIX",ABMMLT,ABMF("DCPT"))=1  ;what CPT needs intervention
  1.  .....S ABMFEEC=1
  1.  ....S ABMF("FEECK",ABMF("FEEDT"))=ABMF("FEE")  ;add to array if it wasn't there already
  1.  ..;
  1.  ..I ABMFEEC=1 S ^ABMFTWC(ABMFT,"FIX",ABMMLT)=+$G(^ABMFTWC(ABMFT,"FIX",ABMMLT))+1  ;count how many need user intervention
  1.  ..I +$G(^ABMFTWC(ABMFT,"FIX",ABMMLT,ABMF("DCPT")))'=0 Q  ;stop here if user intervention needed for CPT
  1.  ..D MERGE  ;merge entries back into fee table
  1.  Q
  1.  ;
  1. ACTIVCPT(ABMCPT) ;EP
  1.  S ABMF("CPTEDT")=""
  1.  I ($G(ABMF("DCPT"))'="")&($G(ABMFT)'="") S ABMF("CPTEDT")=$P($G(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,1,1,0)),U)
  1.  I ABMF("CPTEDT")="" S ABMF("CPTEDT")=$P($G(^ABMDFEE(ABMFT,0)),U,5)  ;CPT effective date
  1.  I ABMF("CPTEDT")="" S ABMF("CPTEDT")=ABMF("FTEDT")  ;if no CPT eff date use fee table eff date
  1.  I ABMF("CPTEDT")="" S ABMF("CPTEDT")=DT  ;use today if there's still no eff date
  1.  S ABMACPT=$$CPT^ABMCVAPI(ABMCPT,ABMF("CPTEDT"))
  1.  I ABMACPT=0 S ABMACPT=$$CPT^ABMCVAPI(ABMCPT,DT)  ;try again with today's date
  1.  Q ABMACPT
  1.  ;
  1. MERGE ;EP
  1.  ;the next two lines are the zero nodes for the CPT and for effective date
  1.  M ^ABMDFEE(ABMFT,ABMMLT,ABMF("DCPT"),0)=^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,0)
  1.  M ^ABMDFEE(ABMFT,ABMMLT,ABMF("DCPT"),1,0)=^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,1,0)
  1.  ;
  1.  S ABMF("DCCNT")=0
  1.  F  S ABMF("DCCNT")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"))) Q:'ABMF("DCCNT")  D
  1.  .S ABMF("CPTEDIEN")=0
  1.  .S ABMF("NEWCPTEDIEN")=1
  1.  .F  S ABMF("CPTEDIEN")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"))) Q:'ABMF("CPTEDIEN")  D
  1.  ..M ^ABMDFEE(ABMFT,ABMMLT,ABMF("DCPT"),1,ABMF("NEWCPTEDIEN"),0)=^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"),0)
  1.  ..S ABMF("NEWCPTEDIEN")=+$G(ABMF("NEWCPTEDIEN"))+1
  1.  D DELWCE
  1.  Q
  1. DELWCE ;
  1.  K ^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"))  ;remove entry from working copy file after all entries have been merged
  1.  Q
  1.  ;
  1. REINDEX ;EP -re-index everything when done
  1.  D BMES^XPDUTL("Reindexing fee schedules...")
  1.  D ^XBFMK
  1.  S ABMT("FT")=0
  1.  F  S ABMT("FT")=$O(^ABMDFEE(ABMT("FT"))) Q:'ABMT("FT")  D
  1.  .S DIK="^ABMDFEE("
  1.  .S DA=ABMT("FT")
  1.  .D IX^DIK
  1.  Q
  1.  ;
  1. COMPLETE ;EP-mark any that are complete
  1.  ;ABM("FTLST",ABMF)
  1.  S ABMF=0
  1.  F  S ABMF=$O(ABM("FTLST",ABMF)) Q:'ABMF  D
  1.  .I $D(^ABMFTWC(ABMF)) Q  ;skip anything that is still in working copy global
  1.  .S DIE="^ABMDFEE("
  1.  .S DA=ABMF
  1.  .S DR=".06////C"
  1.  .D ^DIE
  1.  Q