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