ABMAPASS.m

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)