IBOHLS1.m

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 ---IBOHLS1   10242     printed  Apr 23, 2025@18:40:15                                                                                                                                                                                                    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)