IBOHLS1 ;ALB/BAA - IB HELD CHARGES LIST MANAGER ;08-SEP-2015
;;2.0;INTEGRATED BILLING;**554,616,618**;21-MAR-94;Build 61
;Per VA Directive 6402, this routine should not be modified.
;
SORT ; get the data
N CNT,IBN,SINST
S CNT=0
; compile data to display here
I 'PATS D
. S IBN=0 F S IBN=$O(^IB("AC",8,IBN)) Q:'IBN D CHRGS(IBN,PATS)
I PATS D
. S DFN=0 F S DFN=$O(FILTERS(2,DFN)) Q:'DFN D
.. S IBN=0 F S IBN=$O(^IB("AH",DFN,IBN)) Q:'IBN D CHRGS(IBN,PATS)
Q
;
CHRGS(IBN,PATS) ; charges on hold
N IBFR,IBTO,HDAYS,IBND,HINST,DFN,HST,IBACT,IBCHG,ID,SS,SSLE,SSLS,NAME,HLDT,FLAG
N CLINIC,IBND1,RSLTFRM
S SINST=""
S IBND=$G(^IB(IBN,0)) Q:'IBND
S RSLTFRM=$P(IBND,U,4)
S HINST=$$INST(RSLTFRM),CLINIC=$P(HINST,U,2),HINST=$P(HINST,U,1)
S FLAG=""
I HINST="*" S FLAG="*",HINST=$P(IBND,U,13)
I HINST="" S FLAG="*",HINST=$P(IBND,U,13)
I HINST'="" S SINST=$P(^DIC(4,HINST,0),U,1)
I INSTS,HINST="" Q
I INSTS,'$D(FILTERS(1,HINST)) Q
S IBND1=$G(^IB(IBN,1))
S HLDT=$P(IBND1,U,6)
S IBACT=+IBND
S DFN=$P(IBND,U,2)
D PAT
S HST=$P(IBND,U,5)
I HST'=8 Q
S IBFR=$P(IBND,U,14),IBTO=$P(IBND,U,15)
I $P(IBND,U,4)["52:" D
.S IBRXN=$P($P(IBND,U,4),":",2),IBRF=$P($P(IBND,U,4),":",3)
.I +IBRF>0 S IBFR=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01),IBTO=$P($$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,17),".")
.I +IBRF=0 S IBFR=$$FILE^IBRXUTL(+IBRXN,22),IBTO=$P($$FILE^IBRXUTL(+IBRXN,31),".")
I HLDT<BDATE!(HLDT>EDATE) Q
S HDAYS=$$FMDIFF^XLFDT(DT,HLDT,1)
S IBCHG=$P(IBND,U,7)
D BILLS
Q
;
INST(RF) ; figure out where performed
N FL,IEN,IBIEN,DIEN,INT,CLNM,IBSTA
S IBRXN=$P(RF,":",2),INT="*",CLNM=""
S IBIEN=$P(IBRXN,";",1)
S FL=$P(RF,":",1)
;
I FL=350 S INT="*",CLNM=""
;
I FL=45 D
. S IBSTA=$$GET1^DIQ(45,IBIEN_",",3,"I"),CLNM="" ;IB*2*616, 45 file stores Station Number
. D FIND^DIC(4,"","@;.01;IX","X",IBSTA,99,"D","","","MSG") S INT=$G(MSG("DILIST",2,1)) ;Convert Station number to Institution file IEN
;
I FL=52 D
. S IEN=$$GET1^DIQ(52,IBIEN_",",20,"I"),CLNM=$$GET1^DIQ(52,IBIEN_",",20,"E")
. S INT=$$GET1^DIQ(59,IEN_",",100,"I")
;
I FL=405 D
. S IEN=$$GET1^DIQ(405,IBIEN_",",.06,"I"),CLNM=$$GET1^DIQ(405,IBIEN_",",.06,"E")
. S DIEN=$$GET1^DIQ(42,IEN_",",.015,"I")
. S INT=$$GET1^DIQ(40.8,DIEN_",",.07,"I")
;
I FL=409.68 D
. S IEN=$$GET1^DIQ(409.68,IBIEN_",",.04,"I"),CLNM=$$GET1^DIQ(409.68,IBIEN_",",.04,"E")
. S INT=$$GET1^DIQ(44,IEN_",",3,"I")
;
Q INT_U_CLNM
;
;
PAT ; patient name
N VAERR,VADM D DEM^VADPT I VAERR K VADM
S NAME=$G(VADM(1)) S:NAME="" NAME=" "
S SS=$P($G(VADM(2)),U,1),SSLE=$L(SS),SSLS=6 I $E(SS,SSLE)="P" S SSLS=5
S ID=$E(NAME,1)_$E(SS,SSLS,SSLE)
Q
;
BILLS ; find bills for charges on hold
N IBT,IBATYPE,IBCHRG,IBTP
; Look up the type to match to using the Action Type name
S IBATYPE=$$FNDBTYP^IBOHLD1($P(IBND,"^",3)) ;IB*2.0*618
S CNT=CNT+1
; Patch IB*2.0*618 - added community care - action types to HELD CHARGES report
S IBTP=$P(IBND,"^",3),IBTP=$P($G(^IBE(350.1,IBTP,0)),"^",1)
S IBTP=$$IBACTYPE^IBOHLD2(IBTP)
; end of Patch IB*2.0*618
S ^TMP($J,"IBOHLS",NAME,CNT)=NAME_U_ID_U_IBTP_U_IBFR_U_IBTO_U_HDAYS_U_IBCHG
S ^TMP($J,"IBOHLS",NAME,CNT,"IBND")=DFN_U_NAME_U_IBN_U_IBFR_U_IBTO_U_SINST_U_FLAG_U_CLINIC
I IBATYPE="I" D INP
I IBATYPE="O" D OTP
E D RX
I IINS,$D(^TMP($J,"IBOHLS",NAME,CNT)),'$D(^TMP($J,"IBOHLS INS",NAME)) D GETINS
Q
;
INP ; inpatient bills
N IBEV,IBBILL,IBT,X,X1,X2,IBEND,IBOK,IBBCHG,IBBILL0,IBBILLU1,BILL,BCNT,BLTRK,RNB,STATUS
N HLDDT,AUDT,IBTYPE
S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTYPE,0)),"^",1),IBTYPE=$S(IBTYPE["PSO NSC":"RXNSC",IBTYPE["PSO SC":"RX SC",1:$E(IBTYPE,4,7))
S IBEV=$P(IBND,U,16) Q:'IBEV ; parent event
S IBEV=($P($G(^IB(IBEV,0)),U,17)\1) Q:'IBEV ; date of parent event
S X1=IBEV,X2=1 D C^%DTC S IBEND=X
S BCNT=0
S IBT=(IBEV-.0001) F S IBT=$O(^DGCR(399,"D",IBT)) Q:'IBT!(IBT'<IBEND) S IBBILL=0 F S IBBILL=$O(^DGCR(399,"D",IBT,IBBILL)) Q:IBBILL="" D
. S IBBILL0=$G(^DGCR(399,IBBILL,0))
. S BILL=$P(IBBILL0,U,1)
. S AUDT=$$GET1^DIQ(399,IBBILL,10,"I")
. S HLDDT=$S(AUDT'="":$$FMDIFF^XLFDT(DT,AUDT,1),1:HDAYS)
. S IBBCHG=$$GET1^DIQ(430,IBBILL,77)
. S STATUS=$$GET1^DIQ(430,IBBILL,8,"O")
. S (BLTRK,RNB)=""
. S BLTRK=$O(^IBT(356,"E",IBBILL,BLTRK))
. I BLTRK'="" S RNB=$$GET1^DIQ(356,BLTRK,.19,"O")
. D INPTCK
. I IBOK D
.. ;BILL#AR STATUS^DATE BILLED^AUTH DATE^HLD DAYS^CHARGE^RNB^BILL TRK #
.. S BCNT=BCNT+1
.. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)=BILL_U_STATUS_U_IBT_U_AUDT_U_HLDDT_U_IBBCHG_U_RNB_U_BLTRK ;BILL#^AR STATUS^DATE BILLED^CHARGE
.. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT,"B")=IBBILL_U_BLTRK_U_RNB
Q
;
INPTCK ; does bill belong to charge? returns IBOK=0 if no
N IBBILLU
S IBBILLU=$G(^DGCR(399,IBBILL,"U"))
S IBBILL=$P(IBBILL0,U,1)
S IBOK=1
CK1 ; for same patient?
I DFN=$P(IBBILL0,U,2)
S IBOK=$T
Q:'IBOK
CK2 ; same type- inp or opt?
N B S B=$S(+$P(IBBILL0,U,5)<3:"I",1:"O")
I B=IBATYPE S IBOK=1
S IBOK=$T
Q:'IBOK
CK3 ; overlap in date range?
N F,T
S F=+IBBILLU,T=$P(IBBILLU,U,2)
I (IBTO<F)!(IBFR>T)
S IBOK='$T
Q:'IBOK
CK4 ; insurance bill?
I $P(IBBILL0,U,11)="i"
S IBOK=$T
Q
;
OTP ; outpatient bills
N X,IBV,IBBILL,IBOK,IBBILL0,IBBCHG,IBBILLU1,IBBILLU,BILL,BCNT
S BCNT=0
S IBV=(IBFR\1)-.0001 F S IBV=$O(^DGCR(399,"AOPV",DFN,IBV)) Q:'IBV!(IBV>IBTO) S IBBILL=0 D
.F S IBBILL=$O(^DGCR(399,"AOPV",DFN,IBV,IBBILL)) Q:('IBBILL) D
.. S IBBILL0=$G(^DGCR(399,IBBILL,0)),IBBILLU=$G(^DGCR(399,IBBILL,"U")) D CK4 Q:'IBOK
.. S BILL=$P(IBBILL0,U,1)
.. S AUDT=$$GET1^DIQ(399,IBBILL,10,"I")
.. S HLDDT=$S(AUDT'="":$$FMDIFF^XLFDT(DT,AUDT,1),1:HDAYS)
.. S IBBCHG=$$GET1^DIQ(430,IBBILL,77)
.. S STATUS=$$GET1^DIQ(430,IBBILL,8,"O")
.. S (BLTRK,RNB)=""
.. S BLTRK=$O(^IBT(356,"E",IBBILL,BLTRK))
.. I BLTRK'="" S RNB=$$GET1^DIQ(356,BLTRK,.19,"O")
.. S BILL=$P(IBBILL0,U,1),BCNT=BCNT+1
.. S IBBILLU1=$G(^DGCR(399,IBBILL,"U1")),IBBCHG=$P(IBBILLU1,U,1)
.. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)=BILL_U_STATUS_U_IBV_U_AUDT_U_HLDDT_U_IBBCHG_U_RNB_U_BLTRK ;BILL#^AR STATUS^DATE BILLED^AUTH DATE^DAYS ON HOLD^CHARGE^RNB^BILL TRK NO
.. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT,"B")=IBBILL_U_BLTRK
Q
;
RX ; rx refill bills
N IBRDT,IBRF,IBRX,IBRXN,IBTYPE
S (IBRX,IBRXN,IBRF,IBRDT)=0 N IENS
I $P(IBND,U,4)'["52:" Q
;
S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTYPE,0)),"^",1),IBTYPE=$S(IBTYPE["PSO NSC":"RXNSC",IBTYPE["PSO SC":"RX SC",1:$E(IBTYPE,4,7))
S IBRXN=$P($P(IBND,U,4),":",2),IBRX=$P($P(IBND,U,8),"-"),IBRF=$P($P(IBND,U,4),":",3)
S ^TMP($J,"IBOHLS",NAME,CNT,1)=IBRX ;RX VALUE
I +IBRF>0 S IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
I +IBRF=0 S IBRDT=$$FILE^IBRXUTL(+IBRXN,22)
;
Q:(IBRX="")!('IBRDT)
N X,IBBILL,IBBILL0,IBFILL,IBFILL0,IBOK,IBBCHG,BCNT
S BCNT=0
S IBFILL=0 F S IBFILL=$O(^IBA(362.4,"B",IBRX,IBFILL)) Q:IBFILL="" D
. S BCNT=BCNT+1
. S IBFILL0=$G(^IBA(362.4,IBFILL,0)) I $P(IBFILL0,U,3)'=IBRDT Q
. S IBBILL=+$P(IBFILL0,U,2) I 'IBBILL Q
. S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 I 'IBOK Q
. S BILL=$P(IBBILL0,U,1)
. S AUDT=$$GET1^DIQ(399,IBBILL,10,"I")
. S HLDDT=$S(AUDT'="":$$FMDIFF^XLFDT(DT,AUDT,1),1:HDAYS)
. S IBBCHG=$$GET1^DIQ(430,IBBILL,77)
. S STATUS=$$GET1^DIQ(430,IBBILL,8,"O")
. S (BLTRK,RNB)=""
. S BLTRK=$O(^IBT(356,"E",IBBILL,BLTRK))
. I BLTRK'="" S RNB=$$GET1^DIQ(356,BLTRK,.19,"O")
. S BCNT=BCNT+1
. S IBBILLU1=$G(^DGCR(399,IBBILL,"U1")),IBBCHG=$P(IBBILLU1,U,1)
. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)=BILL_U_STATUS_U_IBRDT_U_AUDT_U_HLDDT_U_IBBCHG_U_RNB_U_BLTRK ;BILL#^AR STATUS^DATE BILLED^CHARGE
. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT,"B")=IBBILL_U_BLTRK_U_RNB
Q
;
GETINS ; get insurance information
N XX,IBINS,IBX,ICNT,INSCO,SUBID,PLNID,EFFDT,EFDTCK,EXPDT,EXDTCK,LEDT,SUBNAM,CVD
N PLNCOV,PEFDT,PCOVD,PCOM,PCNT,COVFN,GRP,CKDT,IBCNT
N IBINS0,IBINS7,LIM,INSTYP,IB0,IBS,REIMB
S (PLNCOV,PLNID,PEFDT,PCOVD,PCOM)=""
S ICNT=0
D ALL^IBCNS1(DFN,"IBINS")
S XX=0
F S XX=$O(IBINS(XX)) Q:'XX D
. S IBINS0=IBINS(XX,0)
. S IBINS7=$G(IBINS(XX,7))
. S PLNID=$P(IBINS0,U,18),GRP=$P(IBINS0,U,3)
. I PLNID'="" I $P($G(^IBA(355.3,PLNID,0)),"^",11) Q ;plan is inactive
. S INSCO=$P(^DIC(36,+IBINS0,0),U,1),REIMB=$P(INSCO,U,2)
. I $P(INSCO,U,5) Q ;insurance company inactive
. S SUBID=$P(IBINS7,U,2)
. S SUBNAM=$P(IBINS7,U,1)
. S EXDTCK=+$P(IBINS0,U,4)
. S EFDTCK=+$P(IBINS0,U,8)
. I EXDTCK,EXDTCK<IBFR Q ; if insurance expired before the from date of copay quit
. I EFDTCK,EFDTCK>IBTO Q ; if insurance not in effect for period quit
. S EFFDT=$$DAT1^IBOUTL(EFDTCK)
. S EXPDT=$$DAT1^IBOUTL(EXDTCK)
. S ICNT=ICNT+1
. ;ins co^sub id^plan id^effective dt^expiration date
. S ^TMP($J,"IBOHLS",NAME,CNT,3,ICNT)=IBINS0_U_PLNID
. S ^TMP($J,"IBOHLS INS",NAME,ICNT)=INSCO_U_SUBNAM_U_GRP_U_EFFDT_U_EXPDT
. ;plan coverage^effective date^covered?^limit comments
. S LIM=0,PCNT=0
. F S LIM=$O(^IBE(355.31,LIM)) Q:'LIM D
.. S PLNCOV=$P($G(^IBE(355.31,LIM,0)),U),IBCNT=0,PEFDT=""
.. S PCOVD="",LEDT="",PCOM=""
.. F S LEDT=$O(^IBA(355.32,"APCD",PLNID,LIM,LEDT)) Q:$S(LEDT="":IBCNT,1:0) D Q:LEDT=""
... S COVFN=+$O(^IBA(355.32,"APCD",PLNID,LIM,+LEDT,"")),PCOVD=$G(^IBA(355.32,+COVFN,0))
... S PEFDT=$$DAT1^IBOUTL($P(LEDT,"-",2))
... I PCOVD="" S PCOVD="BY DEFAULT" D SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT) Q
... S IBCNT=IBCNT+1,PCOM=""
... I PCOVD'="" S CVD=$P(PCOVD,U,4),PCOVD=$S(CVD:$S(CVD<2:"YES",CVD=2:"CONDITIONAL",1:"UNKNOWN"),1:"NO")
... I '$O(^IBA(355.32,COVFN,2,0)) D SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT) Q
... S (IBS,IB0)=0 F S IB0=$O(^IBA(355.32,COVFN,2,IB0)) Q:'IB0 D
.... S PCOM=""
.... S PCOM=^IBA(355.32,COVFN,2,IB0,0)
.... I IBS=0 D SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT)
.... I IBS>0 D SETCOV(PCOM)
.... S IBS=IBS+1
Q
;
SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT) ; SET GLOBAL ENTRY
S PCNT=PCNT+1
I IBCNT>1 S PLNCOV=""
S ^TMP($J,"IBOHLS",NAME,CNT,3,ICNT,PCNT)=""
S ^TMP($J,"IBOHLS INS",NAME,ICNT,0)=IBINS0_U_PLNID
S ^TMP($J,"IBOHLS INS",NAME,ICNT,PCNT)=PLNCOV_U_PEFDT_U_PCOVD_U_PCOM
Q
;
SETCOV(PCOM) ; SET COVERAGE WHEN MULTIPLE
S PCNT=PCNT+1
S ^TMP($J,"IBOHLS INS",NAME,ICNT,PCNT)=""_U_""_U_""_U_PCOM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOHLS1 10242 printed Sep 23, 2025@20:01:58 Page 2
IBOHLS1 ;ALB/BAA - IB HELD CHARGES LIST MANAGER ;08-SEP-2015
+1 ;;2.0;INTEGRATED BILLING;**554,616,618**;21-MAR-94;Build 61
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
SORT ; get the data
+1 NEW CNT,IBN,SINST
+2 SET CNT=0
+3 ; compile data to display here
+4 IF 'PATS
Begin DoDot:1
+5 SET IBN=0
FOR
SET IBN=$ORDER(^IB("AC",8,IBN))
if 'IBN
QUIT
DO CHRGS(IBN,PATS)
End DoDot:1
+6 IF PATS
Begin DoDot:1
+7 SET DFN=0
FOR
SET DFN=$ORDER(FILTERS(2,DFN))
if 'DFN
QUIT
Begin DoDot:2
+8 SET IBN=0
FOR
SET IBN=$ORDER(^IB("AH",DFN,IBN))
if 'IBN
QUIT
DO CHRGS(IBN,PATS)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
CHRGS(IBN,PATS) ; charges on hold
+1 NEW IBFR,IBTO,HDAYS,IBND,HINST,DFN,HST,IBACT,IBCHG,ID,SS,SSLE,SSLS,NAME,HLDT,FLAG
+2 NEW CLINIC,IBND1,RSLTFRM
+3 SET SINST=""
+4 SET IBND=$GET(^IB(IBN,0))
if 'IBND
QUIT
+5 SET RSLTFRM=$PIECE(IBND,U,4)
+6 SET HINST=$$INST(RSLTFRM)
SET CLINIC=$PIECE(HINST,U,2)
SET HINST=$PIECE(HINST,U,1)
+7 SET FLAG=""
+8 IF HINST="*"
SET FLAG="*"
SET HINST=$PIECE(IBND,U,13)
+9 IF HINST=""
SET FLAG="*"
SET HINST=$PIECE(IBND,U,13)
+10 IF HINST'=""
SET SINST=$PIECE(^DIC(4,HINST,0),U,1)
+11 IF INSTS
IF HINST=""
QUIT
+12 IF INSTS
IF '$DATA(FILTERS(1,HINST))
QUIT
+13 SET IBND1=$GET(^IB(IBN,1))
+14 SET HLDT=$PIECE(IBND1,U,6)
+15 SET IBACT=+IBND
+16 SET DFN=$PIECE(IBND,U,2)
+17 DO PAT
+18 SET HST=$PIECE(IBND,U,5)
+19 IF HST'=8
QUIT
+20 SET IBFR=$PIECE(IBND,U,14)
SET IBTO=$PIECE(IBND,U,15)
+21 IF $PIECE(IBND,U,4)["52:"
Begin DoDot:1
+22 SET IBRXN=$PIECE($PIECE(IBND,U,4),":",2)
SET IBRF=$PIECE($PIECE(IBND,U,4),":",3)
+23 IF +IBRF>0
SET IBFR=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
SET IBTO=$PIECE($$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,17),".")
+24 IF +IBRF=0
SET IBFR=$$FILE^IBRXUTL(+IBRXN,22)
SET IBTO=$PIECE($$FILE^IBRXUTL(+IBRXN,31),".")
End DoDot:1
+25 IF HLDT<BDATE!(HLDT>EDATE)
QUIT
+26 SET HDAYS=$$FMDIFF^XLFDT(DT,HLDT,1)
+27 SET IBCHG=$PIECE(IBND,U,7)
+28 DO BILLS
+29 QUIT
+30 ;
INST(RF) ; figure out where performed
+1 NEW FL,IEN,IBIEN,DIEN,INT,CLNM,IBSTA
+2 SET IBRXN=$PIECE(RF,":",2)
SET INT="*"
SET CLNM=""
+3 SET IBIEN=$PIECE(IBRXN,";",1)
+4 SET FL=$PIECE(RF,":",1)
+5 ;
+6 IF FL=350
SET INT="*"
SET CLNM=""
+7 ;
+8 IF FL=45
Begin DoDot:1
+9 ;IB*2*616, 45 file stores Station Number
SET IBSTA=$$GET1^DIQ(45,IBIEN_",",3,"I")
SET CLNM=""
+10 ;Convert Station number to Institution file IEN
DO FIND^DIC(4,"","@;.01;IX","X",IBSTA,99,"D","","","MSG")
SET INT=$GET(MSG("DILIST",2,1))
End DoDot:1
+11 ;
+12 IF FL=52
Begin DoDot:1
+13 SET IEN=$$GET1^DIQ(52,IBIEN_",",20,"I")
SET CLNM=$$GET1^DIQ(52,IBIEN_",",20,"E")
+14 SET INT=$$GET1^DIQ(59,IEN_",",100,"I")
End DoDot:1
+15 ;
+16 IF FL=405
Begin DoDot:1
+17 SET IEN=$$GET1^DIQ(405,IBIEN_",",.06,"I")
SET CLNM=$$GET1^DIQ(405,IBIEN_",",.06,"E")
+18 SET DIEN=$$GET1^DIQ(42,IEN_",",.015,"I")
+19 SET INT=$$GET1^DIQ(40.8,DIEN_",",.07,"I")
End DoDot:1
+20 ;
+21 IF FL=409.68
Begin DoDot:1
+22 SET IEN=$$GET1^DIQ(409.68,IBIEN_",",.04,"I")
SET CLNM=$$GET1^DIQ(409.68,IBIEN_",",.04,"E")
+23 SET INT=$$GET1^DIQ(44,IEN_",",3,"I")
End DoDot:1
+24 ;
+25 QUIT INT_U_CLNM
+26 ;
+27 ;
PAT ; patient name
+1 NEW VAERR,VADM
DO DEM^VADPT
IF VAERR
KILL VADM
+2 SET NAME=$GET(VADM(1))
if NAME=""
SET NAME=" "
+3 SET SS=$PIECE($GET(VADM(2)),U,1)
SET SSLE=$LENGTH(SS)
SET SSLS=6
IF $EXTRACT(SS,SSLE)="P"
SET SSLS=5
+4 SET ID=$EXTRACT(NAME,1)_$EXTRACT(SS,SSLS,SSLE)
+5 QUIT
+6 ;
BILLS ; find bills for charges on hold
+1 NEW IBT,IBATYPE,IBCHRG,IBTP
+2 ; Look up the type to match to using the Action Type name
+3 ;IB*2.0*618
SET IBATYPE=$$FNDBTYP^IBOHLD1($PIECE(IBND,"^",3))
+4 SET CNT=CNT+1
+5 ; Patch IB*2.0*618 - added community care - action types to HELD CHARGES report
+6 SET IBTP=$PIECE(IBND,"^",3)
SET IBTP=$PIECE($GET(^IBE(350.1,IBTP,0)),"^",1)
+7 SET IBTP=$$IBACTYPE^IBOHLD2(IBTP)
+8 ; end of Patch IB*2.0*618
+9 SET ^TMP($JOB,"IBOHLS",NAME,CNT)=NAME_U_ID_U_IBTP_U_IBFR_U_IBTO_U_HDAYS_U_IBCHG
+10 SET ^TMP($JOB,"IBOHLS",NAME,CNT,"IBND")=DFN_U_NAME_U_IBN_U_IBFR_U_IBTO_U_SINST_U_FLAG_U_CLINIC
+11 IF IBATYPE="I"
DO INP
+12 IF IBATYPE="O"
DO OTP
+13 IF '$TEST
DO RX
+14 IF IINS
IF $DATA(^TMP($JOB,"IBOHLS",NAME,CNT))
IF '$DATA(^TMP($JOB,"IBOHLS INS",NAME))
DO GETINS
+15 QUIT
+16 ;
INP ; inpatient bills
+1 NEW IBEV,IBBILL,IBT,X,X1,X2,IBEND,IBOK,IBBCHG,IBBILL0,IBBILLU1,BILL,BCNT,BLTRK,RNB,STATUS
+2 NEW HLDDT,AUDT,IBTYPE
+3 SET IBTYPE=$PIECE(IBND,"^",3)
SET IBTYPE=$PIECE($GET(^IBE(350.1,IBTYPE,0)),"^",1)
SET IBTYPE=$SELECT(IBTYPE["PSO NSC":"RXNSC",IBTYPE["PSO SC":"RX SC",1:$EXTRACT(IBTYPE,4,7))
+4 ; parent event
SET IBEV=$PIECE(IBND,U,16)
if 'IBEV
QUIT
+5 ; date of parent event
SET IBEV=($PIECE($GET(^IB(IBEV,0)),U,17)\1)
if 'IBEV
QUIT
+6 SET X1=IBEV
SET X2=1
DO C^%DTC
SET IBEND=X
+7 SET BCNT=0
+8 SET IBT=(IBEV-.0001)
FOR
SET IBT=$ORDER(^DGCR(399,"D",IBT))
if 'IBT!(IBT'<IBEND)
QUIT
SET IBBILL=0
FOR
SET IBBILL=$ORDER(^DGCR(399,"D",IBT,IBBILL))
if IBBILL=""
QUIT
Begin DoDot:1
+9 SET IBBILL0=$GET(^DGCR(399,IBBILL,0))
+10 SET BILL=$PIECE(IBBILL0,U,1)
+11 SET AUDT=$$GET1^DIQ(399,IBBILL,10,"I")
+12 SET HLDDT=$SELECT(AUDT'="":$$FMDIFF^XLFDT(DT,AUDT,1),1:HDAYS)
+13 SET IBBCHG=$$GET1^DIQ(430,IBBILL,77)
+14 SET STATUS=$$GET1^DIQ(430,IBBILL,8,"O")
+15 SET (BLTRK,RNB)=""
+16 SET BLTRK=$ORDER(^IBT(356,"E",IBBILL,BLTRK))
+17 IF BLTRK'=""
SET RNB=$$GET1^DIQ(356,BLTRK,.19,"O")
+18 DO INPTCK
+19 IF IBOK
Begin DoDot:2
+20 ;BILL#AR STATUS^DATE BILLED^AUTH DATE^HLD DAYS^CHARGE^RNB^BILL TRK #
+21 SET BCNT=BCNT+1
+22 ;BILL#^AR STATUS^DATE BILLED^CHARGE
SET ^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT)=BILL_U_STATUS_U_IBT_U_AUDT_U_HLDDT_U_IBBCHG_U_RNB_U_BLTRK
+23 SET ^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT,"B")=IBBILL_U_BLTRK_U_RNB
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
INPTCK ; does bill belong to charge? returns IBOK=0 if no
+1 NEW IBBILLU
+2 SET IBBILLU=$GET(^DGCR(399,IBBILL,"U"))
+3 SET IBBILL=$PIECE(IBBILL0,U,1)
+4 SET IBOK=1
CK1 ; for same patient?
+1 IF DFN=$PIECE(IBBILL0,U,2)
+2 SET IBOK=$TEST
+3 if 'IBOK
QUIT
CK2 ; same type- inp or opt?
+1 NEW B
SET B=$SELECT(+$PIECE(IBBILL0,U,5)<3:"I",1:"O")
+2 IF B=IBATYPE
SET IBOK=1
+3 SET IBOK=$TEST
+4 if 'IBOK
QUIT
CK3 ; overlap in date range?
+1 NEW F,T
+2 SET F=+IBBILLU
SET T=$PIECE(IBBILLU,U,2)
+3 IF (IBTO<F)!(IBFR>T)
+4 SET IBOK='$TEST
+5 if 'IBOK
QUIT
CK4 ; insurance bill?
+1 IF $PIECE(IBBILL0,U,11)="i"
+2 SET IBOK=$TEST
+3 QUIT
+4 ;
OTP ; outpatient bills
+1 NEW X,IBV,IBBILL,IBOK,IBBILL0,IBBCHG,IBBILLU1,IBBILLU,BILL,BCNT
+2 SET BCNT=0
+3 SET IBV=(IBFR\1)-.0001
FOR
SET IBV=$ORDER(^DGCR(399,"AOPV",DFN,IBV))
if 'IBV!(IBV>IBTO)
QUIT
SET IBBILL=0
Begin DoDot:1
+4 FOR
SET IBBILL=$ORDER(^DGCR(399,"AOPV",DFN,IBV,IBBILL))
if ('IBBILL)
QUIT
Begin DoDot:2
+5 SET IBBILL0=$GET(^DGCR(399,IBBILL,0))
SET IBBILLU=$GET(^DGCR(399,IBBILL,"U"))
DO CK4
if 'IBOK
QUIT
+6 SET BILL=$PIECE(IBBILL0,U,1)
+7 SET AUDT=$$GET1^DIQ(399,IBBILL,10,"I")
+8 SET HLDDT=$SELECT(AUDT'="":$$FMDIFF^XLFDT(DT,AUDT,1),1:HDAYS)
+9 SET IBBCHG=$$GET1^DIQ(430,IBBILL,77)
+10 SET STATUS=$$GET1^DIQ(430,IBBILL,8,"O")
+11 SET (BLTRK,RNB)=""
+12 SET BLTRK=$ORDER(^IBT(356,"E",IBBILL,BLTRK))
+13 IF BLTRK'=""
SET RNB=$$GET1^DIQ(356,BLTRK,.19,"O")
+14 SET BILL=$PIECE(IBBILL0,U,1)
SET BCNT=BCNT+1
+15 SET IBBILLU1=$GET(^DGCR(399,IBBILL,"U1"))
SET IBBCHG=$PIECE(IBBILLU1,U,1)
+16 ;BILL#^AR STATUS^DATE BILLED^AUTH DATE^DAYS ON HOLD^CHARGE^RNB^BILL TRK NO
SET ^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT)=BILL_U_STATUS_U_IBV_U_AUDT_U_HLDDT_U_IBBCHG_U_RNB_U_BLTRK
+17 SET ^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT,"B")=IBBILL_U_BLTRK
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
RX ; rx refill bills
+1 NEW IBRDT,IBRF,IBRX,IBRXN,IBTYPE
+2 SET (IBRX,IBRXN,IBRF,IBRDT)=0
NEW IENS
+3 IF $PIECE(IBND,U,4)'["52:"
QUIT
+4 ;
+5 SET IBTYPE=$PIECE(IBND,"^",3)
SET IBTYPE=$PIECE($GET(^IBE(350.1,IBTYPE,0)),"^",1)
SET IBTYPE=$SELECT(IBTYPE["PSO NSC":"RXNSC",IBTYPE["PSO SC":"RX SC",1:$EXTRACT(IBTYPE,4,7))
+6 SET IBRXN=$PIECE($PIECE(IBND,U,4),":",2)
SET IBRX=$PIECE($PIECE(IBND,U,8),"-")
SET IBRF=$PIECE($PIECE(IBND,U,4),":",3)
+7 ;RX VALUE
SET ^TMP($JOB,"IBOHLS",NAME,CNT,1)=IBRX
+8 IF +IBRF>0
SET IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
+9 IF +IBRF=0
SET IBRDT=$$FILE^IBRXUTL(+IBRXN,22)
+10 ;
+11 if (IBRX="")!('IBRDT)
QUIT
+12 NEW X,IBBILL,IBBILL0,IBFILL,IBFILL0,IBOK,IBBCHG,BCNT
+13 SET BCNT=0
+14 SET IBFILL=0
FOR
SET IBFILL=$ORDER(^IBA(362.4,"B",IBRX,IBFILL))
if IBFILL=""
QUIT
Begin DoDot:1
+15 SET BCNT=BCNT+1
+16 SET IBFILL0=$GET(^IBA(362.4,IBFILL,0))
IF $PIECE(IBFILL0,U,3)'=IBRDT
QUIT
+17 SET IBBILL=+$PIECE(IBFILL0,U,2)
IF 'IBBILL
QUIT
+18 SET IBBILL0=$GET(^DGCR(399,IBBILL,0))
DO CK4
IF 'IBOK
QUIT
+19 SET BILL=$PIECE(IBBILL0,U,1)
+20 SET AUDT=$$GET1^DIQ(399,IBBILL,10,"I")
+21 SET HLDDT=$SELECT(AUDT'="":$$FMDIFF^XLFDT(DT,AUDT,1),1:HDAYS)
+22 SET IBBCHG=$$GET1^DIQ(430,IBBILL,77)
+23 SET STATUS=$$GET1^DIQ(430,IBBILL,8,"O")
+24 SET (BLTRK,RNB)=""
+25 SET BLTRK=$ORDER(^IBT(356,"E",IBBILL,BLTRK))
+26 IF BLTRK'=""
SET RNB=$$GET1^DIQ(356,BLTRK,.19,"O")
+27 SET BCNT=BCNT+1
+28 SET IBBILLU1=$GET(^DGCR(399,IBBILL,"U1"))
SET IBBCHG=$PIECE(IBBILLU1,U,1)
+29 ;BILL#^AR STATUS^DATE BILLED^CHARGE
SET ^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT)=BILL_U_STATUS_U_IBRDT_U_AUDT_U_HLDDT_U_IBBCHG_U_RNB_U_BLTRK
+30 SET ^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT,"B")=IBBILL_U_BLTRK_U_RNB
End DoDot:1
+31 QUIT
+32 ;
GETINS ; get insurance information
+1 NEW XX,IBINS,IBX,ICNT,INSCO,SUBID,PLNID,EFFDT,EFDTCK,EXPDT,EXDTCK,LEDT,SUBNAM,CVD
+2 NEW PLNCOV,PEFDT,PCOVD,PCOM,PCNT,COVFN,GRP,CKDT,IBCNT
+3 NEW IBINS0,IBINS7,LIM,INSTYP,IB0,IBS,REIMB
+4 SET (PLNCOV,PLNID,PEFDT,PCOVD,PCOM)=""
+5 SET ICNT=0
+6 DO ALL^IBCNS1(DFN,"IBINS")
+7 SET XX=0
+8 FOR
SET XX=$ORDER(IBINS(XX))
if 'XX
QUIT
Begin DoDot:1
+9 SET IBINS0=IBINS(XX,0)
+10 SET IBINS7=$GET(IBINS(XX,7))
+11 SET PLNID=$PIECE(IBINS0,U,18)
SET GRP=$PIECE(IBINS0,U,3)
+12 ;plan is inactive
IF PLNID'=""
IF $PIECE($GET(^IBA(355.3,PLNID,0)),"^",11)
QUIT
+13 SET INSCO=$PIECE(^DIC(36,+IBINS0,0),U,1)
SET REIMB=$PIECE(INSCO,U,2)
+14 ;insurance company inactive
IF $PIECE(INSCO,U,5)
QUIT
+15 SET SUBID=$PIECE(IBINS7,U,2)
+16 SET SUBNAM=$PIECE(IBINS7,U,1)
+17 SET EXDTCK=+$PIECE(IBINS0,U,4)
+18 SET EFDTCK=+$PIECE(IBINS0,U,8)
+19 ; if insurance expired before the from date of copay quit
IF EXDTCK
IF EXDTCK<IBFR
QUIT
+20 ; if insurance not in effect for period quit
IF EFDTCK
IF EFDTCK>IBTO
QUIT
+21 SET EFFDT=$$DAT1^IBOUTL(EFDTCK)
+22 SET EXPDT=$$DAT1^IBOUTL(EXDTCK)
+23 SET ICNT=ICNT+1
+24 ;ins co^sub id^plan id^effective dt^expiration date
+25 SET ^TMP($JOB,"IBOHLS",NAME,CNT,3,ICNT)=IBINS0_U_PLNID
+26 SET ^TMP($JOB,"IBOHLS INS",NAME,ICNT)=INSCO_U_SUBNAM_U_GRP_U_EFFDT_U_EXPDT
+27 ;plan coverage^effective date^covered?^limit comments
+28 SET LIM=0
SET PCNT=0
+29 FOR
SET LIM=$ORDER(^IBE(355.31,LIM))
if 'LIM
QUIT
Begin DoDot:2
+30 SET PLNCOV=$PIECE($GET(^IBE(355.31,LIM,0)),U)
SET IBCNT=0
SET PEFDT=""
+31 SET PCOVD=""
SET LEDT=""
SET PCOM=""
+32 FOR
SET LEDT=$ORDER(^IBA(355.32,"APCD",PLNID,LIM,LEDT))
if $SELECT(LEDT=""
QUIT
Begin DoDot:3
+33 SET COVFN=+$ORDER(^IBA(355.32,"APCD",PLNID,LIM,+LEDT,""))
SET PCOVD=$GET(^IBA(355.32,+COVFN,0))
+34 SET PEFDT=$$DAT1^IBOUTL($PIECE(LEDT,"-",2))
+35 IF PCOVD=""
SET PCOVD="BY DEFAULT"
DO SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT)
QUIT
+36 SET IBCNT=IBCNT+1
SET PCOM=""
+37 IF PCOVD'=""
SET CVD=$PIECE(PCOVD,U,4)
SET PCOVD=$SELECT(CVD:$SELECT(CVD<2:"YES",CVD=2:"CONDITIONAL",1:"UNKNOWN"),1:"NO")
+38 IF '$ORDER(^IBA(355.32,COVFN,2,0))
DO SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT)
QUIT
+39 SET (IBS,IB0)=0
FOR
SET IB0=$ORDER(^IBA(355.32,COVFN,2,IB0))
if 'IB0
QUIT
Begin DoDot:4
+40 SET PCOM=""
+41 SET PCOM=^IBA(355.32,COVFN,2,IB0,0)
+42 IF IBS=0
DO SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT)
+43 IF IBS>0
DO SETCOV(PCOM)
+44 SET IBS=IBS+1
End DoDot:4
End DoDot:3
if LEDT=""
QUIT
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT) ; SET GLOBAL ENTRY
+1 SET PCNT=PCNT+1
+2 IF IBCNT>1
SET PLNCOV=""
+3 SET ^TMP($JOB,"IBOHLS",NAME,CNT,3,ICNT,PCNT)=""
+4 SET ^TMP($JOB,"IBOHLS INS",NAME,ICNT,0)=IBINS0_U_PLNID
+5 SET ^TMP($JOB,"IBOHLS INS",NAME,ICNT,PCNT)=PLNCOV_U_PEFDT_U_PCOVD_U_PCOM
+6 QUIT
+7 ;
SETCOV(PCOM) ; SET COVERAGE WHEN MULTIPLE
+1 SET PCNT=PCNT+1
+2 SET ^TMP($JOB,"IBOHLS INS",NAME,ICNT,PCNT)=""_U_""_U_""_U_PCOM
+3 QUIT
