ABMAPASS ; IHS/ASDST/DMJ - PASS INFO TO A/R ;
;;2.6;IHS 3P BILLING SYSTEM;**3,4,6,8,10,11,13,21**;NOV 12, 2009;Build 379
;Original;DMJ
;
;IHS/DSD/MRS-4/1/1999 Modify to check for missing root of insurer array
;IHS/DSD/MRS - 6/23/1999 - NOIS PYA-0499-90061 Patch 3 #2
; Code assumed ICPT ien was equal to .01, not true for type II & III HCPCS. Modified to retrieve numerical ien from "B" cross-reference
; IHS/ASDS/LSL - 05/18/2001 - V2.4 Patch 6 - Modified to accomodate Pharmacy POS posting. Allow RX to pass to A/R Bill file as
; Other Bill Identifier.
;
; IHS/SD/SDR - v2.5 p8 added code to pass ambulance charges
; IHS/SD/SDR - v2.5 p9 IM16864 Correction to bill suffix when rolling over for satellites
; IHS/SD/SDR - v2.5 p10 - IM20395 Split out lines bundled by rev code
;
; IHS/SD/SDR - v2.6 CSV
; IHS/SD/SDR - 2.6*3 modified to pass POS Rejection info if it exists for bill
; IHS/SD/SDR - 2.6*3 modified to pass Re-export dates if any exist on bill
; IHS/SD/SDR - 2.6*4 POS rejection change was causing 3P CREDIT A/R transactions to create.
; Modified to only pass the codes not the whole ABMPOS array.
; IHS/SD/SDR - 2.6*6 NOHEAT - Added code to put a partial bill number as other identifier
;IHS/SD/SDR - 2.6*13 NOHEAT1 - Made change to default date/time approved if there is no export date.
;IHS/SD/SDR - 2.6*21 HEAT118656 - Made changes for total credit for Upload option in A/R
;
; *********************************************************************
; This routine is called each time the Bill Status is changed in the 3P BILL file. It is called as part of
; a cross-reference on the Bill Status (.04) field. It will send the ABMA array to A/R.
; The ABMA array is stored in ^TMP($J,"ABMAPASS") and it is this global that is passed to A/R. The array
; can be defined as follows (Field numbers are as they relate to the 3P BILL file):
; This rtn has been modified so it will work with either A/R 1.1 or 1.0
;
; VARIABLE FIELD # DESCRIPTION
;
; ABMA("BLDA") = .001 = IEN to 3P BILL file
; ABMA("ACTION") = Insurance priority or cancelled status
; value 1 = Primary Insurer
; value 2 = Secondary Insurer
; value 3 = Tertiary Insurer
; value 99 = Cancelled Status
; ABMA("BLNM") = .01 Bill name (bill #-Bill # suffix-HRN)
; ABMA("VSLC") = .03 Visit location
; ABMA("PTNM") = .05 Patient (Pointer)
; ABMA("VSTP") = .07 Visit Type
; ABMA("INS") = .08 Active Insurer
; ABMA("CLNC") = .1 Clinic
; ABMA("DTAP") = .15 Date/Time Approved
; ABMA("DTBILL") = .17 Export number
; ABMA("BLAMT") = .21 Bill Amount
; ABMA("DOSB") = .71 Service Date From
; ABMA("DOSE") = .72 Service Date To
; ABMA("PRIM") = Primary Insurer (Pointer)
; ABMA("SEC") = Secondary Insurer (Pointer)
; ABMA("TERT") = Tertiary Insurer (Pointer)
; ABMA("POLH") = Policy Holder of active insurance
; ABMA("POLN") = Policy Number of active insurance
; ABMA("PROV") = Attending Provider (Pointer)
; ABMA("CREDIT") = Total payments (payment+deductable+coins)
; ABMA("OTHIDENT") = Other Bill Identifier for A/R (from POS)
; ABMA("LICN") = Line Item Control Number (if flat rate) ;abm*2.6*8
;
; ITEM ARRAY
;
; ABMA(cntr,"BLSRV") = Type of service (ie: Dental,Pharmacy)
; ABMA(cntr,"ITCODE") = IEN to REVENUE CODE file
; ABMA(cntr,"ITQT") = total units (quantity)
; ABMA(cntr,"ITTOT") = total charges
; ABMA(cntr,"ITUC") = unit charge
; ABMA(cntr,"OTUC") = dispense fee (pharmacy)
; ABMA(cntr,"OTIT") = "DISPENSE FEE" (Pharmacy)
; ABMA(cntr,"ITNM") = Revenue code description (item)
; ABMA(cntr,"ITCODE") = Revenue code (item code)
; ABMA(cntr,"DOS") = Date of service
; ABMA(cntr,"LICN") = Line Item Control Number ;abm*2.6*8
;
; start new abm*2.6*3 POS Rejection codes
; ABMA(73,"REJDATE") = POS rejection date
; ABMA(73,cnt,"CODE") = code
; ABMA(73,cnt,"REASON") = reason
;
; Re-export info
; ABMA(74,ABMMIEN,"DT")
; ABMA(74,ABMMIEN,"STAT")
; ABMA(74,ABMMIEN,"GCN")
; ABMA(74,ABMMIEN,"RSN")
; ABMA(74,ABMMIEN,"USR")
; end new abm*2.6*3
;
; ******************************
;
START ; START HERE
; X = Bill status in 3P BILL file
;
Q:X=""
Q:"ABTX"'[X ; q: bill not approved, billed, transferred, or cancelled
S ABMP("ARVERS")=$$CV^XBFUNC("BAR")
Q:ABMP("ARVERS")<0 ;Q if A/R not loaded
D BLD ; Build ABMA Array
D PASS ; Pass ABMA Array to A/R
K ABMA,ABM,ABMR,^TMP($J,"ABMPASS")
Q
;
; ********************************
BLD ; PEP
; BUILD ABMA ARRAY (STORED IN TMP for ver 1.1)
; NEEDS X AND DA IF CALLED FROM HERE
; X = Bill status in 3P BILL
; DA = IEN to 3P BILL
;
K ABMA,^TMP($J,"ABMPASS")
S (ABMA("BLDA"),ABMP("BDFN"))=DA
S ABMA="^TMP($J,""ABMPASS"")"
S ABMA("ACTION")=X
; The line below translate cancelled status to 99 for A/R
S:X="X" ABMA("ACTION")=$S(ABMP("ARVERS")'<1.1:99,1:"C")
N I
F I=1:1 S ABMA("LINE")=$T(TXT+I) Q:ABMA("LINE")["END" D
. S ABMA("DR")=$P(ABMA("LINE"),";;",2)
. S ABMA($P(ABMA("LINE"),";;",3))=$$VALI^XBDIQ1("^ABMDBILL(DUZ(2),",DA,ABMA("DR"))
. I ABMA("DR")=.17,ABMA("DTBILL") S ABMA("DTBILL")=$$VALI^XBDIQ1(^DIC(9002274.6,0,"GL"),ABMA("DTBILL"),.01)
;I ABMA("ACTION")="B",ABMA("DTBILL")="" S ABMA("DTBILL")=DT ;abm*2.6*13 NOHEAT1
I ABMA("ACTION")="B",ABMA("DTBILL")="" S ABMA("DTBILL")=ABMA("DTAP") ;abm*2.6*13 NOHEAT1
D BLNM ;Calculate complete bill name
N I,DA,K
S K=0
; Loop through each type of bill service and find ITEM ARRAY data
S ABMP("VDT")=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U) ;fix for CSV; needed for CSV API call
;start new code ABM*2.6*11 HEAT90370
S:'+$G(ABMP("INS")) ABMP("INS")=+$G(ABMA("INS"))
S:'+$G(ABMP("LDFN")) ABMP("LDFN")=+$G(ABMA("VSLC"))
;end new code HEAT90370
F I=21,23,25,27,33,35,37,39,43,47 D
. K ABM,ABMRV
. D @(I_"^ABMERGR2") ;Build ABRV Array for all items for service type
. Q:'$D(ABMRV) ;quit if no items for this service type
. D CONV ;Convert ABRV Array to ABMA array
K ABMRV
D ORV^ABMERGRV ;Find other items (Revenue codes)
N I
S I=.97
D CONV
N ABME
; Get insurer data
;S ABMP("ITYPE")=$P($G(^AUTNINS(+ABMA("INS"),2)),"^",1) ;abm*2.6*10 HEAT73780
S ABMP("ITYPE")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMA("INS"),".211","I"),1,"I") ;abm*2.6*10 HEAT73780
D ISET^ABMERUTL ;Set insurer priorities based on 3P BILL
D CONV2 ;Convert insurer to ABMA array
K ABMP("SET")
S ABMP("PDFN")=ABMA("PTNM")
S ABME("INS")=ABMA("INS")
;The following line has been added to Klamath falls ***
I '$G(ABME("INSIEN")),'($D(ABMP("INS"))#2) S ABMP("INS")=""
; Get policy data of active insurer
D EN^XBNEW("ISET^ABMERINS","ABME,ABMP,ABMR")
S ABMA("POLH")=$G(ABME("PHNM"))
S ABMA("POLN")=$G(ABMR(30,70))
;
D PROV ;Get Attending provider
;S ABMA("CREDIT")=$$TCR^ABMERUTL(ABMP("BDFN")) ;Total Credit ;abm*2.6*21 IHS/SD/SDR HEAT118656
D TCR ;Total Credit abm*2.6*21 IHS/SD/SDR HEAT118656
S ABMA("OTHIDENT")=$G(ABMPOS("OTHIDENT"))
I ($G(ABMA("OTHIDENT"))=""),($L(ABMA("BLNM")>14)) S ABMA("OTHIDENT")=$E(ABMA("BLNM"),1,14) ;abm*2.6*6 NOHEAT
K ABMA("LINE"),ABMA("DR"),ABMA("DA")
I $P($G(^AUTNINS(ABMA("INS"),2)),"^",1)="N" S ABMA("INS")=""
;I ABMP("ARVERS")'<1.1 M @ABMA=ABMA ;abm*2.6*3
;
;I $D(ABMPOS) M ABMA=ABMPOS ;abm*2.6*3 POS Rejections ;abm*2.6*4
I $D(ABMPOS) M ABMA(73)=ABMPOS(73) ;abm*2.6*4
;start new abm*2.6*3 re-export dates
I $G(ABMREX("BDFN")),$D(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74)) D
.S ABMMIEN=0
.F S ABMMIEN=$O(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN)) Q:(+$G(ABMMIEN)=0) D
..S ABMA(74,ABMMIEN,"DT")=$P($G(^ABMDTXST(DUZ(2),$P($G(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U),0)),U)
..S ABMA(74,ABMMIEN,"STAT")=$P($G(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U,2)
..S ABMA(74,ABMMIEN,"GCN")=$P($G(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U,3)
..S ABMTXIEN=$O(^ABMDTXST(DUZ(2),$P($G(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U),3,"B",ABMA(74,ABMMIEN,"DT"),0))
..I ABMTXIEN'="" D
...S ABMA(74,ABMMIEN,"USR")=$P($G(^ABMDTXST(DUZ(2),$P($G(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U),3,ABMTXIEN,0)),U,4)
...S ABMA(74,ABMMIEN,"RSN")=$P($G(^ABMDTXST(DUZ(2),$P($G(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U),3,ABMTXIEN,0)),U,5)
I $G(ABMREX("BDFN")),+$G(ABMP("XMIT"))'=0 D
.I $D(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,"B",ABMP("XMIT"))) Q ;already has this transmission
.S ABMMIEN=($O(ABMA(74,99999),-1)+1)
.S ABMTXIEN=$O(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,"B",$P($G(^ABMDTXST(DUZ(2),ABMP("XMIT"),0)),U),0))
.I ABMTXIEN'="" D
..S ABMA(74,ABMMIEN,"DT")=$P($G(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,ABMTXIEN,0)),U)
..S ABMA(74,ABMMIEN,"GCN")=$P($G(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,ABMTXIEN,0)),U,2)
..S ABMSTAT="O"
..I $G(ABMREX("BILLSELECT"))'="" S ABMSTAT="F"
..I $G(ABMREX("BATCHSELECT"))'="" S ABMSTAT="S"
..I $G(ABMREX("RECREATE"))'="" S ABMSTAT="C"
..S ABMA(74,ABMMIEN,"STAT")=ABMSTAT
..S ABMA(74,ABMMIEN,"USR")=$P($G(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,ABMTXIEN,0)),U,4)
..S ABMA(74,ABMMIEN,"RSN")=$P($G(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,ABMTXIEN,0)),U,5)
;end new abm*2.6*3 re-export dates
;
I ABMP("ARVERS")'<1.1 M @ABMA=ABMA ;abm*2.6*3
Q
;
;start new abm*2.6*21 IHS/SD/SDR HEAT118656
TCR ;EP
;transactions from A/R
; ABMA("TRNS",ADJ TYP,COUNTER)=ADJ AMT^DATE^ADJ CAT^ADJ TYPE^SAR
K ABMA("TRNS")
N ABMATREC,ABMTCNT,ABMTAMT
S I=0
F S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),3,I)) Q:'I D
.S ABMATREC=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),3,I,0))
.S ABMTCNT=+$G(ABMTCNT)+1
.I +$P(ABMATREC,U,10)'=0 S ABMA("TRNS","PAYMENT CREDIT",ABMTCNT)=+$P(ABMATREC,U,10),ABMRTYP="PAYMENT CREDIT",ABMTAMT=+$G(ABMTAMT)+$P(ABMATREC,U,10)
.I +$P(ABMATREC,U,3) S ABMA("TRNS","DEDUCTIBLE",ABMTCNT)=+$P(ABMATREC,U,3),ABMRTYP="DEDUCTIBLE",ABMTAMT=+$G(ABMTAMT)+$P(ABMATREC,U,3)
.I +$P(ABMATREC,U,4) S ABMA("TRNS","CO-PAY",ABMTCNT)=+$P(ABMATREC,U,4),ABMRTYP="CO-PAY",ABMTAMT=+$G(ABMTAMT)+$P(ABMATREC,U,4)
.I +$P(ABMATREC,U,6) S ABMA("TRNS","WRITE OFF",ABMTCNT)=+$P(ABMATREC,U,6),ABMRTYP="WRITE OFF",ABMTAMT=+$G(ABMTAMT)+$P(ABMATREC,U,6)
.I +$P(ABMATREC,U,7) S ABMA("TRNS","NON PAYMENT",ABMTCNT)=+$P(ABMATREC,U,7),ABMRTYP="NON PAYMENT",ABMTAMT=+$G(ABMTAMT)+$P(ABMATREC,U,7)
.I +$P(ABMATREC,U,9) S ABMA("TRNS","PENALTY",ABMTCNT)=+$P(ABMATREC,U,9),ABMRTYP="PENALTY",ABMTAMT=+$G(ABMTAMT)+$P(ABMATREC,U,9)
.I +$P(ABMATREC,U,12) S ABMA("TRNS","GROUPER ALLOWANCE",ABMTCNT)=+$P(ABMATREC,U,12),ABMRTYP="GROUPER ALLOWANCE",ABMTAMT=+$G(ABMTAMT)+$P(ABMATREC,U,12)
.I +$P(ABMATREC,U,13) S ABMA("TRNS","REFUND",ABMTCNT)=+$P(ABMATREC,U,13),ABMTYP="REFUND",ABMTAMT=+$G(ABMTAMT)+$P(ABMATREC,U,13)
.S $P(ABMA("TRNS",ABMRTYP,ABMTCNT),U,2)=$P(ABMATREC,U)
.I +$P(ABMATREC,U,14)'=0 D
..S ABMTCNT=+$G(ABMTCNT)+1
..S ABMA("TRNS","PAYMENT CREDIT",ABMTCNT)=+$P(ABMATREC,U,14)
..S ABMRTYP="PAYMENT CREDIT"
..S ABMTAMT=+$G(ABMTAMT)+$P(ABMATREC,U,14)
..S $P(ABMA("TRNS",ABMRTYP,ABMTCNT),U,2)=$P(ABMATREC,U)
.Q:(ABMRTYP="PAYMENT CREDIT") ;below this is for adjs only
.S $P(ABMA("TRNS",ABMRTYP,ABMTCNT),U,3)=$P(ABMATREC,U,15)
.S $P(ABMA("TRNS",ABMRTYP,ABMTCNT),U,4)=$P(ABMATREC,U,16)
.S $P(ABMA("TRNS",ABMRTYP,ABMTCNT),U,5)=$P(ABMATREC,U,17)
S ABMA("CREDIT")=+$G(ABMTAMT)
Q
;end new abm*2.6*21 IHS/SD/SDR HEAT118656
;
PASS ;
;PASS TO A/R
I ABMP("ARVERS")'<1.1 D
. D TPB^BARUP(ABMA)
E D TPB^BARUP(.ABMA)
S $P(^ABMDBILL(DUZ(2),DA,2),U,6)=$G(^TMP($J,"ABMPASS","ARLOC"))
Q
;
; ***************************
BLNM ;EP - get full bill name
I $P($G(^ABMDPARM(ABMA("VSLC"),1,2)),"^",4)]"" S ABMA("BLNM")=ABMA("BLNM")_"-"_$P(^(2),"^",4)
I $P($G(^ABMDPARM(ABMA("VSLC"),1,3)),"^",3)=1 D
.S ABM("HRN")=$P($G(^AUPNPAT(ABMA("PTNM"),41,ABMA("VSLC"),0)),"^",2)
.S:ABM("HRN")]"" ABMA("BLNM")=ABMA("BLNM")_"-"_ABM("HRN")
Q
;
; ***************************
CONV ;
;CONVERT ABMRV ARRAY TO ABMA ARRAY
N L
N J
I '$D(ABMP("ARVERS")) S ABMP("ARVERS")=$$CV^XBFUNC("BAR")
S L=-1
F S L=$O(ABMRV(L)) Q:L="" D
.S J=-1
.F S J=$O(ABMRV(L,J)) Q:J="" D
..S M=0
..F S M=$O(ABMRV(L,J,M)) Q:M="" D
...S K=K+1
...S ABMA(K,"DOS")=""
...S ABMA(K,"BLSRV")=$P(^DD(9002274.4,I,0),U)
...S ABMA(K,"BLSRV")=$$UPC^ABMERUTL(ABMA(K,"BLSRV"))
...S ABMA(K,"BLSRV")=$TR(ABMA(K,"BLSRV"),"*")
...S ABMA(K,"ITCODE")=L
...S ABMA(K,"ITQT")=$P(ABMRV(L,J,M),U,5)
...S ABMA(K,"ITTOT")=$P(ABMRV(L,J,M),U,6)
...S ABMA(K,"ITUC")=ABMA(K,"ITTOT")
...S ABMA(K,"LICN")=$P(ABMRV(L,J,M),U,38) ;abm*2.6*8
...I I=23 D
....S ABMA(K,"OTUC")=ABM(5)
....S ABMA(K,"OTIT")="DISPENSE FEE"
....S ABMA(K,"ITUC")=ABMA(K,"ITTOT")-ABM(5)
....S ABMA(K,"ITNM")=$P(ABMRV(L,J,M),U,9) ;Medicine code
...I I=25 S ABMA(K,"ITNM")=$P($G(^AUTTREVN(L,0)),U,2)
...I J]"",I'=23,I'=33 D
....N ABMJIEN
....S ABMJIEN=$O(^ICPT("B",J,"")) ;GET NUMERICAL ien
....I ABMJIEN S ABMA(K,"ITNM")=$P($$CPT^ABMCVAPI(ABMJIEN,$P(ABMRV(L,J,M),U,10),ABMP("VDT")),U,3) Q ;CSV-c
....S ABMA(K,"ITNM")=$P($$CPT^ABMCVAPI(J,$P(ABMRV(L,J,M),U,10),ABMP("VDT")),U,3) ;CSV-c
....S ABMA(K,"ITCODE")=J
...I J,I=33 D
....S ABMA(K,"ITCODE")=$P(ABMRV(L,J,M),U,2)
...S:$P(ABMRV(L,J,M),U,9)'="" ABMA(K,"ITNM")=$P(ABMRV(L,J,M),U,9)
...S:$P(ABMRV(L,J,M),U,10) ABMA(K,"DOS")=$P(ABMRV(L,J,M),U,10)
...I '$G(ABMA(K,"ITQT")) S ABMA(K,"ITUC")=0 Q
...S ABMA(K,"ITUC")=$J(ABMA(K,"ITUC")/ABMA(K,"ITQT"),1,3)
...I ABMP("ARVERS")'<1.1 D
....M @ABMA@(K)=ABMA(K)
....K ABMA(K)
Q
;
; ****************************
CONV2 ;
;CONVERT INSURER ARRAY
F I=1:1:3 D
. Q:'$D(ABMP("INS",I))
. Q:ABMA("ACTION")=$S(ABMP("ARVERS")'<1.1:99,1:"C")
. S:+ABMP("INS",I)=ABMA("INS") ABMA("ACTION")=I
. S:$P($G(^AUTNINS(+ABMP("INS",I),0)),"^",1)="N" ABMP("INS",I)=""
S ABMA("PRIM")=$P($G(ABMP("INS",1)),"^",1)
S ABMA("SEC")=$P($G(ABMP("INS",2)),"^",1)
S ABMA("TERT")=$P($G(ABMP("INS",3)),"^",1)
Q
;
; *************************
PROV ;
;GET ATTENDING PROVIDER
S ABMA("PROV")=""
N I
S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0))
N J
S J=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,+I,0)),"^",1)
S ABMA("PROV")=J
Q
;
; **********************
TXT ;FIELDS
;;.01;;BLNM
;;.03;;VSLC
;;.05;;PTNM
;;.07;;VSTP
;;.08;;INS
;;.1;;CLNC
;;.15;;DTAP
;;.17;;DTBILL
;;.21;;BLAMT
;;.29;;LICN
;;.71;;DOSB
;;.72;;DOSE
;;END
;abm*2.6*8 added .29 field above
;
; ********************************
EXT ;EP
;EXTERNAL CALL (NEEDS DA DEFINED)
S DIC="^ABMDBILL(DUZ(2),"
S X="A"
D START
K ABM,ABMP,ABMA,ABME
Q
ABMAPASS ; IHS/ASDST/DMJ - PASS INFO TO A/R ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**3,4,6,8,10,11,13,21**;NOV 12, 2009;Build 379
+2 ;Original;DMJ
+3 ;
+4 ;IHS/DSD/MRS-4/1/1999 Modify to check for missing root of insurer array
+5 ;IHS/DSD/MRS - 6/23/1999 - NOIS PYA-0499-90061 Patch 3 #2
+6 ; Code assumed ICPT ien was equal to .01, not true for type II & III HCPCS. Modified to retrieve numerical ien from "B" cross-reference
+7 ; IHS/ASDS/LSL - 05/18/2001 - V2.4 Patch 6 - Modified to accomodate Pharmacy POS posting. Allow RX to pass to A/R Bill file as
+8 ; Other Bill Identifier.
+9 ;
+10 ; IHS/SD/SDR - v2.5 p8 added code to pass ambulance charges
+11 ; IHS/SD/SDR - v2.5 p9 IM16864 Correction to bill suffix when rolling over for satellites
+12 ; IHS/SD/SDR - v2.5 p10 - IM20395 Split out lines bundled by rev code
+13 ;
+14 ; IHS/SD/SDR - v2.6 CSV
+15 ; IHS/SD/SDR - 2.6*3 modified to pass POS Rejection info if it exists for bill
+16 ; IHS/SD/SDR - 2.6*3 modified to pass Re-export dates if any exist on bill
+17 ; IHS/SD/SDR - 2.6*4 POS rejection change was causing 3P CREDIT A/R transactions to create.
+18 ; Modified to only pass the codes not the whole ABMPOS array.
+19 ; IHS/SD/SDR - 2.6*6 NOHEAT - Added code to put a partial bill number as other identifier
+20 ;IHS/SD/SDR - 2.6*13 NOHEAT1 - Made change to default date/time approved if there is no export date.
+21 ;IHS/SD/SDR - 2.6*21 HEAT118656 - Made changes for total credit for Upload option in A/R
+22 ;
+23 ; *********************************************************************
+24 ; This routine is called each time the Bill Status is changed in the 3P BILL file. It is called as part of
+25 ; a cross-reference on the Bill Status (.04) field. It will send the ABMA array to A/R.
+26 ; The ABMA array is stored in ^TMP($J,"ABMAPASS") and it is this global that is passed to A/R. The array
+27 ; can be defined as follows (Field numbers are as they relate to the 3P BILL file):
+28 ; This rtn has been modified so it will work with either A/R 1.1 or 1.0
+29 ;
+30 ; VARIABLE FIELD # DESCRIPTION
+31 ;
+32 ; ABMA("BLDA") = .001 = IEN to 3P BILL file
+33 ; ABMA("ACTION") = Insurance priority or cancelled status
+34 ; value 1 = Primary Insurer
+35 ; value 2 = Secondary Insurer
+36 ; value 3 = Tertiary Insurer
+37 ; value 99 = Cancelled Status
+38 ; ABMA("BLNM") = .01 Bill name (bill #-Bill # suffix-HRN)
+39 ; ABMA("VSLC") = .03 Visit location
+40 ; ABMA("PTNM") = .05 Patient (Pointer)
+41 ; ABMA("VSTP") = .07 Visit Type
+42 ; ABMA("INS") = .08 Active Insurer
+43 ; ABMA("CLNC") = .1 Clinic
+44 ; ABMA("DTAP") = .15 Date/Time Approved
+45 ; ABMA("DTBILL") = .17 Export number
+46 ; ABMA("BLAMT") = .21 Bill Amount
+47 ; ABMA("DOSB") = .71 Service Date From
+48 ; ABMA("DOSE") = .72 Service Date To
+49 ; ABMA("PRIM") = Primary Insurer (Pointer)
+50 ; ABMA("SEC") = Secondary Insurer (Pointer)
+51 ; ABMA("TERT") = Tertiary Insurer (Pointer)
+52 ; ABMA("POLH") = Policy Holder of active insurance
+53 ; ABMA("POLN") = Policy Number of active insurance
+54 ; ABMA("PROV") = Attending Provider (Pointer)
+55 ; ABMA("CREDIT") = Total payments (payment+deductable+coins)
+56 ; ABMA("OTHIDENT") = Other Bill Identifier for A/R (from POS)
+57 ; ABMA("LICN") = Line Item Control Number (if flat rate) ;abm*2.6*8
+58 ;
+59 ; ITEM ARRAY
+60 ;
+61 ; ABMA(cntr,"BLSRV") = Type of service (ie: Dental,Pharmacy)
+62 ; ABMA(cntr,"ITCODE") = IEN to REVENUE CODE file
+63 ; ABMA(cntr,"ITQT") = total units (quantity)
+64 ; ABMA(cntr,"ITTOT") = total charges
+65 ; ABMA(cntr,"ITUC") = unit charge
+66 ; ABMA(cntr,"OTUC") = dispense fee (pharmacy)
+67 ; ABMA(cntr,"OTIT") = "DISPENSE FEE" (Pharmacy)
+68 ; ABMA(cntr,"ITNM") = Revenue code description (item)
+69 ; ABMA(cntr,"ITCODE") = Revenue code (item code)
+70 ; ABMA(cntr,"DOS") = Date of service
+71 ; ABMA(cntr,"LICN") = Line Item Control Number ;abm*2.6*8
+72 ;
+73 ; start new abm*2.6*3 POS Rejection codes
+74 ; ABMA(73,"REJDATE") = POS rejection date
+75 ; ABMA(73,cnt,"CODE") = code
+76 ; ABMA(73,cnt,"REASON") = reason
+77 ;
+78 ; Re-export info
+79 ; ABMA(74,ABMMIEN,"DT")
+80 ; ABMA(74,ABMMIEN,"STAT")
+81 ; ABMA(74,ABMMIEN,"GCN")
+82 ; ABMA(74,ABMMIEN,"RSN")
+83 ; ABMA(74,ABMMIEN,"USR")
+84 ; end new abm*2.6*3
+85 ;
+86 ; ******************************
+87 ;
START ; START HERE
+1 ; X = Bill status in 3P BILL file
+2 ;
+3 IF X=""
QUIT
+4 ; q: bill not approved, billed, transferred, or cancelled
IF "ABTX"'[X
QUIT
+5 SET ABMP("ARVERS")=$$CV^XBFUNC("BAR")
+6 ;Q if A/R not loaded
IF ABMP("ARVERS")<0
QUIT
+7 ; Build ABMA Array
DO BLD
+8 ; Pass ABMA Array to A/R
DO PASS
+9 KILL ABMA,ABM,ABMR,^TMP($JOB,"ABMPASS")
+10 QUIT
+11 ;
+12 ; ********************************
BLD ; PEP
+1 ; BUILD ABMA ARRAY (STORED IN TMP for ver 1.1)
+2 ; NEEDS X AND DA IF CALLED FROM HERE
+3 ; X = Bill status in 3P BILL
+4 ; DA = IEN to 3P BILL
+5 ;
+6 KILL ABMA,^TMP($JOB,"ABMPASS")
+7 SET (ABMA("BLDA"),ABMP("BDFN"))=DA
+8 SET ABMA="^TMP($J,""ABMPASS"")"
+9 SET ABMA("ACTION")=X
+10 ; The line below translate cancelled status to 99 for A/R
+11 IF X="X"
SET ABMA("ACTION")=$SELECT(ABMP("ARVERS")'<1.1:99,1:"C")
+12 NEW I
+13 FOR I=1:1
SET ABMA("LINE")=$TEXT(TXT+I)
IF ABMA("LINE")["END"
QUIT
Begin DoDot:1
+14 SET ABMA("DR")=$PIECE(ABMA("LINE"),";;",2)
+15 SET ABMA($PIECE(ABMA("LINE"),";;",3))=$$VALI^XBDIQ1("^ABMDBILL(DUZ(2),",DA,ABMA("DR"))
+16 IF ABMA("DR")=.17
IF ABMA("DTBILL")
SET ABMA("DTBILL")=$$VALI^XBDIQ1(^DIC(9002274.6,0,"GL"),ABMA("DTBILL"),.01)
End DoDot:1
+17 ;I ABMA("ACTION")="B",ABMA("DTBILL")="" S ABMA("DTBILL")=DT ;abm*2.6*13 NOHEAT1
+18 ;abm*2.6*13 NOHEAT1
IF ABMA("ACTION")="B"
IF ABMA("DTBILL")=""
SET ABMA("DTBILL")=ABMA("DTAP")
+19 ;Calculate complete bill name
DO BLNM
+20 NEW I,DA,K
+21 SET K=0
+22 ; Loop through each type of bill service and find ITEM ARRAY data
+23 ;fix for CSV; needed for CSV API call
SET ABMP("VDT")=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U)
+24 ;start new code ABM*2.6*11 HEAT90370
+25 IF '+$GET(ABMP("INS"))
SET ABMP("INS")=+$GET(ABMA("INS"))
+26 IF '+$GET(ABMP("LDFN"))
SET ABMP("LDFN")=+$GET(ABMA("VSLC"))
+27 ;end new code HEAT90370
+28 FOR I=21,23,25,27,33,35,37,39,43,47
Begin DoDot:1
+29 KILL ABM,ABMRV
+30 ;Build ABRV Array for all items for service type
DO @(I_"^ABMERGR2")
+31 ;quit if no items for this service type
IF '$DATA(ABMRV)
QUIT
+32 ;Convert ABRV Array to ABMA array
DO CONV
End DoDot:1
+33 KILL ABMRV
+34 ;Find other items (Revenue codes)
DO ORV^ABMERGRV
+35 NEW I
+36 SET I=.97
+37 DO CONV
+38 NEW ABME
+39 ; Get insurer data
+40 ;S ABMP("ITYPE")=$P($G(^AUTNINS(+ABMA("INS"),2)),"^",1) ;abm*2.6*10 HEAT73780
+41 ;abm*2.6*10 HEAT73780
SET ABMP("ITYPE")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMA("INS"),".211","I"),1,"I")
+42 ;Set insurer priorities based on 3P BILL
DO ISET^ABMERUTL
+43 ;Convert insurer to ABMA array
DO CONV2
+44 KILL ABMP("SET")
+45 SET ABMP("PDFN")=ABMA("PTNM")
+46 SET ABME("INS")=ABMA("INS")
+47 ;The following line has been added to Klamath falls ***
+48 IF '$GET(ABME("INSIEN"))
IF '($DATA(ABMP("INS"))#2)
SET ABMP("INS")=""
+49 ; Get policy data of active insurer
+50 DO EN^XBNEW("ISET^ABMERINS","ABME,ABMP,ABMR")
+51 SET ABMA("POLH")=$GET(ABME("PHNM"))
+52 SET ABMA("POLN")=$GET(ABMR(30,70))
+53 ;
+54 ;Get Attending provider
DO PROV
+55 ;S ABMA("CREDIT")=$$TCR^ABMERUTL(ABMP("BDFN")) ;Total Credit ;abm*2.6*21 IHS/SD/SDR HEAT118656
+56 ;Total Credit abm*2.6*21 IHS/SD/SDR HEAT118656
DO TCR
+57 SET ABMA("OTHIDENT")=$GET(ABMPOS("OTHIDENT"))
+58 ;abm*2.6*6 NOHEAT
IF ($GET(ABMA("OTHIDENT"))="")
IF ($LENGTH(ABMA("BLNM")>14))
SET ABMA("OTHIDENT")=$EXTRACT(ABMA("BLNM"),1,14)
+59 KILL ABMA("LINE"),ABMA("DR"),ABMA("DA")
+60 IF $PIECE($GET(^AUTNINS(ABMA("INS"),2)),"^",1)="N"
SET ABMA("INS")=""
+61 ;I ABMP("ARVERS")'<1.1 M @ABMA=ABMA ;abm*2.6*3
+62 ;
+63 ;I $D(ABMPOS) M ABMA=ABMPOS ;abm*2.6*3 POS Rejections ;abm*2.6*4
+64 ;abm*2.6*4
IF $DATA(ABMPOS)
MERGE ABMA(73)=ABMPOS(73)
+65 ;start new abm*2.6*3 re-export dates
+66 IF $GET(ABMREX("BDFN"))
IF $DATA(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74))
Begin DoDot:1
+67 SET ABMMIEN=0
+68 FOR
SET ABMMIEN=$ORDER(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN))
IF (+$GET(ABMMIEN)=0)
QUIT
Begin DoDot:2
+69 SET ABMA(74,ABMMIEN,"DT")=$PIECE($GET(^ABMDTXST(DUZ(2),$PIECE($GET(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U),0)),U)
+70 SET ABMA(74,ABMMIEN,"STAT")=$PIECE($GET(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U,2)
+71 SET ABMA(74,ABMMIEN,"GCN")=$PIECE($GET(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U,3)
+72 SET ABMTXIEN=$ORDER(^ABMDTXST(DUZ(2),$PIECE($GET(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U),3,"B",ABMA(74,ABMMIEN,"DT"),0))
+73 IF ABMTXIEN'=""
Begin DoDot:3
+74 SET ABMA(74,ABMMIEN,"USR")=$PIECE($GET(^ABMDTXST(DUZ(2),$PIECE($GET(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U),3,ABMTXIEN,0)),U,4)
+75 SET ABMA(74,ABMMIEN,"RSN")=$PIECE($GET(^ABMDTXST(DUZ(2),$PIECE($GET(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,ABMMIEN,0)),U),3,ABMTXIEN,0)),U,5)
End DoDot:3
End DoDot:2
End DoDot:1
+76 IF $GET(ABMREX("BDFN"))
IF +$GET(ABMP("XMIT"))'=0
Begin DoDot:1
+77 ;already has this transmission
IF $DATA(^ABMDBILL(DUZ(2),ABMREX("BDFN"),74,"B",ABMP("XMIT")))
QUIT
+78 SET ABMMIEN=($ORDER(ABMA(74,99999),-1)+1)
+79 SET ABMTXIEN=$ORDER(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,"B",$PIECE($GET(^ABMDTXST(DUZ(2),ABMP("XMIT"),0)),U),0))
+80 IF ABMTXIEN'=""
Begin DoDot:2
+81 SET ABMA(74,ABMMIEN,"DT")=$PIECE($GET(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,ABMTXIEN,0)),U)
+82 SET ABMA(74,ABMMIEN,"GCN")=$PIECE($GET(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,ABMTXIEN,0)),U,2)
+83 SET ABMSTAT="O"
+84 IF $GET(ABMREX("BILLSELECT"))'=""
SET ABMSTAT="F"
+85 IF $GET(ABMREX("BATCHSELECT"))'=""
SET ABMSTAT="S"
+86 IF $GET(ABMREX("RECREATE"))'=""
SET ABMSTAT="C"
+87 SET ABMA(74,ABMMIEN,"STAT")=ABMSTAT
+88 SET ABMA(74,ABMMIEN,"USR")=$PIECE($GET(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,ABMTXIEN,0)),U,4)
+89 SET ABMA(74,ABMMIEN,"RSN")=$PIECE($GET(^ABMDTXST(DUZ(2),ABMP("XMIT"),3,ABMTXIEN,0)),U,5)
End DoDot:2
End DoDot:1
+90 ;end new abm*2.6*3 re-export dates
+91 ;
+92 ;abm*2.6*3
IF ABMP("ARVERS")'<1.1
MERGE @ABMA=ABMA
+93 QUIT
+94 ;
+95 ;start new abm*2.6*21 IHS/SD/SDR HEAT118656
TCR ;EP
+1 ;transactions from A/R
+2 ; ABMA("TRNS",ADJ TYP,COUNTER)=ADJ AMT^DATE^ADJ CAT^ADJ TYPE^SAR
+3 KILL ABMA("TRNS")
+4 NEW ABMATREC,ABMTCNT,ABMTAMT
+5 SET I=0
+6 FOR
SET I=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),3,I))
IF 'I
QUIT
Begin DoDot:1
+7 SET ABMATREC=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),3,I,0))
+8 SET ABMTCNT=+$GET(ABMTCNT)+1
+9 IF +$PIECE(ABMATREC,U,10)'=0
SET ABMA("TRNS","PAYMENT CREDIT",ABMTCNT)=+$PIECE(ABMATREC,U,10)
SET ABMRTYP="PAYMENT CREDIT"
SET ABMTAMT=+$GET(ABMTAMT)+$PIECE(ABMATREC,U,10)
+10 IF +$PIECE(ABMATREC,U,3)
SET ABMA("TRNS","DEDUCTIBLE",ABMTCNT)=+$PIECE(ABMATREC,U,3)
SET ABMRTYP="DEDUCTIBLE"
SET ABMTAMT=+$GET(ABMTAMT)+$PIECE(ABMATREC,U,3)
+11 IF +$PIECE(ABMATREC,U,4)
SET ABMA("TRNS","CO-PAY",ABMTCNT)=+$PIECE(ABMATREC,U,4)
SET ABMRTYP="CO-PAY"
SET ABMTAMT=+$GET(ABMTAMT)+$PIECE(ABMATREC,U,4)
+12 IF +$PIECE(ABMATREC,U,6)
SET ABMA("TRNS","WRITE OFF",ABMTCNT)=+$PIECE(ABMATREC,U,6)
SET ABMRTYP="WRITE OFF"
SET ABMTAMT=+$GET(ABMTAMT)+$PIECE(ABMATREC,U,6)
+13 IF +$PIECE(ABMATREC,U,7)
SET ABMA("TRNS","NON PAYMENT",ABMTCNT)=+$PIECE(ABMATREC,U,7)
SET ABMRTYP="NON PAYMENT"
SET ABMTAMT=+$GET(ABMTAMT)+$PIECE(ABMATREC,U,7)
+14 IF +$PIECE(ABMATREC,U,9)
SET ABMA("TRNS","PENALTY",ABMTCNT)=+$PIECE(ABMATREC,U,9)
SET ABMRTYP="PENALTY"
SET ABMTAMT=+$GET(ABMTAMT)+$PIECE(ABMATREC,U,9)
+15 IF +$PIECE(ABMATREC,U,12)
SET ABMA("TRNS","GROUPER ALLOWANCE",ABMTCNT)=+$PIECE(ABMATREC,U,12)
SET ABMRTYP="GROUPER ALLOWANCE"
SET ABMTAMT=+$GET(ABMTAMT)+$PIECE(ABMATREC,U,12)
+16 IF +$PIECE(ABMATREC,U,13)
SET ABMA("TRNS","REFUND",ABMTCNT)=+$PIECE(ABMATREC,U,13)
SET ABMTYP="REFUND"
SET ABMTAMT=+$GET(ABMTAMT)+$PIECE(ABMATREC,U,13)
+17 SET $PIECE(ABMA("TRNS",ABMRTYP,ABMTCNT),U,2)=$PIECE(ABMATREC,U)
+18 IF +$PIECE(ABMATREC,U,14)'=0
Begin DoDot:2
+19 SET ABMTCNT=+$GET(ABMTCNT)+1
+20 SET ABMA("TRNS","PAYMENT CREDIT",ABMTCNT)=+$PIECE(ABMATREC,U,14)
+21 SET ABMRTYP="PAYMENT CREDIT"
+22 SET ABMTAMT=+$GET(ABMTAMT)+$PIECE(ABMATREC,U,14)
+23 SET $PIECE(ABMA("TRNS",ABMRTYP,ABMTCNT),U,2)=$PIECE(ABMATREC,U)
End DoDot:2
+24 ;below this is for adjs only
IF (ABMRTYP="PAYMENT CREDIT")
QUIT
+25 SET $PIECE(ABMA("TRNS",ABMRTYP,ABMTCNT),U,3)=$PIECE(ABMATREC,U,15)
+26 SET $PIECE(ABMA("TRNS",ABMRTYP,ABMTCNT),U,4)=$PIECE(ABMATREC,U,16)
+27 SET $PIECE(ABMA("TRNS",ABMRTYP,ABMTCNT),U,5)=$PIECE(ABMATREC,U,17)
End DoDot:1
+28 SET ABMA("CREDIT")=+$GET(ABMTAMT)
+29 QUIT
+30 ;end new abm*2.6*21 IHS/SD/SDR HEAT118656
+31 ;
PASS ;
+1 ;PASS TO A/R
+2 IF ABMP("ARVERS")'<1.1
Begin DoDot:1
+3 DO TPB^BARUP(ABMA)
End DoDot:1
+4 IF '$TEST
DO TPB^BARUP(.ABMA)
+5 SET $PIECE(^ABMDBILL(DUZ(2),DA,2),U,6)=$GET(^TMP($JOB,"ABMPASS","ARLOC"))
+6 QUIT
+7 ;
+8 ; ***************************
BLNM ;EP - get full bill name
+1 IF $PIECE($GET(^ABMDPARM(ABMA("VSLC"),1,2)),"^",4)]""
SET ABMA("BLNM")=ABMA("BLNM")_"-"_$PIECE(^(2),"^",4)
+2 IF $PIECE($GET(^ABMDPARM(ABMA("VSLC"),1,3)),"^",3)=1
Begin DoDot:1
+3 SET ABM("HRN")=$PIECE($GET(^AUPNPAT(ABMA("PTNM"),41,ABMA("VSLC"),0)),"^",2)
+4 IF ABM("HRN")]""
SET ABMA("BLNM")=ABMA("BLNM")_"-"_ABM("HRN")
End DoDot:1
+5 QUIT
+6 ;
+7 ; ***************************
CONV ;
+1 ;CONVERT ABMRV ARRAY TO ABMA ARRAY
+2 NEW L
+3 NEW J
+4 IF '$DATA(ABMP("ARVERS"))
SET ABMP("ARVERS")=$$CV^XBFUNC("BAR")
+5 SET L=-1
+6 FOR
SET L=$ORDER(ABMRV(L))
IF L=""
QUIT
Begin DoDot:1
+7 SET J=-1
+8 FOR
SET J=$ORDER(ABMRV(L,J))
IF J=""
QUIT
Begin DoDot:2
+9 SET M=0
+10 FOR
SET M=$ORDER(ABMRV(L,J,M))
IF M=""
QUIT
Begin DoDot:3
+11 SET K=K+1
+12 SET ABMA(K,"DOS")=""
+13 SET ABMA(K,"BLSRV")=$PIECE(^DD(9002274.4,I,0),U)
+14 SET ABMA(K,"BLSRV")=$$UPC^ABMERUTL(ABMA(K,"BLSRV"))
+15 SET ABMA(K,"BLSRV")=$TRANSLATE(ABMA(K,"BLSRV"),"*")
+16 SET ABMA(K,"ITCODE")=L
+17 SET ABMA(K,"ITQT")=$PIECE(ABMRV(L,J,M),U,5)
+18 SET ABMA(K,"ITTOT")=$PIECE(ABMRV(L,J,M),U,6)
+19 SET ABMA(K,"ITUC")=ABMA(K,"ITTOT")
+20 ;abm*2.6*8
SET ABMA(K,"LICN")=$PIECE(ABMRV(L,J,M),U,38)
+21 IF I=23
Begin DoDot:4
+22 SET ABMA(K,"OTUC")=ABM(5)
+23 SET ABMA(K,"OTIT")="DISPENSE FEE"
+24 SET ABMA(K,"ITUC")=ABMA(K,"ITTOT")-ABM(5)
+25 ;Medicine code
SET ABMA(K,"ITNM")=$PIECE(ABMRV(L,J,M),U,9)
End DoDot:4
+26 IF I=25
SET ABMA(K,"ITNM")=$PIECE($GET(^AUTTREVN(L,0)),U,2)
+27 IF J]""
IF I'=23
IF I'=33
Begin DoDot:4
+28 NEW ABMJIEN
+29 ;GET NUMERICAL ien
SET ABMJIEN=$ORDER(^ICPT("B",J,""))
+30 ;CSV-c
IF ABMJIEN
SET ABMA(K,"ITNM")=$PIECE($$CPT^ABMCVAPI(ABMJIEN,$PIECE(ABMRV(L,J,M),U,10),ABMP("VDT")),U,3)
QUIT
+31 ;CSV-c
SET ABMA(K,"ITNM")=$PIECE($$CPT^ABMCVAPI(J,$PIECE(ABMRV(L,J,M),U,10),ABMP("VDT")),U,3)
+32 SET ABMA(K,"ITCODE")=J
End DoDot:4
+33 IF J
IF I=33
Begin DoDot:4
+34 SET ABMA(K,"ITCODE")=$PIECE(ABMRV(L,J,M),U,2)
End DoDot:4
+35 IF $PIECE(ABMRV(L,J,M),U,9)'=""
SET ABMA(K,"ITNM")=$PIECE(ABMRV(L,J,M),U,9)
+36 IF $PIECE(ABMRV(L,J,M),U,10)
SET ABMA(K,"DOS")=$PIECE(ABMRV(L,J,M),U,10)
+37 IF '$GET(ABMA(K,"ITQT"))
SET ABMA(K,"ITUC")=0
QUIT
+38 SET ABMA(K,"ITUC")=$JUSTIFY(ABMA(K,"ITUC")/ABMA(K,"ITQT"),1,3)
+39 IF ABMP("ARVERS")'<1.1
Begin DoDot:4
+40 MERGE @ABMA@(K)=ABMA(K)
+41 KILL ABMA(K)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
+44 ; ****************************
CONV2 ;
+1 ;CONVERT INSURER ARRAY
+2 FOR I=1:1:3
Begin DoDot:1
+3 IF '$DATA(ABMP("INS",I))
QUIT
+4 IF ABMA("ACTION")=$SELECT(ABMP("ARVERS")'<1.1
QUIT
+5 IF +ABMP("INS",I)=ABMA("INS")
SET ABMA("ACTION")=I
+6 IF $PIECE($GET(^AUTNINS(+ABMP("INS",I),0)),"^",1)="N"
SET ABMP("INS",I)=""
End DoDot:1
+7 SET ABMA("PRIM")=$PIECE($GET(ABMP("INS",1)),"^",1)
+8 SET ABMA("SEC")=$PIECE($GET(ABMP("INS",2)),"^",1)
+9 SET ABMA("TERT")=$PIECE($GET(ABMP("INS",3)),"^",1)
+10 QUIT
+11 ;
+12 ; *************************
PROV ;
+1 ;GET ATTENDING PROVIDER
+2 SET ABMA("PROV")=""
+3 NEW I
+4 SET I=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0))
+5 NEW J
+6 SET J=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,+I,0)),"^",1)
+7 SET ABMA("PROV")=J
+8 QUIT
+9 ;
+10 ; **********************
TXT ;FIELDS
+1 ;;.01;;BLNM
+2 ;;.03;;VSLC
+3 ;;.05;;PTNM
+4 ;;.07;;VSTP
+5 ;;.08;;INS
+6 ;;.1;;CLNC
+7 ;;.15;;DTAP
+8 ;;.17;;DTBILL
+9 ;;.21;;BLAMT
+10 ;;.29;;LICN
+11 ;;.71;;DOSB
+12 ;;.72;;DOSE
+13 ;;END
+14 ;abm*2.6*8 added .29 field above
+15 ;
+16 ; ********************************
EXT ;EP
+1 ;EXTERNAL CALL (NEEDS DA DEFINED)
+2 SET DIC="^ABMDBILL(DUZ(2),"
+3 SET X="A"
+4 DO START
+5 KILL ABM,ABMP,ABMA,ABME
+6 QUIT
