ABMDRPX ; IHS/ASDST/DMJ - CPT Summary Report ;
;;2.6;IHS Third Party Billing;**1**;NOV 12, 2009
;Original;TMD;10/20/95 3:37 PM
;
; IHS/SD/SDR - 10/21/02 - V2.5 P2 - UXX-1002-170028
; Modified so report would print data second time if same session
;
; IHS/SD/SDR - v2.6 CSV
; IHS/SD/SDR - abm*2.6*1 - HEAT4716 - Include NDC on RXs
;
K ABM,ABMY,^TMP("ABM-PX","CL")
K ^TMP($J,"ABM-PX","CL")
;
SEL ;
; Ask the user what category they would like to list procedures
W !!,"----- PROCEDURE CATEGORIES -----",!
K DIR
S DIR(0)="SO^1:MEDICAL;2:SURGICAL;3:RADIOLOGY;4:LABORATORY;5:ANESTHESIA;6:DENTAL;7:ROOM & BOARD;8:MISCELLANEOUS (HCPCS);9:PHARMACY;10:ALL"
S DIR("A")="Select Desired CATEGORY"
D ^DIR
G XIT:$D(DIROUT)!$D(DIRUT)
S ABM("CAT")=Y(0)
S ABM=+Y
;ABM("SUB") ; multiple in bill file
S ABM("SUB")=$S(ABM=1:27,ABM=2:21,ABM=3:35,ABM=4:37,ABM=5:39,ABM=6:33,ABM=7:25,ABM=8:43,ABM=9:23,1:"")
I ABM("SUB")="" S ABM("ALL")=1
;
RSEL ;
; Select exclusion parameters
D ^ABMDRSEL
G XIT:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
;
HD ;
S ABM("HDCAT")=$S(ABM=1:"MEDICAL ",ABM=2:"SURGICAL ",ABM=3:"RADIOLOGY ",ABM=4:"LABORATORY ",ABM=5:"ANESTHESIA ",ABM=6:"DENTAL ",ABM=7:"ROOM & BOARD ",ABM=8:"MISCELLANEOUS (HCPCS) ",ABM=9:"PHARMACY ",1:"")
S ABM("HD",0)="BILLED "_ABM("HDCAT")_"PROCEDURES"
D ^ABMDRHD ; Write report header
S ABMQ("RC")="COMPUTE^ABMDRPX" ; Compute routine
S ABMQ("RP")="PRINT^ABMDRPX1" ; Print routine
S ABMQ("RX")="POUT^ABMDRUTL" ; Namespace
S ABMQ("NS")="ABM"
D ^ABMDRDBQ ; Double queue rtn - uses ABMQ array
Q
;
COMPUTE ;EP - Entry Point for Setting up Data
; Loop through bill file
S ABM("SUBR")="ABM-PX"
K ^TMP(ABM("SUBR"),$J)
S ABMP("RTN")="ABMDRPX"
D LOOP^ABMDRUTL
Q
;
DATA ;
; for each bill. . . gather data (called from ABMDRUTL)
S ABMP("HIT")=0
D ^ABMDRCHK ; Check bill parameters
Q:'ABMP("HIT")
S ABM("CL")=+^ABMDBILL(DUZ(2),ABM,0)
Q:$D(^TMP($J,"ABM-PX","CL",ABM("CL")))
S ^TMP($J,"ABM-PX","CL",ABM("CL"))=""
I +ABM("SUB") D ONE
I $G(ABM("ALL")) D
.F ABM("SUB")=21,23,25,27,33,35,37,39,43 D
..I $O(^ABMDBILL(DUZ(2),ABM,ABM("SUB"),0)) D ONE
.I $P($G(^ABMDBILL(DUZ(2),ABM,8)),U,10),'$D(ABMY("PX")) D
..S ABM("FEE")=$P(^ABMDBILL(DUZ(2),ABM,8),U,10)
..S ABM("CD")=450
..S ABM("NM")=$P(^AUTTREVN(ABM("CD"),0),U,2)
..D TL
.I $P($G(^ABMDBILL(DUZ(2),ABM,9)),U,8),'$D(ABMY("PX")) D
..S ABM("FEE")=$P(^ABMDBILL(DUZ(2),ABM,9),U,8)
..S ABM("CD")=$P(^ABMDBILL(DUZ(2),ABM,9),U,7)
..S ABM("NM")=$P(^AUTTREVN(ABM("CD"),0),U,2)
..D TL
Q
;
ONE ;
; ONE CATEGORY
I $D(ABMY("PX")),"23^25^33^43"[ABM("SUB") Q
S ABM("PX")=0
F S ABM("PX")=$O(^ABMDBILL(DUZ(2),ABM,ABM("SUB"),ABM("PX"))) Q:'ABM("PX") D
.Q:'$D(^ABMDBILL(DUZ(2),ABM,ABM("SUB"),ABM("PX"),0))
.S ABM(0)=^ABMDBILL(DUZ(2),ABM,ABM("SUB"),ABM("PX"),0)
.;S ABM("CD")=$S(ABM("SUB")=23:"ZZZZZ",ABM("SUB")=25:+ABM(0),ABM("SUB")=33:$P(^AUTTADA(+ABM(0),0),U),1:$P($$CPT^ABMCVAPI(+ABM(0),ABM("D")),U,2)) ;CSV-c ;abm*2.6*1 HEAT4716
.S ABM("CD")=$S(ABM("SUB")=23:$P($G(ABM(0)),U,24),ABM("SUB")=25:+ABM(0),ABM("SUB")=33:$P(^AUTTADA(+ABM(0),0),U),1:$P($$CPT^ABMCVAPI(+ABM(0),ABM("D")),U,2)) ;CSV-c ;abm*2.6*1 HEAT4716
.I +ABM("CD")<+$G(ABMY("PX",1)) Q
.I $D(ABMY("PX",2)),+ABM("CD")>+ABMY("PX",2) Q
.;S ABM("NM")=$S(ABM("SUB")=23:"PRESCRIPTIONS",ABM("SUB")=25:$E($P(^AUTTREVN(+ABM(0),0),U,2),1,40),ABM("SUB")=33:$E($P(^AUTTADA(+ABM(0),0),U,2),1,40),1:$P($$CPT^ABMCVAPI(+ABM(0),ABM("D")),U,3)) ;CSV-c ;abm*2.6*1 HEAT4716
.;start new code abm*2.6*1 HEAT4716
.S ABM("NM")=$S(ABM("SUB")=23&(ABM("CD")'=""):$E($P(^PSDRUG(+ABM(0),0),U),1,30),ABM("SUB")=25:$E($P(^AUTTREVN(+ABM(0),0),U,2),1,40),ABM("SUB")=33:$E($P(^AUTTADA(+ABM(0),0),U,2),1,40),1:$P($$CPT^ABMCVAPI(+ABM(0),ABM("D")),U,3)) ;CSV-c
.I ABM("SUB")=23&(ABM("CD")="") S ABM("NM")="PRESCRIPTIONS"
.;end new code HEAT4716
.I ABM("SUB")=21 S ABM("FEE")=$P(ABM(0),U,7)
.I ABM("SUB")=23 S ABM("FEE")=$P(ABM(0),U,3)*$P(ABM(0),U,4)+$P(ABM(0),U,5)
.I ABM("SUB")=25 S ABM("FEE")=$P(ABM(0),U,2)*$P(ABM(0),U,3)
.I ABM("SUB")=27 S ABM("FEE")=$P(ABM(0),U,3)*$P(ABM(0),U,4)
.I ABM("SUB")=33 S ABM("FEE")=$P(ABM(0),U,8)
.I ABM("SUB")=35!(ABM("SUB")=37)!(ABM("SUB")=43) S ABM("FEE")=$P(ABM(0),U,3)*$P(ABM(0),U,4)
.I ABM("SUB")=39 D
..S ABM("FEE")=$P(ABM(0),U,3)+$P(ABM(0),U,4)
..S ABM("CD")=ABM("CD")_".1"
..Q:'$G(ABM("ALL"))
..S ABM("NM")=ABM("NM")_" (ANEST)"
.I ABM("CD")=""&(ABM("SUB")=23) S ABM("CD")="NONDC-" ;abm*2.6*1 HEAT4716
.D TL
Q
;
TL ;
;SET ENTRY IN TMP
S $P(^TMP("ABM-PX",$J),U)=$P($G(^TMP("ABM-PX",$J)),U)+1
S $P(^TMP("ABM-PX",$J),U,2)=$P(^TMP("ABM-PX",$J),U,2)+ABM("FEE")
S $P(^TMP("ABM-PX",$J,ABM("CD")),U)=$P($G(^TMP("ABM-PX",$J,ABM("CD"))),U)+1,$P(^(ABM("CD")),U,2)=$P(^(ABM("CD")),U,2)+ABM("FEE"),$P(^(ABM("CD")),U,3)=ABM("NM")
Q
;
XIT ;
K ABM,ABMY,ABMP
Q
ABMDRPX ; IHS/ASDST/DMJ - CPT Summary Report ;
+1 ;;2.6;IHS Third Party Billing;**1**;NOV 12, 2009
+2 ;Original;TMD;10/20/95 3:37 PM
+3 ;
+4 ; IHS/SD/SDR - 10/21/02 - V2.5 P2 - UXX-1002-170028
+5 ; Modified so report would print data second time if same session
+6 ;
+7 ; IHS/SD/SDR - v2.6 CSV
+8 ; IHS/SD/SDR - abm*2.6*1 - HEAT4716 - Include NDC on RXs
+9 ;
+10 KILL ABM,ABMY,^TMP("ABM-PX","CL")
+11 KILL ^TMP($JOB,"ABM-PX","CL")
+12 ;
SEL ;
+1 ; Ask the user what category they would like to list procedures
+2 WRITE !!,"----- PROCEDURE CATEGORIES -----",!
+3 KILL DIR
+4 SET DIR(0)="SO^1:MEDICAL;2:SURGICAL;3:RADIOLOGY;4:LABORATORY;5:ANESTHESIA;6:DENTAL;7:ROOM & BOARD;8:MISCELLANEOUS (HCPCS);9:PHARMACY;10:ALL"
+5 SET DIR("A")="Select Desired CATEGORY"
+6 DO ^DIR
+7 IF $DATA(DIROUT)!$DATA(DIRUT)
GOTO XIT
+8 SET ABM("CAT")=Y(0)
+9 SET ABM=+Y
+10 ;ABM("SUB") ; multiple in bill file
+11 SET ABM("SUB")=$SELECT(ABM=1:27,ABM=2:21,ABM=3:35,ABM=4:37,ABM=5:39,ABM=6:33,ABM=7:25,ABM=8:43,ABM=9:23,1:"")
+12 IF ABM("SUB")=""
SET ABM("ALL")=1
+13 ;
RSEL ;
+1 ; Select exclusion parameters
+2 DO ^ABMDRSEL
+3 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO XIT
+4 ;
HD ;
+1 SET ABM("HDCAT")=$SELECT(ABM=1:"MEDICAL ",ABM=2:"SURGICAL ",ABM=3:"RADIOLOGY ",ABM=4:"LABORATORY ",ABM=5:"ANESTHESIA ",ABM=6:"DENTAL ",ABM=7:"ROOM & BOARD ",ABM=8:"MISCELLANEOUS (HCPCS) ",ABM=9:"PHARMACY ",1:"")
+2 SET ABM("HD",0)="BILLED "_ABM("HDCAT")_"PROCEDURES"
+3 ; Write report header
DO ^ABMDRHD
+4 ; Compute routine
SET ABMQ("RC")="COMPUTE^ABMDRPX"
+5 ; Print routine
SET ABMQ("RP")="PRINT^ABMDRPX1"
+6 ; Namespace
SET ABMQ("RX")="POUT^ABMDRUTL"
+7 SET ABMQ("NS")="ABM"
+8 ; Double queue rtn - uses ABMQ array
DO ^ABMDRDBQ
+9 QUIT
+10 ;
COMPUTE ;EP - Entry Point for Setting up Data
+1 ; Loop through bill file
+2 SET ABM("SUBR")="ABM-PX"
+3 KILL ^TMP(ABM("SUBR"),$JOB)
+4 SET ABMP("RTN")="ABMDRPX"
+5 DO LOOP^ABMDRUTL
+6 QUIT
+7 ;
DATA ;
+1 ; for each bill. . . gather data (called from ABMDRUTL)
+2 SET ABMP("HIT")=0
+3 ; Check bill parameters
DO ^ABMDRCHK
+4 IF 'ABMP("HIT")
QUIT
+5 SET ABM("CL")=+^ABMDBILL(DUZ(2),ABM,0)
+6 IF $DATA(^TMP($JOB,"ABM-PX","CL",ABM("CL")))
QUIT
+7 SET ^TMP($JOB,"ABM-PX","CL",ABM("CL"))=""
+8 IF +ABM("SUB")
DO ONE
+9 IF $GET(ABM("ALL"))
Begin DoDot:1
+10 FOR ABM("SUB")=21,23,25,27,33,35,37,39,43
Begin DoDot:2
+11 IF $ORDER(^ABMDBILL(DUZ(2),ABM,ABM("SUB"),0))
DO ONE
End DoDot:2
+12 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABM,8)),U,10)
IF '$DATA(ABMY("PX"))
Begin DoDot:2
+13 SET ABM("FEE")=$PIECE(^ABMDBILL(DUZ(2),ABM,8),U,10)
+14 SET ABM("CD")=450
+15 SET ABM("NM")=$PIECE(^AUTTREVN(ABM("CD"),0),U,2)
+16 DO TL
End DoDot:2
+17 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABM,9)),U,8)
IF '$DATA(ABMY("PX"))
Begin DoDot:2
+18 SET ABM("FEE")=$PIECE(^ABMDBILL(DUZ(2),ABM,9),U,8)
+19 SET ABM("CD")=$PIECE(^ABMDBILL(DUZ(2),ABM,9),U,7)
+20 SET ABM("NM")=$PIECE(^AUTTREVN(ABM("CD"),0),U,2)
+21 DO TL
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
ONE ;
+1 ; ONE CATEGORY
+2 IF $DATA(ABMY("PX"))
IF "23^25^33^43"[ABM("SUB")
QUIT
+3 SET ABM("PX")=0
+4 FOR
SET ABM("PX")=$ORDER(^ABMDBILL(DUZ(2),ABM,ABM("SUB"),ABM("PX")))
IF 'ABM("PX")
QUIT
Begin DoDot:1
+5 IF '$DATA(^ABMDBILL(DUZ(2),ABM,ABM("SUB"),ABM("PX"),0))
QUIT
+6 SET ABM(0)=^ABMDBILL(DUZ(2),ABM,ABM("SUB"),ABM("PX"),0)
+7 ;S ABM("CD")=$S(ABM("SUB")=23:"ZZZZZ",ABM("SUB")=25:+ABM(0),ABM("SUB")=33:$P(^AUTTADA(+ABM(0),0),U),1:$P($$CPT^ABMCVAPI(+ABM(0),ABM("D")),U,2)) ;CSV-c ;abm*2.6*1 HEAT4716
+8 ;CSV-c ;abm*2.6*1 HEAT4716
SET ABM("CD")=$SELECT(ABM("SUB")=23:$PIECE($GET(ABM(0)),U,24),ABM("SUB")=25:+ABM(0),ABM("SUB")=33:$PIECE(^AUTTADA(+ABM(0),0),U),1:$PIECE($$CPT^ABMCVAPI(+ABM(0),ABM("D")),U,2))
+9 IF +ABM("CD")<+$GET(ABMY("PX",1))
QUIT
+10 IF $DATA(ABMY("PX",2))
IF +ABM("CD")>+ABMY("PX",2)
QUIT
+11 ;S ABM("NM")=$S(ABM("SUB")=23:"PRESCRIPTIONS",ABM("SUB")=25:$E($P(^AUTTREVN(+ABM(0),0),U,2),1,40),ABM("SUB")=33:$E($P(^AUTTADA(+ABM(0),0),U,2),1,40),1:$P($$CPT^ABMCVAPI(+ABM(0),ABM("D")),U,3)) ;CSV-c ;abm*2.6*1 HEAT4716
+12 ;start new code abm*2.6*1 HEAT4716
+13 ;CSV-c
SET ABM("NM")=$SELECT(ABM("SUB")=23&(ABM("CD")'=""):$EXTRACT($PIECE(^PSDRUG(+ABM(0),0),U),1,30),ABM("SUB")=25:$EXTRACT($PIECE(^AUTTREVN(+ABM(0),0),U,2),1,40),ABM("SUB")=33:...
... $EXTRACT($PIECE(^AUTTADA(+ABM(0),0),U,2),1,40),1:$PIECE($$CPT^ABMCVAPI(+ABM(0),ABM("D")),U,3))
+14 IF ABM("SUB")=23&(ABM("CD")="")
SET ABM("NM")="PRESCRIPTIONS"
+15 ;end new code HEAT4716
+16 IF ABM("SUB")=21
SET ABM("FEE")=$PIECE(ABM(0),U,7)
+17 IF ABM("SUB")=23
SET ABM("FEE")=$PIECE(ABM(0),U,3)*$PIECE(ABM(0),U,4)+$PIECE(ABM(0),U,5)
+18 IF ABM("SUB")=25
SET ABM("FEE")=$PIECE(ABM(0),U,2)*$PIECE(ABM(0),U,3)
+19 IF ABM("SUB")=27
SET ABM("FEE")=$PIECE(ABM(0),U,3)*$PIECE(ABM(0),U,4)
+20 IF ABM("SUB")=33
SET ABM("FEE")=$PIECE(ABM(0),U,8)
+21 IF ABM("SUB")=35!(ABM("SUB")=37)!(ABM("SUB")=43)
SET ABM("FEE")=$PIECE(ABM(0),U,3)*$PIECE(ABM(0),U,4)
+22 IF ABM("SUB")=39
Begin DoDot:2
+23 SET ABM("FEE")=$PIECE(ABM(0),U,3)+$PIECE(ABM(0),U,4)
+24 SET ABM("CD")=ABM("CD")_".1"
+25 IF '$GET(ABM("ALL"))
QUIT
+26 SET ABM("NM")=ABM("NM")_" (ANEST)"
End DoDot:2
+27 ;abm*2.6*1 HEAT4716
IF ABM("CD")=""&(ABM("SUB")=23)
SET ABM("CD")="NONDC-"
+28 DO TL
End DoDot:1
+29 QUIT
+30 ;
TL ;
+1 ;SET ENTRY IN TMP
+2 SET $PIECE(^TMP("ABM-PX",$JOB),U)=$PIECE($GET(^TMP("ABM-PX",$JOB)),U)+1
+3 SET $PIECE(^TMP("ABM-PX",$JOB),U,2)=$PIECE(^TMP("ABM-PX",$JOB),U,2)+ABM("FEE")
+4 SET $PIECE(^TMP("ABM-PX",$JOB,ABM("CD")),U)=$PIECE($GET(^TMP("ABM-PX",$JOB,ABM("CD"))),U)+1
SET $PIECE(^(ABM("CD")),U,2)=$PIECE(^(ABM("CD")),U,2)+ABM("FEE")
SET $PIECE(^(ABM("CD")),U,3)=ABM("NM")
+5 QUIT
+6 ;
XIT ;
+1 KILL ABM,ABMY,ABMP
+2 QUIT
