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

ABMDTFEE.m

Go to the documentation of this file. 
  1. ABMDTFEE ; IHS/SD/SDR - Table Maintenance of 3P CODES ;
  1.  ;;2.6;IHS Third Party Billing;**1,2,21,27**;NOV 12, 2009;Build 486
  1.  ;
  1.  ;IHS/SD/SDR 2.6 CSV
  1.  ;IHS/SD/SDR 2.6*1 NO HEAT - Populate owner of table
  1.  ;IHS/SD/SDR 2.6*2 3PMS10003A - populate new effective dates multiple
  1.  ;IHS/SD/SDR 2.6*21 HEAT135354 Fix so when CPT selected the effective fee, if there is one, will display; was just printing a dash, no description, and 0.00 for the fee no matter what was entered.
  1.  ;IHS/SD/SDR 2.6*27 CR8894 Fixed so short descriptions and fees will print if ?? typed at any prompt.  Fixed how entries were getting filed to use new
  1.  ;  DINUM methodology.  It requires codes to be hardset into global and then edited.
  1.  ;
  1.  S U="^" W !
  1. FEE K DIC
  1.  S DIC="^ABMDFEE(",DIC(0)="QEAML"
  1.  S DIC("A")="Select FEE SCHEDULE: "
  1.  S:$P($G(^ABMDPARM(DUZ(2),1,0)),U,9)]"" DIC("B")=$P(^(0),U,9)
  1.  S DIC("S")="I DUZ(2)=$P($G(^ABMDFEE(X,0)),""^"",4)"
  1.  ;S DIC("DR")=".02;.04////"_DUZ(2)  ;abm*2.6*1 NO HEAT  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  S DIC("DR")=".02;.06////C;.04////"_DUZ(2)  ;abm*2.6*1 NO HEAT  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  D ^DIC
  1.  G XIT:$D(DUOUT)!$D(DTOUT)
  1.  I +Y<1 G FEE
  1.  S ABM("FEE")=+Y
  1. SEL W !!,"----- FEE SCHEDULE CATEGORIES -----",!
  1.  S DIR(0)="SO^1:MEDICAL FEES;2:SURGICAL FEES;3:RADIOLOGY FEES;4:LABORATORY FEES;5:ANESTHESIA FEES;6:DENTAL FEES;7:REVENUE CODE;8:HCPCS FEES;9:DRUG FEES;10:CHARGE MASTER"
  1.  S DIR("A")="Select Desired CATEGORY"
  1.  D ^DIR K DIR
  1.  G XIT:$D(DIROUT)!$D(DIRUT)
  1.  S ABM=+Y
  1.  ;
  1.  S ABM("SUB")=$S(ABM=1:19,ABM=2:11,ABM=3:15,ABM=4:17,ABM=5:23,ABM=6:21,ABM=7:31,ABM=8:13,ABM=9:25,ABM=10:32)
  1. EDIT ;
  1.  ;start old abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;K DIC  ;abm*2.6*2 3PMS10003A moved EDIT tag to here
  1.  ;S DA(1)=ABM("FEE")
  1.  ;;S (DIC,DIE)="^ABMDFEE("_DA(1)_","_ABM("SUB")_","  ;abm*2.6*2 3PMS10003A
  1.  ;S DIC="^ABMDFEE("_DA(1)_","_ABM("SUB")_","  ;abm*2.6*2 3PMS10003A
  1.  ;S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002274.01"_ABM("SUB")_"P"
  1.  ;S ABM("DICS")=9002274.01_ABM("SUB") X:$D(^DD(ABM("DICS"),.01,12.1)) ^DD(ABM("DICS"),.01,12.1)
  1.  ;;start old code abm*2.6*2 3PMS10003A
  1.  ;;I ABM=7 S DIC("W")="W "" - "",$P($G(^AUTTREVN(Y,0)),U,2),?65,$J($FN($P($G(^ABMDFEE(DA(1),31,Y,0)),U,2),"","",2),9)"
  1.  ;;I ABM=6 S DIC("W")="W "" - "",$P($G(^AUTTADA(Y,0)),U,2),?65,$J($FN($P($G(^ABMDFEE(DA(1),21,Y,0)),U,2),"","",2),9)"
  1.  ;;I "123458"[ABM S DIC("W")="W "" - "",$P($$CPT^ABMCVAPI(Y,DT),U,3),?65,$J($FN($P($G(^ABMDFEE(DA(1),ABM(""SUB""),Y,0)),U,2),"","",2),9)"  ;CSV-c
  1.  ;;S DR=".02"
  1.  ;;end old code start new code 3PMS10003A
  1.  ;I ABM=7 S DIC("W")="W "" - "",$P($G(^AUTTREVN(Y,0)),U,2),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),31,Y,DT),U),"","",2),9)"
  1.  ;;I ABM=6 S DIC("W")="W "" - "",$P($G(^AUTTADA(Y,0)),U,2),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),21,Y,DT),U),"","",2),9)"  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;I ABM=6 S DIC("W")="S ABMR(""CODE"")=$E(Y,2,5) W "" - "",$E($P($G(^AUTTADA($P(^ABMDFEE(DA(1),21,Y,0),U),0)),U,2),1,45),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),21,Y,DT),U),"","",2),9)"  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;;I "123458"[ABM S DIC("W")="W "" - "",$P($$CPT^ABMCVAPI(Y,DT),U,3),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"  ;CSV-c  ;abm*2.6*21 IHS/SD/SDR HEAT135354
  1.  ;;I "123458"[ABM S DIC("W")="W "" - "",$P($$CPT^ABMCVAPI(X,DT),U,3),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),$P($$CPT^ABMCVAPI(X,DT),U),DT),U),"","",2),9)"  ;CSV-c  ;abm*2.6*21 IHS/SD/SDR HEAT135354  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;;start new abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;I "123458"[ABM D
  1.  ;.S DIC("W")=" W "" - "",$P($$CPT^ABMCVAPI(Y,DT),U,3),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),$P($$CPT^ABMCVAPI(Y,DT),U),DT),U),"","",2),9)"
  1.  ;I ABM=9 S DIC("W")="W ?50,$P($G(^PSDRUG(Y,2)),U,4),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
  1.  ;I ABM=10 S DIC("W")="W ?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
  1.  ;;end new abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;;end new code 3PMS10003A
  1.  ;;
  1.  ;W !!  ;abm*2.6*2 3PMS10003A removed EDIT tag from here
  1.  ;S DIC(0)="QLEAM"
  1.  ;D ^DIC K DIC
  1.  ;
  1.  ;end old start new abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;
  1.  K DIC  ;abm*2.6*2 3PMS10003A moved EDIT tag to here
  1.  S DIC="^ICPT("
  1.  I "^6^7^9^10^"[("^"_ABM_"^") D
  1.  .S DA(1)=ABM("FEE")
  1.  .S DIC="^ABMDFEE("_DA(1)_","_ABM("SUB")_","
  1.  .I ABM=7 S DIC("W")="W "" - "",$P($G(^AUTTREVN(Y,0)),U,2),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),31,Y,DT),U),"","",2),9)"
  1.  .I ABM=6 S DIC("W")="S ABMR(""CODE"")=$E(Y,2,5) W "" - "",$E($P($G(^AUTTADA($P(^ABMDFEE(DA(1),21,Y,0),U),0)),U,2),1,45),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),21,Y,DT),U),"","",2),9)"
  1.  .I ABM=9 S DIC("W")="W ?50,$P($G(^PSDRUG(Y,2)),U,4),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
  1.  .I ABM=10 S DIC("W")="W ?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
  1.  ;
  1.  S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002274.01"_ABM("SUB")_"P"
  1.  S ABM("DICS")=9002274.01_ABM("SUB") X:$D(^DD(ABM("DICS"),.01,12.1)) ^DD(ABM("DICS"),.01,12.1)
  1.  ;
  1.  W !!
  1.  S DIC(0)="QEAMI"
  1.  I "^6^7^9^10^"[("^"_ABM_"^") S DIC(0)="QLEAM"
  1.  D ^DIC K DIC
  1.  ;end new abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;
  1.  G SEL:X=""!$D(DUOUT)!$D(DTOUT)
  1.  ;
  1.  ;start new abm*2.6*27 IHS/SD/SDR CR8894
  1.  I "123458"[(ABM) D
  1.  .S X=$TR(X," ")
  1.  .S ABMCODE=$$DINUM^ABMFOFS($P(Y,U,2))
  1.  .I '$D(^ABMDFEE(ABM("FEE"),ABM("SUB"),ABMCODE)) D
  1.  ..S ^ABMDFEE(ABM("FEE"),ABM("SUB"),ABMCODE,0)=+Y
  1.  ..S ^ABMDFEE(ABM("FEE"),ABM("SUB"),"C",ABMCODE,+Y)=""
  1.  ..S ^ABMDFEE(ABM("FEE"),ABM("SUB"),"B",+Y,ABMCODE)=""
  1.  ;
  1.  I "123458"[ABM D
  1.  .;W !,ABMCODE," - ",$E($P($$CPT^ABMCVAPI(+Y,DT),U,3),1,55),?65,$J($FN($P($$ONE^ABMFEAPI(ABM("FEE"),ABM("SUB"),+Y,DT),U),",",2),9)
  1.  .W !,X," - ",$E($P($$CPT^ABMCVAPI(+Y,DT),U,3),1,55),?65,$J($FN($P($$ONE^ABMFEAPI(ABM("FEE"),ABM("SUB"),+Y,DT),U),",",2),9)
  1.  ;end new abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;
  1.  I +Y<1 G EDIT
  1.  ;start old code 3PMS10003A
  1.  ;S DA=+Y
  1.  ;S ABM("LDATE")=$P(^ABMDFEE(DA(1),ABM("SUB"),DA,0),U,3)
  1.  ;S:ABM("SUB")=21 ABM("LDATE")=$P(^(0),U,4)
  1.  ;I ABM("LDATE") W !,"Last Updated: ",$$SDT^ABMDUTL(ABM("LDATE"))
  1.  ;end old code start new code 3PMS10003A
  1. EFFDT ;
  1.  ;S ABMCODE=+Y  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  I "^6^7^9^10^"[("^"_ABM_"^") S ABMCODE=+Y  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  D ^XBFMK
  1.  S DA(2)=ABM("FEE")
  1.  S DA(1)=ABMCODE
  1.  S DIC="^ABMDFEE("_DA(2)_","_ABM("SUB")_","_DA(1)_",1,"
  1.  S DIC(0)="AELQ"
  1.  S DIC("P")=$P(^DD(9002274.01_ABM("SUB"),1,0),U,2)
  1.  D ^DIC
  1.  I $D(DTOUT)!$D(DUOUT) G EDIT  ;abm*2.6*2
  1.  I Y<0 W "??  EFFECTIVE DATE REQUIRED" G EFFDT  ;abm*2.6*2
  1.  S ABMENTRY=+Y
  1.  D ^XBFMK
  1.  S DA(2)=ABM("FEE")
  1.  S DA(1)=ABMCODE
  1.  S DIE="^ABMDFEE("_DA(2)_","_ABM("SUB")_","_DA(1)_",1,"
  1.  S DA=ABMENTRY
  1.  S DR=".02//"_$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U)
  1.  ;start old abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;S DR=DR_";.03//"_$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,2)
  1.  ;S DR=DR_";.04//"_$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,3)
  1.  ;end old start new abm*2.6*27 IHS/SD/SDR CR8894
  1.  S DR=DR_";.03//"_+$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,2)
  1.  S DR=DR_";.04//"_+$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,3)
  1.  ;end new abm*2.6*27 IHS/SD/SDR CR8894
  1.  S DR=DR_";.05////"_DT_";.06////"_DUZ
  1.  ;end new code 3PMS10003A
  1.  W !
  1.  D ^ABMDDIE
  1.  ;start new code abm*2.6*2 3PMS10003A
  1.  D ^XBFMK
  1.  S DA(1)=ABM("FEE")
  1.  S DIE="^ABMDFEE("_DA(1)_","_ABM("SUB")_","
  1.  S DA=ABMCODE
  1.  S DR=".02////"_$P($$ONE^ABMFEAPI(ABM("FEE"),ABM("SUB"),ABMCODE,DT),U)
  1.  D ^DIE
  1.  ;this next part populates the UPDATE multiple
  1.  D ^XBFMK
  1.  S DA(1)=ABM("FEE")
  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
  1.  D ^DIC
  1.  ;end new code 3PMS10003A
  1.  ;start new abm*2.6*27 IHS/SD/SDR CR8894
  1.  S DA(1)=ABM("FEE")
  1.  S DA=ABMCODE
  1.  S DIK="^ABMDFEE("_DA(1)_","_ABM("SUB")_","
  1.  D IX^DIK
  1.  ;end new abm*2.6*27 IHS/SD/SDR CR8894
  1.  G EDIT
  1.  ;
  1. XIT K ABM,DIR,DIC,DIE
  1.  Q