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

ABMDTFED.m

Go to the documentation of this file. 
  1. ABMDTFED ; IHS/ASDST/DMJ - REPORT OF 3P FEE SCHEDULES ; 
  1.  ;;2.6;IHS Third Party Billing System;**3,8,27**;NOV 12, 2009;Build 486
  1.  ;
  1.  ;IHS/SD/SDR 2.5*9 IM11865 - Made change so it will print to printer
  1.  ;
  1.  ;IHS/SD/SDR 2.6*3 FIXPMS10008 and FIXPMS10012 - Modified to not use templates and to print by
  1.  ;   effective dates that were introduced in patch 2.
  1.  ;IHS/SD/SDR 2.6*27 CR8897 Fixed header when Charge Master selected; made NDC print for drugs; made sure
  1.  ;   display works with changes to IENs in 3P Fee Table
  1.  ;
  1.  S U="^"
  1. FEE W ! K DIC
  1.  S DIC="^ABMDFEE("
  1.  S DIC(0)="QEAM"
  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.  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.  K DIR
  1.  S (ABM("S"),DIR(0))="SO^1:MEDICAL;2:SURGICAL;3:RADIOLOGY;4:LABORATORY;5:ANESTHESIA;6:DENTAL;7:REVENUE CODE;8:HCPCS;9:DRUG;10:CHARGE MASTER"
  1.  S DIR("A")="Select Desired CATEGORY"
  1.  D ^DIR
  1.  G XIT:$D(DIROUT)!$D(DIRUT)
  1.  S ABM=+Y
  1.  S ABM("S")=$P($P($P(ABM("S"),U,2),";",+Y),":",2)
  1.  ;start new code abm*2.6*3 FIXPMS10008
  1.  S:ABM("S")="MEDICAL" ABM("CAT")=19
  1.  S:ABM("S")="SURGICAL" ABM("CAT")=11
  1.  S:ABM("S")="RADIOLOGY" ABM("CAT")=15
  1.  S:ABM("S")="LABORATORY" ABM("CAT")=17
  1.  S:ABM("S")="ANESTHESIA" ABM("CAT")=23
  1.  S:ABM("S")="DENTAL" ABM("CAT")=21
  1.  S:ABM("S")="REVENUE CODE" ABM("CAT")=31
  1.  S:ABM("S")="HCPCS" ABM("CAT")=13
  1.  S:ABM("S")="DRUG" ABM("CAT")=25
  1.  S:ABM("S")="CHARGE MASTER" ABM("CAT")=32
  1.  ;start new code abm*2.6*8 HEAT19236
  1.  W !,"Looking for effective dates..."
  1.  S ABMCODE=0
  1.  F  S ABMCODE=$O(^ABMDFEE(ABM("FEE"),ABM("CAT"),ABMCODE)) Q:'ABMCODE  D
  1.  .S ABMEFFDT=0
  1.  .F  S ABMEFFDT=$O(^ABMDFEE(ABM("FEE"),ABM("CAT"),ABMCODE,1,"B",ABMEFFDT)) Q:'ABMEFFDT  D
  1.  ..S ABMELST(ABMEFFDT)=""
  1.  W !!,"Possible effective dates:"
  1.  S ABMEFFDT=0
  1.  F  S ABMEFFDT=$O(ABMELST(ABMEFFDT)) Q:'ABMEFFDT  W !?3,$$SDT^ABMDUTL(ABMEFFDT)
  1.  ;end new code HEAT19236
  1.  D ^XBFMK
  1.  S DIR(0)="DA"
  1.  S DIR("A")="Use what effective date? "
  1.  D ^DIR
  1.  K DIR
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!$D(DIROUT)
  1.  S ABM("EFFDT")=Y
  1.  ;start old code abm*2.6*8 HEAT19236
  1.  ;S ABM("TMP")=$O(^ABMDFEE(ABM("FEE"),1,"B",0))
  1.  ;I (ABM("EFFDT")<($P(ABM("TMP"),".",1))) D  G FEE
  1.  ;.W !!?2,"The effective date you selected is before any effective date in this"
  1.  ;.W !?2,"fee schedule."
  1.  ;end old code HEAT19236
  1.  ;end new code FIXPMS10008
  1.  ;
  1. W1 ;EP
  1.  W !!!
  1.  ;start old code abm*2.6*8 HEAT26652
  1.  ;S %ZIS="NQ"
  1.  ;S %ZIS("B")=""
  1.  ;D ^%ZIS
  1.  ;G:'$D(IO)!$G(POP) XIT
  1.  ;S ABM("ION")=ION
  1.  ;G:$D(IO("Q")) QUE
  1.  ;I IO'=IO(0),$E(IOST)'="C",'$D(IO("S")),$P($G(^ABMDPARM(DUZ(2),1,0)),U,13)="Y" W !!,"As specified in the 3P Site Parameters File FORCED QUEUEING is in effect!",! G QUE
  1.  ;end old code start new code HEAT26652
  1.  S %ZIS="NQ"
  1.  S %ZIS("A")="Enter DEVICE: "
  1.  D ^%ZIS Q:POP
  1.  I IO'=IO(0) D QUE,HOME^%ZIS S DIR(0)="E" D ^DIR K DIR Q
  1.  I $D(IO("S")) S IOP=ION D ^%ZIS
  1.  ;end new code HEAT26652
  1. PRQUE ;EP - Entry Point for Taskman
  1. S2 ;start old code abm*2.6*3 FIXPMS10008
  1.  ;S L=0
  1.  ;S DIC="^ABMDFEE("
  1.  ;S FLDS="[ABMD TM "_ABM("S")_" FEES]"
  1.  ;S BY=$S(ABM("S")="DENTAL":"[ABMD TM DENTAL FEE SCHEDULE]",1:"[ABMD TM FEE SCHEDULE]")
  1.  ;S FR=$S(ABM("S")="DENTAL":ABM("FEE"),1:ABM("FEE"))
  1.  ;S TO=$S(ABM("S")="DENTAL":ABM("FEE")_",?",1:ABM("FEE"))
  1.  ;S IOP=ABM("ION")_";"_IOST_";"_80_";"_IOSL
  1.  ;S PG=1
  1.  ;D EN1^DIP
  1.  ;end old code start new code FIXPMS10008
  1.  S ABM("PG")=0
  1.  S ABM("HD",0)=ABM("S")_" SERVICES FEE SCHEDULE"
  1.  S ABM("HD",1)="FEE SCHEDULE NUMBER "_ABM("FEE")_" WITH EFFECTIVE DATE "_$$SDT^ABMDUTL(ABM("EFFDT"))
  1.  K ^TMP("ABM-FS",$J)
  1.  D RANGE^ABMFEAPI(ABM("FEE"),ABM("CAT"),ABM("EFFDT"))
  1.  D HDB
  1.  S ABMCD=""
  1.  F  S ABMCD=$O(^TMP("ABM-FS",$J,ABMCD)) Q:($G(ABMCD)="")  D  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  .S ABMCODE="",ABMDESC=""
  1.  .I $Y>(IOSL-5) D HD Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)  W " (cont)"
  1.  .;I ABM("CAT")=25 S ABMCODE=$P($G(^PSDRUG($P($G(^TMP("ABM-FS",$J,ABMCD)),U),0)),U)  ;drug  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  .;start new abm*2.6*27 IHS/SD/SDR CR8894
  1.  .I ABM("CAT")=25 D
  1.  ..S ABMCODE=$P($G(^PSDRUG($P($G(^TMP("ABM-FS",$J,ABMCD)),U),2)),U,4)  ;NDC
  1.  ..S ABMDESC=$P($G(^PSDRUG($P($G(^TMP("ABM-FS",$J,ABMCD)),U),0)),U)  ;drug
  1.  .;end new abm*2.6*27 IHS/SD/SDR CR8894
  1.  .I ABM("CAT")=32 S ABMCODE=$P($G(^ABMCM(ABMCD,0)),U)  ;charge master
  1.  .I (ABM("CAT")'=25&(ABM("CAT")'=32)) S ABMCODE=ABMCD
  1.  .;I "^19^11^15^17^23^13^"[("^"_ABM("CAT")_"^") S ABMDESC=$P($$CPT^ABMCVAPI($P(^TMP("ABM-FS",$J,ABMCD),U),ABM("EFFDT")),U,3)  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  .;start new abm*2.6*27 IHS/SD/SDR CR8894
  1.  .I "^19^11^15^17^23^13^"[("^"_ABM("CAT")_"^") D
  1.  ..S ABMDESC=$P($$CPT^ABMCVAPI(ABMCD,ABM("EFFDT")),U,3)
  1.  ..I ABMDESC="" S ABMDESC=$P($$CPT^ABMCVAPI(ABMCD,DT),U,3)
  1.  .;end new abm*2.6*27 IHS/SD/SDR CR8894
  1.  .I ABM("CAT")=21 S ABMDESC=$P($G(^AUTTADA($P($G(^TMP("ABM-FS",$J,ABMCODE)),U),0)),U,2)
  1.  .I ABM("CAT")=31 S ABMDESC=$P($G(^AUTTREVN(ABMCD,0)),U,2)
  1.  .W !,ABMCODE
  1.  .;W ?10,$E(ABMDESC,1,32)  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  .I ABM("CAT")'=25 W ?10  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  .I ABM("CAT")=25 W ?15  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  .W $E(ABMDESC,1,32)  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  .I "^19^11^15^17^23^13^21^31^"[("^"_ABM("CAT")_"^") D
  1.  ..W ?44,+$P($G(^TMP("ABM-FS",$J,ABMCD)),U,2)
  1.  ..W ?56,+$P($G(^TMP("ABM-FS",$J,ABMCD)),U,3)
  1.  ..W ?68,+$P($G(^TMP("ABM-FS",$J,ABMCD)),U,4)
  1.  .I "^19^11^15^17^23^13^21^31^"'[("^"_ABM("CAT")_"^") D
  1.  ..I ABM("CAT")=25 Q  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  ..W ?44,+$P($G(^TMP("ABM-FS",$J,ABMCD)),U,2)
  1.  .I ABM("CAT")=25 W ?60,+$P($G(^TMP("ABM-FS",$J,ABMCD)),U,2)  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  ;end new code FIXPMS10008
  1. XIT D ^%ZISC
  1.  K ABM
  1.  Q
  1.  ;
  1. QUE ;EP
  1.  ;start old code abm*2.6*8
  1.  ;K IO("Q")
  1.  ;S ZTRTN="PRQUE^ABMDTFED"
  1.  ;S ZTDESC="REPORT OF 3P FEE SCHEDULES"
  1.  ;F ABM="ABM(" S ZTSAVE(ABM)=""
  1.  ;D ^%ZTLOAD
  1.  ;W:$D(ZTSK) !,"REQUEST QUEUED!",! G XIT
  1.  ;end old code start new code
  1.  S ZTRTN="PRQUE^ABMDTFED"
  1.  S ZTDESC="REPORT OF 3P FEE SCHEDULES"
  1.  S ZTSAVE("ABM*")=""
  1.  K ZTSK
  1.  D ^%ZTLOAD
  1.  W:$G(ZTSK) !,"Task # ",ZTSK," queued.",!
  1.  Q
  1.  ;end new code
  1.  ;
  1.  ;start new code abm*2.6*3 FIXPMS10008
  1. HD D PAZ^ABMDRUTL Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1. HDB S ABM("PG")=ABM("PG")+1
  1.  D WHD^ABMDRHD
  1.  ;I "^19^11^15^17^23^13^21^31^"[("^"_ABM("CAT")_"^") W !?44,"GLOBAL",?56,"TECH",?68,"PROF"  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  I "^19^11^15^17^23^13^21^31^32^"[("^"_ABM("CAT")_"^") W !?44,"GLOBAL",?56,"TECH",?68,"PROF"  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  I "^19^11^15^17^23^13^"[("^"_ABM("CAT")_"^") W !,"CPT CODE",?10,"SHORT NAME",?44,"CHARGE",?56,"CHARGE",?68,"CHARGE"
  1.  I ABM("CAT")=21 W !,"ADA CODE",?15,"SHORT NAME",?44,"CHARGE",?56,"CHARGE",?68,"CHARGE"
  1.  ;I ABM("CAT")=25 W !,"DRUG",?44,"PRICE PER DISPENSING UNIT"  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  I ABM("CAT")=25 W !,"NDC",?18,"DRUG",?55,"PRICE PER DISPENSING UNIT"  ;abm*2.6*27 IHS/SD/SDR CR8894
  1.  I ABM("CAT")=31 W !,"REV CODE",?10,"STANDARD ABBREV.",?44,"CHARGE",?56,"CHARGE",?68,"CHARGE"
  1.  I ABM("CAT")=32 W !,"CHARGE MASTER",?44,"CHARGE",?56,"CHARGE",?68,"CHARGE"
  1.  S $P(ABM("LINE"),"-",80)="" W !,ABM("LINE") K ABM("LINE")
  1.  Q
  1.  ;end new code FIXPMS10008