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

ABMFOFS.m

Go to the documentation of this file. 
  1. ABMFOFS ; IHS/ASDST/DMJ - UPDATE FEE TABLE FROM FOREIGN FILE ; 
  1.  ;;2.6;IHS Third Party Billing;**1,2,27**;NOV 12, 2009;Build 486
  1.  ;
  1.  ;IHS/SD/SDR 2.5*10 IM20355 Modified default to be Read
  1.  ;
  1.  ;IHS/SD/SDR 2.6*1 NO HEAT corrected cnts for categories and display
  1.  ;IHS/SD/SDR 2.6*2 3PMS10003A Effective dates added to fee sched
  1.  ;IHS/SD/SDR 2.6*27 CR8894 Change FILE and DFILE tags to file entries correctly using DINUM to CPT instead of first found IEN for CPT.
  1.  ;   Issue results from multiple entries in CPT file for a CPT code.
  1.  ;
  1. START ;START HERE
  1.  W !!,"FEE SCHEDULE UPDATE FROM FOREIGN FILE"
  1.  W !!,$$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")," It is advisable to do a global save of global ^ABMDFEE prior to"
  1.  W !,"running this procedure.",!
  1.  S DIR(0)="Y",DIR("A")="Continue",DIR("B")="NO"
  1.  D ^DIR K DIR
  1.  Q:Y'=1
  1.  S DIC="^ABMDFEE("
  1.  S DIC(0)="AEMQ"
  1.  S DIC("A")="Enter Fee Schedule to Update: "
  1.  S DIC("B")=1
  1.  D ^DIC K DIC
  1.  Q:Y<0
  1.  S ABMTB=+Y
  1.  ;start new code abm*2.6*2 3PMS10003A
  1.  D ^XBFMK
  1.  S DIR(0)="D"
  1.  S DIR("A")="What is the effective date? "
  1.  S DIR("B")="TODAY"
  1.  D ^DIR K DIR
  1.  Q:$D(DIRUT)
  1.  S ABMEDT=Y
  1.  D ^XBFMK
  1.  S DIR(0)="N^0:200"
  1.  S DIR("A")="What percentile are you loading? "
  1.  D ^DIR K DIR
  1.  Q:$D(DIRUT)
  1.  S ABMPRCNT=Y
  1.  ;end new code 3PMS10003A
  1. DF ;DESCRIBE FLAT FILE
  1.  W !!,"FOREIGN HOST FILE DESCRIPTION",!
  1.  S DIR(0)="FA",DIR("A")="What is the host file record delimiter? ",DIR("B")="," D ^DIR K DIR Q:$D(DIRUT)  S ABMDLM=Y
  1.  S DIR(0)="NA",DIR("A")="Which piece of the host file record contains the cpt code? ",DIR("B")=1 D ^DIR K DIR Q:$D(DIRUT)  S ABMCPC=Y
  1.  S DIR(0)="NA",DIR("A")="Which piece of the host file record contains the price? ",DIR("B")=2 D ^DIR K DIR Q:$D(DIRUT)  S ABMPPC=Y
  1.  W !!,"Some providers of fee schedules (Medicode for example) break out"
  1.  W !,"the professional and technical portions into separate records."
  1.  W !,"The next section will determine how to identify the different"
  1.  W !,"record types.",!
  1.  ;start old code abm*2.6*2 3PMS10003A
  1.  ;S DIR(0)="Y",DIR("A")="Include only certain record types",DIR("B")="NO"  D ^DIR K DIR
  1.  ;I Y=1 D
  1.  ;.S DIR(0)="NA",DIR("A")="Examine piece: ",DIR("B")=4 D ^DIR K DIR
  1.  ;.Q:'Y
  1.  ;.S ABMIPC=+Y
  1.  ;.S DIR(0)="F^1:30",DIR("A")="for value ",DIR("B")="G" D ^DIR K DIR
  1.  ;.Q:Y=""
  1.  ;.S ABMIVAL=Y
  1.  ;end old code start new code
  1.  W !,"This section will load the different record types (global/technical/professional)"
  1.  ;global
  1.  S DIR(0)="NA",DIR("A")="What column is the record type located in: ",DIR("B")=4 D ^DIR K DIR
  1.  Q:'Y
  1.  S ABMIPC=+Y
  1.  S DIR(0)="F^1:30",DIR("A")="Indicate value that identifies GLOBAL charge ",DIR("B")="G" D ^DIR K DIR
  1.  Q:Y=""
  1.  S ABMGVAL=Y
  1.  ;technical
  1.  S DIR(0)="F^1:30",DIR("A")="Indicate value that identifies TECHNICAL charge ",DIR("B")="TC" D ^DIR K DIR
  1.  Q:Y=""
  1.  S ABMTVAL=Y
  1.  ;professional
  1.  S DIR(0)="F^1:30",DIR("A")="Indicate value that identifies PROFESSIONAL charge ",DIR("B")="26" D ^DIR K DIR
  1.  Q:Y=""
  1.  S ABMPVAL=Y
  1.  K ABMCNT
  1.  ;end new code 3PMS10003A
  1. BY ;BYPASS WITH ABMTB DEFINED
  1.  I '$G(DT) S DT=$$HTFM^XLFDT($H)\1
  1.  W !!,"OPEN AND READ FOREIGN FILE",!
  1.  S %ZIS("HFSMODE")="R"
  1.  S %ZIS("B")="HOST FILE SERVER" D ^%ZIS Q:POP
  1.  F ABMCNT=1:1 D  Q:$$STATUS^%ZISH
  1.  .U IO R X:DTIME Q:$$STATUS^%ZISH
  1.  .;I $G(ABMIVAL)'="" Q:($$TRIM^ABMUTLP($P(X,ABMDLM,ABMIPC),"R"," ")'=ABMIVAL)  ;abm*2.6*2 3PMS10003A
  1.  .S ABMIVAL=$$TRIM^ABMUTLP($P(X,ABMDLM,ABMIPC),"LR"," ")  ;abm*2.6*2 3PMS10003A
  1.  .S ABMCODE=$P(X,ABMDLM,ABMCPC)
  1.  .;start old code abm*2.6*2 3PMS10003A
  1.  .;S ABMCODE=$TR(ABMCODE,"""")
  1.  .;Q:$L(ABMCODE)<4
  1.  .;I $L(ABMCODE)=4,'$D(^AUTTADA("B",ABMCODE)) Q
  1.  .;I $L(ABMCODE)'=4,'$D(^ICPT("B",ABMCODE)) Q
  1.  .;end old code start new code 3PMS10003A
  1.  .S ABMCODE=$TR(ABMCODE," """)
  1.  .I $L(ABMCODE)<4 D  Q
  1.  ..I DUZ(0)["@" U 0 W !,ABMCODE_" "_ABMIVAL
  1.  .I $L(ABMCODE)=4,'$D(^AUTTADA("B",ABMCODE)) D  Q
  1.  ..I DUZ(0)["@" U 0 W !,ABMCODE_" "_ABMIVAL
  1.  .I $L(ABMCODE)'=4,'$D(^ICPT("B",ABMCODE)) D  Q
  1.  ..I DUZ(0)["@" U 0 W !,ABMCODE_" "_ABMIVAL
  1.  .;end new code 3PMS10003A
  1.  .I ((ABMIVAL'="")&(("^"_ABMGVAL_"^"_ABMTVAL_"^"_ABMPVAL_"^")'[("^"_ABMIVAL_"^"))) D  Q
  1.  ..I DUZ(0)["@" U 0 W !,ABMCODE_" "_ABMIVAL
  1.  .S ABMPRICE=$P(X,ABMDLM,ABMPPC)
  1.  .;S ABMPRICE=+$TR(ABMPRICE,"$"",")  ;abm*2.6*2 3PMS10003A
  1.  .S ABMPRICE=+$TR(ABMPRICE,"$"", ")  ;abm*2.6*2 3PMS10003A
  1.  .D SEC
  1.  .D:ABMSC'=21 FILE
  1.  .D:ABMSC=21 DFILE
  1.  .I '(ABMCNT#10) U IO(0) W "."
  1.  D HK
  1.  Q
  1. SEC ;WHAT SECTION?
  1.  I $L(ABMCODE)=4 S ABMSC=21 Q
  1.  I ABMCODE?1U4N S ABMSC=13 Q
  1.  I ABMCODE?4N1U S ABMSC=13 Q  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  I ABMCODE<10000 S ABMSC=23 Q
  1.  I ABMCODE<70000 S ABMSC=11 Q
  1.  I ABMCODE<80000 S ABMSC=15 Q
  1.  I ABMCODE<90000 S ABMSC=17 Q
  1.  S ABMSC=19
  1.  I '$D(^ABMDFEE(ABMTB,ABMSC)) D
  1.  .S ^ABMDFEE(ABMTB,ABMSC,0)="^9002274.01"_ABMSC_"P^^"
  1.  Q
  1. FILE ;FILE CODE
  1.  ;start old abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;S ABMPTR=$O(^ICPT("B",ABMCODE,0))
  1.  ;Q:'ABMPTR
  1.  ;;S ^ABMDFEE(ABMTB,ABMSC,ABMPTR,0)=ABMPTR_"^"_ABMPRICE_"^"_DT  ;abm*2.6*2 3PMS10003A
  1.  ;S:ABMIVAL="G"!(ABMIVAL="") ^ABMDFEE(ABMTB,ABMSC,ABMPTR,0)=ABMPTR_"^"_ABMPRICE_"^"_DT  ;abm*2.6*2 3PMS10003A
  1.  ;S ^ABMDFEE(ABMTB,ABMSC,"B",ABMPTR,ABMPTR)=""
  1.  ;end old start new abm*2.6*27 IHS/SD/SDR CR8894
  1.  S ABMPTR=$P($$CPT^ABMCVAPI(ABMCODE,ABMEDT),U)  ;returns CPT active at time of effective date
  1.  Q:+ABMPTR=0
  1.  S ABMCD=$$DINUM(ABMCODE)  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  S:ABMIVAL="G"!(ABMIVAL="") ^ABMDFEE(ABMTB,ABMSC,ABMCD,0)=ABMPTR_"^"_ABMPRICE_"^"_DT  ;abm*2.6*2 3PMS10003A
  1.  S ^ABMDFEE(ABMTB,ABMSC,"B",ABMCODE,ABMPTR)=""
  1.  ;end new abm*2.6*27 IHS/SD/SDR CR8894
  1.  S ABMCNT(ABMSC)=+$G(ABMCNT(ABMSC))+1  ;abm*2.6*1 NO HEAT
  1.  D EFFDT  ;abm*2.6*2 3PMS10003A
  1.  Q
  1.  ;start new abm*2.6*27 IHS/SD/SDR CR8894
  1. DINUM(ABMCODE) ;PEP - DINUM CPT for fee table
  1.  I +$G(ABMCODE)=ABMCODE D  Q ABMCODE  ;5-digit code, leave it
  1.  I (($A($E(ABMCODE))>64)&($A($E(ABMCODE))<91)) S ABMCD=$A($E(ABMCODE))_$E(ABMCODE,2,5) Q ABMCD
  1.  I (($A($E(ABMCODE,5))>64)&($A($E(ABMCODE,5))<91)) S ABMCD=$E(+ABMCODE,1,4)_"."_$A($E(ABMCODE,5)) Q ABMCD
  1.  S ABMCD=+$G(ABMCODE) Q ABMCD
  1.  Q ABMCODE
  1.  ;end new abm*2.6*27 IHS/SD/SDR CR8894
  1. DFILE ;FILE ADA CODE IN DENTAL SECTION
  1.  S ABMPTR=$O(^AUTTADA("B",ABMCODE,0))
  1.  Q:'ABMPTR
  1.  ;S ^ABMDFEE(ABMTB,21,1_ABMCODE,0)=ABMPTR_"^"_ABMPRICE_"^"_ABMCODE_"^"_DT  ;abm*2.6*2 3PMS10003A
  1.  S:ABMIVAL="G"!(ABMIVAL="") ^ABMDFEE(ABMTB,21,1_ABMCODE,0)=ABMPTR_"^"_ABMPRICE_"^"_ABMCODE_"^"_DT  ;abm*2.6*2 3PMS10003A
  1.  S ^ABMDFEE(ABMTB,21,"B",ABMPTR,1_ABMCODE)=""
  1.  S ABMCNT(21)=+$G(ABMCNT(21))+1  ;abm*2.6*1 NO HEAT
  1.  D EFFDT  ;abm*2.6*2 3PMS10003A
  1.  Q
  1.  ;start new code abm*2.6*2 3PMS10003A
  1. EFFDT ;
  1.  D ^XBFMK
  1.  S DA(2)=ABMTB
  1.  ;S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMPTR)  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMCD)  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  S DIC="^ABMDFEE("_DA(2)_","_ABMSC_","_DA(1)_",1,"
  1.  S DIC(0)="L"
  1.  S DIC("P")=$P(^DD(9002274.01_ABMSC,1,0),U,2)
  1.  S X=ABMEDT
  1.  D ^DIC
  1.  S ABMENTRY=+Y
  1.  D ^XBFMK
  1.  S DA(2)=ABMTB
  1.  ;S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMPTR)  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMCD)  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  S DIE="^ABMDFEE("_DA(2)_","_ABMSC_","_DA(1)_",1,"
  1.  S DA=ABMENTRY
  1.  I ((ABMIVAL=ABMGVAL)!($G(ABMIVAL)="")) S DR=".02////"_ABMPRICE
  1.  I (ABMIVAL=ABMTVAL) S DR=".03////"_ABMPRICE
  1.  I (ABMIVAL=ABMPVAL) S DR=".04////"_ABMPRICE
  1.  I $G(DR)'="" S DR=DR_";.05////"_DT_";.06////"_DUZ
  1.  D ^DIE
  1.  S ABMCNT(ABMSC,$S(($G(ABMIVAL)'=""):ABMIVAL,1:"G"))=+$G(ABMCNT(ABMSC,$S(($G(ABMIVAL)'=""):ABMIVAL,1:"G")))+1
  1.  Q
  1.  ;end new code 3PMS10003A
  1. HK ;HOUSE CLEANING
  1.  D ^%ZISC
  1.  ;start new code abm*2.6*2 3PMS10003A
  1.  W !!,"Will now ensure all global charges are populated where applicable..."
  1.  S ABMSC=0
  1.  F  S ABMSC=$O(^ABMDFEE(ABMTB,ABMSC)) Q:(+$G(ABMSC)=0)  D
  1.  .S ABMCD=0
  1.  .F  S ABMCD=$O(^ABMDFEE(ABMTB,ABMSC,ABMCD)) Q:(+$G(ABMCD)=0)  D
  1.  ..I $D(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,"B",ABMEDT)) D
  1.  ...S ABMEDFN=$O(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,"B",ABMEDT,0))
  1.  ...Q:(+$P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,2)'=0)  ;already has global charge
  1.  ...I (+$P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,3)'=0)&(+$P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,4)'=0)  D
  1.  ....D ^XBFMK
  1.  ....S DA(2)=ABMTB
  1.  ....S DA(1)=ABMCD
  1.  ....S DIE="^ABMDFEE("_DA(2)_","_ABMSC_","_DA(1)_",1,"
  1.  ....S DA=ABMEDFN
  1.  ....S DR=".02////"_($P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,3)+($P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,4)))
  1.  ....D ^DIE
  1.  ;end new code 3PMS10003A
  1.  ;W !!,ABMCNT," records updated.",!  ;abm*2.6*1 NO HEAT
  1.  ;start new code abm*2.6*1 NO HEAT
  1.  W !!,"Records updated by category"
  1.  S ABMRCNT=0
  1.  F  S ABMRCNT=$O(ABMCNT(ABMRCNT)) Q:'ABMRCNT  D
  1.  .W !?3,$G(ABMCNT(ABMRCNT)),?10
  1.  .I ABMRCNT=11 W "SURGICAL "
  1.  .I ABMRCNT=13 W "HCPCS "
  1.  .I ABMRCNT=15 W "RADIOLOGY "
  1.  .I ABMRCNT=17 W "LABORATORY "
  1.  .I ABMRCNT=19 W "MEDICAL "
  1.  .I ABMRCNT=21 W "DENTAL "
  1.  .I ABMRCNT=23 W "ANESTHESIA "
  1.  .I ABMRCNT=25 W "DRUG "
  1.  .;start new code abm*2.6*2 3PMS10003A
  1.  .S ABMIVAL=""
  1.  .F  S ABMIVAL=$O(ABMCNT(ABMRCNT,ABMIVAL)) Q:($G(ABMIVAL)="")  D
  1.  ..W !?5,ABMIVAL,?8,$G(ABMCNT(ABMRCNT,ABMIVAL))
  1.  .;end new code 3PMS10003A
  1.  ;end new code NO HEAT
  1.  ;start new code abm*2.6*2 3PMS10003A
  1.  D ^XBFMK
  1.  S DA(1)=ABMTB
  1.  S DIC="^ABMDFEE("_DA(1)_",1,"
  1.  S DIC(0)="MQL"
  1.  S DIC("P")=$P(^DD(9002274.01,1,0),U,2)
  1.  D NOW^%DTC
  1.  S X=%
  1.  S DIC("DR")=".02////"_DUZ_";.03////"_ABMPRCNT
  1.  D ^DIC
  1.  ;end new code 3PMS10003A
  1.  ;start new abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;mark fee table as complete for p27 cleanup
  1.  D ^XBFMK
  1.  S DIE="^ABMDFEE("
  1.  S DA=ABMTB
  1.  S DR=".06////C"
  1.  D ^DIE
  1.  ;re-cross reference entire fee table
  1.  S DIK="^ABMDFEE("
  1.  S DA=ABMTB
  1.  D IX^DIK
  1.  ;end new abm*2.6*27 IHS/SD/SDR CR8894
  1.  S DIR(0)="E" D ^DIR K DIR
  1.  K ABMSC,ABMCODE,ABMPRICE,ABMDLM,ABMCPC,ABMPPC,ABMCNT,ABMIPC,ABMIVAL
  1.  Q