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

ABMDEMLB.m

Go to the documentation of this file. 
  1. ABMDEMLB ; IHS/ASDST/DMJ - DSD/JLG - Edit Utility - MULTIPLES - PART 3 ; 
  1.  ;;2.6;IHS Third Party Billing;**1,2,13,14**;NOV 12, 2009;Build 238
  1.  ;
  1.  ;IHS/DSD/MRS - 5/6/1999 - NOIS DXX-0599-140006 Patch 1
  1.  ;      Changed indirect (ABMZ("DICI")) to direct call to fee table for outside labs
  1.  ;
  1.  ; IHS/SD/SDR - v2.5 p8 - task 6 - Added code for A0425/A0888 to remove mileage from page 3A
  1.  ; IHS/SD/SDR - v2.5 p9 - IM13945 - Ability to delete range of codes
  1.  ; IHS/SD/SDR - v2.5 p10 - IM20384 - Fix for <UNDEF>CONT+5^ABMDEMLB
  1.  ;
  1.  ; IHS/SD/SDR - abm*2.6*1 - HEAT2653 - E-codes not deleting
  1.  ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - Modified to call ABMFEAPI
  1.  ;IHS/SD/SDR - 2.6*13 - exp mode 35 - changes for injury date, 01 occurrence code and dt first symptom, 11 occurrence code
  1.  ;IHS/SD/SDR - 2.6*14 - HEAT165301 - Removed link introduced in 13 between page 9A and 3
  1.  ;
  1. D1 ; EP - Delete Multiple
  1.  I +$E(Y,2,3)>0&(+$E(Y,2,3)<(ABMZ("NUM")+1)) S Y=+$E(Y,2,3) G D2
  1.  I ABMZ("NUM")=1 S Y=1 G D2
  1.  I ABMZ("NUM")<1 D  G XIT
  1.  .W !,"There is no ",ABMZ("ITEM")," to delete."
  1.  .H 3
  1.  K DIR S DIR(0)="LO^1:"_ABMZ("NUM")_":0"
  1.  S DIR("?")="Enter the Sequence Number of "_ABMZ("ITEM")_" to Delete",DIR("A")="Sequence Number to DELETE"
  1.  D ^DIR K DIR
  1.  G XIT:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(Y'>0)
  1. D2 ;
  1.  W !
  1.  S ABMXANS=Y
  1.  F ABM("I")=1:1 S ABM=$P(ABMXANS,",",ABM("I")) Q:ABM=""  D
  1.  .I $G(ABMX("ANS"))'="" S ABMX("ANS")=ABMX("ANS")_","_$P(ABMZ(ABM),U)
  1.  .E  S ABMX("ANS")=$P(ABMZ(ABM),U)
  1.  K DIR S DIR(0)="YO",DIR("A")="Do you wish "_ABMX("ANS")_" DELETED"
  1.  D ^DIR K DIR
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1. D3 ;
  1.  I Y=1 D
  1.  .;I ABMZ("SUB")=51,"^01^11^"[("^"_$P(ABMZ(+ABMXANS),U)_"^") S ABMOIEN=$P(ABMZ(+ABMXANS),U,2),ABMDEL=1 D OCCURCD^ABMDEML K ABMDEL  ;abm*2.6*13 exp mode 35  ;abm*2.6*14 HEAT165301
  1.  .F ABM("I")=1:1 S ABM=$P(ABMXANS,",",ABM("I")) Q:ABM=""  D
  1.  ..I (ABMZ("SUB")=43)!(ABMZ("SUB")=47),"A0425^A0888"[$P(ABMZ(ABM),U) D
  1.  ...I $P(ABMZ(ABM),U)="A0425",$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),12)),U,8)=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),$P(ABMZ(ABM),U,2),0)),U,3) D
  1.  ....S DIE="^ABMDCLM(DUZ(2),"
  1.  ....S DA=ABMP("CDFN")
  1.  ....S DR=".128////@"
  1.  ....D ^DIE
  1.  ...I $P(ABMZ(ABM),U)="A0888",$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),12)),U,9)=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),$P(ABMZ(ABM),U,2),0)),U,3) D
  1.  ....S DIE="^ABMDCLM(DUZ(2),"
  1.  ....S DA=ABMP("CDFN")
  1.  ....S DR=".129////@"
  1.  ....D ^DIE
  1.  ..;start new code abm*2.6*1 HEAT2653
  1.  ..;this deletes the individual fields that are associated with any E-codes in the Diag mult.
  1.  ..I $P(ABMZ(ABM),U)["E" D
  1.  ...F ABM("I2")=12,19,20 D
  1.  ....Q:(+$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),8)),U,ABM("I2"))=0)
  1.  ....I ($P($G(^ICD9($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),8)),U,ABM("I2")),0)),U)=$P(ABMZ(ABM),U)) D
  1.  .....S DIE="^ABMDCLM(DUZ(2),"
  1.  .....S DA=ABMP("CDFN")
  1.  .....S DR=$S(ABM("I2")=12:".857",ABM("I2")=19:".858",ABM("I2"):".859",1:"")_"////@"
  1.  .....D ^DIE
  1.  ..;end new code HEAT2653
  1.  ..;
  1.  ..S DA(1)=ABMP("CDFN")
  1.  ..S DA=$P(ABMZ(ABM),U,2)
  1.  ..S DIK="^ABMDCLM(DUZ(2),"_DA(1)_","_ABMZ("SUB")_","
  1.  ..D ^DIK
  1. XIT K ABMX
  1.  Q
  1.  ;
  1. CONT ;EP for setting Contract Provider procedures to zero
  1.  W !!,"Either the Attending or Operating Provider's affiliation is Contract, depending",!,"upon local policy, procedures done by a Contract Provider may be unbillable."
  1.  W ! K DIR S DIR(0)="Y",DIR("A")="Do you want a Zero Charge for this Procedure (Y/N)" S:$D(ABMX("EDIT")) DIR("B")=$S($P(ABMZ(ABMX("Y")),U,8)=0:"Y",1:"N") D ^DIR K DIR
  1.  I Y=1 S ABMZ("DR")=ABMZ("DR")_ABMZ("CHRG")_"////0" Q
  1.  Q:'$D(ABMX("EDIT"))
  1.  I $P(ABMZ(ABMX("Y")),U,8)=0,$P($G(@(ABMZ("DIC")_$P(ABMZ(ABMX("Y")),U,3)_",0)")),U,2)>0 S ABMZ("DR")=ABMZ("DR")_";.07////"_$S($P(ABMZ(ABMX("Y")),U,10):$P(^(11,$P(ABMZ(ABMX("Y")),U,10),0),U,3),1:$P(^(0),U,2))_";09///@"
  1.  Q
  1.  ;
  1. LAB ;EP for Outside Labs
  1.  W !!,"============================ OUTSIDE LAB CHARGES =============================="
  1.  W !,"Outside Laboratory activity has occurred for this visit as indicated on Page 3.",!,"If a lab test is indicated as being performed by an outside entity than, the"
  1.  W !,"CPT Code for these tests will be appended with a modifier of 90 (outside lab),",!,"and the billing fee will become editable."
  1.  W ! K DIR S DIR(0)="Y",DIR("A")="Was this Test performed by an Outside Lab (Y/N)" D ^DIR K DIR
  1.  ;I Y=1 S ABMZ("DR")=ABMZ("DR")_ABMZ("CHRG")_"//"_$S('$D(ABMX("EDIT")):+$P($G(^ABMDFEE(ABMP("FEE"),ABMZ("CAT"),ABMX("Y"),0)),U,2),1:"")_";"_+ABMZ("MOD")_"////"_90 Q  ;abm*2.6*2 3PMS10003A
  1.  I Y=1 S ABMZ("DR")=ABMZ("DR")_ABMZ("CHRG")_"//"_$S('$D(ABMX("EDIT")):+$P($$ONE^ABMFEAPI(ABMP("FEE"),ABMZ("CAT"),ABMX("Y"),ABMP("VDT")),U),1:"")_";"_+ABMZ("MOD")_"////"_90 Q  ;abm*2.6*2 3PMS10003A
  1.  Q:'$D(ABMX("EDIT"))
  1.  ;I $P($G(^ABMDFEE(ABMP("FEE"),+ABMX("Y"),0)),U,2)>0 S ABMZ("DR")=ABMZ("DR")_";.04////"_$P(^(0),U,2)_";.06///@"  ;abm*2.6*2 3PMS10003A
  1.  I $P($$ONE^ABMFEAPI(ABMP("FEE"),ABMZ("CAT"),+ABMX("Y"),ABMP("VDT")),U)>0 S ABMZ("DR")=ABMZ("DR")_";.04////"_$P(^(0),U,2)_";.06///@"  ;abm*2.6*2 3PMS10003A
  1.  Q
  1.  ;
  1. RX ;EP for entering Prescription Number
  1.  K ABMX("P")
  1.  K DIC W !
  1.  S DIC="^PSRX(",DIC(0)="QAZEM",DIC("B")=ABMZ("RX"),DIC("S")="I $D(^PS(55,ABMP(""PDFN"")))"
  1.  D ^DIC K DIC
  1.  Q
  1.  ;
  1. RXW ;EP - for displaying PRESCRIPTION FILE identifiers
  1.  W ?17,$P(^PSDRUG($P(ABMP(0),U,6),0),U),?50,$$HDT^ABMDUTL($P(ABMP(0),U,13))
  1.  S DIW=1
  1.  Q