RCXVUTIL ;DAOU/ALA - AR Data Extract Utility Program ;29-JUL-03
;;4.5;Accounts Receivable;**201,299,308,356**;Mar 20, 1995;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;
SPAR(REF) ; HL7 Segment Parsing
; Input Parameter
; REF = Array or global reference
; Global or array should end with ')'
; e.g. ^TMP($J,"XXX",#)
;
; Output Parameters
; RCXSEG(#) = Each sequence of the segment in the array
;
NEW ISCT,II,IJ,IK,ISDATA,ISPEC,ISBEG,ISEND,IS,LSDATA,IM,NPC
;
S ISCT="",II=0,IS=0
F S ISCT=$O(@REF@(ISCT)) Q:ISCT="" D
. S IS=IS+1
. S ISDATA(IS)=$G(@REF@(ISCT))
. I $O(@REF@(ISCT))="" S ISDATA(IS)=ISDATA(IS)_HLFS
. S ISPEC(IS)=$L(ISDATA(IS),HLFS)
;
S IM=0,LSDATA=""
LP S IM=IM+1 Q:IM>IS
S LSDATA=LSDATA_ISDATA(IM),NPC=ISPEC(IM)
F IJ=1:1:NPC-1 D
. S II=II+1,RCXSEG(II)=$$CLNSTR($P(LSDATA,HLFS,IJ),HL("ECH"),$E(HL("ECH")))
S LSDATA=$P(LSDATA,HLFS,NPC)
G LP
;
CLNSTR(STRING,CHARS,SUBSEP) ; Remove extra trailing components and subcomponents
; in the HL7 segment
;
; Input parameters
; STRING - The data value to be 'cleansed'
; CHARS - The component character to be removed
; SUSEP - The subcomponent character to be removed
;
N RTSTRING,NUMPEC,PEC
S RTSTRING=$$RTRIMCH(STRING,CHARS)
; Now we have string without trailing chars, remove from subs
S NUMPEC=$L(RTSTRING,SUBSEP)
F PEC=1:1:NUMPEC S $P(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($P(RTSTRING,SUBSEP,PEC),CHARS)
Q RTSTRING
;
RTRIMCH(STR,CHRS) ; Remove the trailing chars from string
N R,L
S L=1,CHRS=$G(CHRS," ")
F R=$L(STR):-1:1 Q:CHRS'[$E(STR,R)
I L=R,(CHRS[$E(STR)) S STR=""
Q $E(STR,L,R)
;
DFP(IBN) ; Date of First Payment Function
; Input Parameter
; IBN = IEN of the bill number from file 430
;
N VAL,IBPAY,IBT,IBT0,IBT1
S VAL=0
; No payments made.
I '$P($G(^PRCA(430,IBN,7)),U,7) Q ""
S (IBPAY,IBT)=0 F S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT D Q:IBPAY
. S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1))
. I $P(IBT0,U,4)'=2 Q ; Not complete.
. I $P(IBT1,U,2)'=2,$P(IBT1,U,2)'=34 Q ; Not a payment.
. S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1
Q $P(VAL,U,4)
;
DATE(X) ; Pass in External Date and get FileMan date format
;
; Input Parameter
; X = a date in any regular date format
; Output Parameter
; Y = a date in FileMan format
; Parameters
; DIC(0) = FileMan date parameter
;
I X["@" S %DT="T"
I $G(DIC(0))="" S DIC(0)=""
D ^%DT
I Y=-1 S Y=""
K DIC,%DT
Q Y
;
TASK(RCDSC) ; Check on Task Status
;
; Input Parameter
; RCDSC = Task Description
;
NEW RTASKS,RTSK,ZTSK,ZTKEY
D DESC^%ZTLOAD(RCDSC,"RTASKS")
S RTSK=""
F S RTSK=$O(RTASKS(RTSK)) Q:RTSK="" D
. S ZTSK=RTSK D STAT^%ZTLOAD
;
K RTASKS
I $G(ZTSK(2))="Inactive: Finished" Q 0
I $G(ZTSK(2))="Inactive: Interrupted" Q 0
I $G(ZTSK(2))="Active: Pending" Q 1
Q 0
;
SAT(RDATE) ; Find the next Saturday date from the passed in date
NEW CDOW,FDATE,NDAYS
S CDOW=$$DOW^XLFDT(RDATE,1),NDAYS=6-CDOW
I NDAYS=0 S NDAYS=7
S FDATE=$$FMADD^XLFDT(RDATE,NDAYS)
Q FDATE
;
CARE(RCXVIEN) ; Is bill VA or NON-VA care?
;
; Input parameter
; RCXVIEN = Bill ien
;
; Output parameter
; RCXVCFL = Care Flag
; 0 = Non-VA Care
; 1 = VA Care
; *308 phase II criteria for inpatient and outpatient
; -Non-VA care if op visit in 9000010/.22 & stop code=669 in /.08
; -VA care if the bill # with prosthetic item is found in 362.5
; -VA care if rate type'=REIMBURSABLE INS or none of types below:
; FEE;FEE BASIS;FEE-INPT;NON VA CARE;NON-VA;NON-VA FEE BASIS CARE
; -VA care if item type=RX in 399.042/.1 & charge item found in 362.4
; -Non-VA care if item type=RX in 399.042/.1 & charge item not found
; -Non-VA care if op visit in 9000010/.22 matching to any below:
; NVCC;NVC;VCL;NON-VA CARE;NONVA CARE;NONCOUNT FEE;FEE BASIS
; -VA care if op vist in 9000010/.22 not matching to any above
; -Non-VA care if no encounter on op visit date(s) is found in 409.68
; -VA care if the bill not meet above criteria
;
; *299 criteria for inpatient and outpatient
; -Non-VA care if bill classification is inpt/(med. part A) & no ptf #.
; -Non-VA care if ptf # & discharge dt are not null and ward is null.
; -VA care if ptf # & discharge dt are not null and ward is not null.
; -Non-VA care if ptf # & fee basis are not null, otherwise VA care.
; -VA care if at least one assoc. opt encounter is not a NON-COUNT (12)
; encounter, otherwise Non-VA care.
; -VA care or Non-VA care in the final indicator is determined based on
; the opt encounter criteria if the flow reaches it.
;
N RCXVCARE,RCXVRATE,RCXVODT,RPTF
N RCIBX,RCIBY,RCTY,RCTYPE,RCTMP,RCIBRX
;
; if visit has hospital location & stop code 669, it's non-va care
N RCDAT,RCDFN,RCXTMP S (RCDAT,RCTYPE)=0
S RCDFN=$P($G(^DGCR(399,RCXVIEN,0)),U,2)
; if no date then check yymm only
S RCTY="N RCIBX S RCIBX=$P($P($G(^(0)),U),""."") S:'+$E(RCDAT,6,7) RCIBX=$E(RCIBX,1,5) I RCIBX=RCDAT"
F S RCDAT=$O(^DGCR(399,RCXVIEN,"OP",RCDAT)) Q:'RCDAT D Q:RCTYPE
. K RCXTMP D FIND^DIC(9000010,,"@;.01I","QPX",RCDFN,,"C",RCTY,,"RCXTMP")
. S RCIBX=0 F S RCIBX=$O(RCXTMP("DILIST",RCIBX)) Q:'RCIBX D Q:RCTYPE
.. S RCIBY=$$GET1^DIQ(9000010,+RCXTMP("DILIST",RCIBX,0),.22) Q:RCIBY=""
.. S RCIBY=$$GET1^DIQ(9000010,+RCXTMP("DILIST",RCIBX,0),.08,"I") Q:RCIBY=""
.. I +$P($G(^DIC(40.7,+RCIBY,0)),U,2)=669 S RCTYPE=1 Q
I RCTYPE S RCXVCFL=0 Q
;
; if the bill # with prosthetics item in file 362.5, it's va care
S RCIBRX="AIFN"_RCXVIEN
I $D(^IBA(362.5,RCIBRX)) S RCXVCFL=1 Q
;
; if not Reimbursable Insurance & not fee basis, it's va care
S RCTYPE=0
S RCIBX=+$P($G(^DGCR(399,RCXVIEN,0)),U,7)
S RCXVRATE=$P($G(^DGCR(399.3,RCIBX,0)),U)
I $F(",FEE,FEE BASIS,FEE-INPT,NON VA CARE,NON-VA,NON-VA CARE,NON-VA FEE BASIS CARE,",","_RCXVRATE_",") S RCTYPE=1
I 'RCTYPE,RCXVRATE'="REIMBURSABLE INS." S RCXVCFL=1 Q
;
; non-va discharge date
I $P($G(^DGCR(399,RCXVIEN,0)),U,16)'="" S RCXVCFL=0 Q
;
; non-va facility, non-va care type, non-va care id
S RCXVCARE=$G(^DGCR(399,RCXVIEN,"U2"))
I $P(RCXVCARE,U,10)'="" S RCXVCFL=0 Q
I $P(RCXVCARE,U,11)'="" S RCXVCFL=0 Q
I $P(RCXVCARE,U,12)'="" S RCXVCFL=0 Q
;
; Prescription item charge in file 362.4
S (RCIBX,RCTYPE)=0,RCIBRX="AIFN"_RCXVIEN
; DBIA#3811
K RCTMP D RCITEM^IBCSC5A(RCXVIEN,"RCTMP",3)
F S RCIBX=$O(^IBA(362.4,RCIBRX,RCIBX)) Q:'RCIBX S RCIBY=0 D Q:'RCTYPE
. F S RCIBY=$O(^IBA(362.4,RCIBRX,RCIBX,RCIBY)) Q:'RCIBY D Q:'RCTYPE
.. I $$IBCHG(RCIBY,3,.RCTMP)'="" S RCTYPE=1 Q
; no item and no charge, then continue to check
I $O(RCTMP(3,""))'="" S RCXVCFL=0 Q
I RCTYPE S RCXVCFL=1 Q
;
; Check inpatient
; -ptf entry number (#399/.08) & bill classification (#399/.05)
S RPTF=$P($G(^DGCR(399,RCXVIEN,0)),U,8)
I $P($G(^DGCR(399,RCXVIEN,0)),U,5)=1,RPTF="" S RCXVCFL=0 Q
;
; -discharge date (#45/70) and ward at discharge (#45/2.2)
; -fee basis (#45/4) exits, it's non-va care
; DBIA#6030
I RPTF'="" D Q
. I $P($G(^DGPT(RPTF,70)),U,1)'="" D Q
.. N X S X="" D PTF^DGPMUTL(RPTF)
.. I X="" S RCXVCFL=0 Q
.. S RCXVCFL=1
. I $P($G(^DGPT(RPTF,0)),U,4)=1 S RCXVCFL=0 Q
. S RCXVCFL=1
;
; If at least bedsection=non-va care, it's non-va care
S (RCIBX,RCTYPE)=0
F S RCIBX=$O(^DGCR(399,RCXVIEN,"RC",RCIBX)) Q:'RCIBX D Q:RCTYPE
. S RCIBY=$P($G(^DGCR(399,RCXVIEN,"RC",RCIBX,0)),U,5) Q:RCIBY=""
. S RCIBY=$P(^DGCR(399.1,+RCIBY,0),U) Q:RCIBY=""
. I $F(",NON-VA CARE,NON-VA CARE AT VA EXPENSE,NON-VA CARE%,",","_RCIBY_",") S RCTYPE=1
I RCTYPE S RCXVCFL=0 Q
;
; Hospital location meets the va care checks
S RCTYPE=0
S RCIBX=0 F S RCIBX=$O(RCXTMP("DILIST",RCIBX)) Q:'RCIBX D Q:RCTYPE
. S RCIBY=$$GET1^DIQ(9000010,+RCXTMP("DILIST",RCIBX,0),.22) Q:RCIBY=""
. F RCTY="NVCC","NON-VA CARE","NONVA CARE","NONCOUNT FEE","FEE BASIS" I $F(RCIBY,RCTY) S RCTYPE=1 Q
. Q:RCTYPE ;abbreviation
. S RCIBY=+$O(^SC("B",RCIBY,0)),RCIBY=$P($G(^SC(RCIBY,0)),U,2)
. F RCTY="NVCC","NVC","VCL" I $F(RCIBY,RCTY) S RCTYPE=1
; if no op visit then continue to check
I $O(RCXTMP("DILIST",0))'="" S RCXVCFL=$S('RCTYPE:1,1:0) Q
;
; Check outpatient encounter
; If no encounter on op visit date, it's non va care
NEW IBCBK,IBVAL
S IBCBK="I '$P(Y0,U,6) S ^TMP(""RCXVOE"",$J,+$P(Y0,U,8),Y)=Y0"
S IBVAL("DFN")=$P(^DGCR(399,RCXVIEN,0),U,2)
S (RCTYPE,RCXVODT)=0 K ^TMP("RCXVOE",$J)
; DBIA# 2351 for call to scan^ibsdu
F S RCXVODT=$O(^DGCR(399,RCXVIEN,"OP",RCXVODT)) Q:'RCXVODT D
. S RCTYPE=1,IBVAL("BDT")=RCXVODT,IBVAL("EDT")=RCXVODT+.9999
. D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1)
I RCTYPE,$O(^TMP("RCXVOE",$J,0))="" S RCXVCFL=0 Q
K ^TMP("RCXVOE",$J)
S RCXVCFL=1
Q
;
IBCHG(RCIBY,RCTY,RCTMP) ; Return charge for item entry or null if no charge
; RCTMP=array containing the RC and unit(s) and unit charge
; RCTY=3 for prescription or RCTY=5 for prosthetics or RCTY=4 for cpt
; delete charge entry in rctmp if item found
N RCIBZ,RCIBYC
S RCTMP=$S($D(RCTMP(RCTY,RCIBY)):RCIBY,1:0),RCIBYC=""
F RCTMP=RCTMP,0 Q:'$D(RCTMP(RCTY,RCTMP)) S RCIBZ="" D Q:RCIBZ'=""!(RCTMP=0)
. F S RCIBZ=$O(RCTMP(RCTY,RCTMP,RCIBZ)) Q:RCIBZ="" I RCTMP(RCTY,RCTMP,RCIBZ) S $P(RCTMP(RCTY,RCTMP,RCIBZ),U)=RCTMP(RCTY,RCTMP,RCIBZ)-1,RCIBYC=$P(RCTMP(RCTY,RCTMP,RCIBZ),U,2) K:'RCTMP(RCTY,RCTMP,RCIBZ) RCTMP(RCTY,RCTMP,RCIBZ) Q
Q RCIBYC
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXVUTIL 9522 printed Dec 13, 2024@01:49:51 Page 2
RCXVUTIL ;DAOU/ALA - AR Data Extract Utility Program ;29-JUL-03
+1 ;;4.5;Accounts Receivable;**201,299,308,356**;Mar 20, 1995;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
SPAR(REF) ; HL7 Segment Parsing
+1 ; Input Parameter
+2 ; REF = Array or global reference
+3 ; Global or array should end with ')'
+4 ; e.g. ^TMP($J,"XXX",#)
+5 ;
+6 ; Output Parameters
+7 ; RCXSEG(#) = Each sequence of the segment in the array
+8 ;
+9 NEW ISCT,II,IJ,IK,ISDATA,ISPEC,ISBEG,ISEND,IS,LSDATA,IM,NPC
+10 ;
+11 SET ISCT=""
SET II=0
SET IS=0
+12 FOR
SET ISCT=$ORDER(@REF@(ISCT))
if ISCT=""
QUIT
Begin DoDot:1
+13 SET IS=IS+1
+14 SET ISDATA(IS)=$GET(@REF@(ISCT))
+15 IF $ORDER(@REF@(ISCT))=""
SET ISDATA(IS)=ISDATA(IS)_HLFS
+16 SET ISPEC(IS)=$LENGTH(ISDATA(IS),HLFS)
End DoDot:1
+17 ;
+18 SET IM=0
SET LSDATA=""
LP SET IM=IM+1
if IM>IS
QUIT
+1 SET LSDATA=LSDATA_ISDATA(IM)
SET NPC=ISPEC(IM)
+2 FOR IJ=1:1:NPC-1
Begin DoDot:1
+3 SET II=II+1
SET RCXSEG(II)=$$CLNSTR($PIECE(LSDATA,HLFS,IJ),HL("ECH"),$EXTRACT(HL("ECH")))
End DoDot:1
+4 SET LSDATA=$PIECE(LSDATA,HLFS,NPC)
+5 GOTO LP
+6 ;
CLNSTR(STRING,CHARS,SUBSEP) ; Remove extra trailing components and subcomponents
+1 ; in the HL7 segment
+2 ;
+3 ; Input parameters
+4 ; STRING - The data value to be 'cleansed'
+5 ; CHARS - The component character to be removed
+6 ; SUSEP - The subcomponent character to be removed
+7 ;
+8 NEW RTSTRING,NUMPEC,PEC
+9 SET RTSTRING=$$RTRIMCH(STRING,CHARS)
+10 ; Now we have string without trailing chars, remove from subs
+11 SET NUMPEC=$LENGTH(RTSTRING,SUBSEP)
+12 FOR PEC=1:1:NUMPEC
SET $PIECE(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($PIECE(RTSTRING,SUBSEP,PEC),CHARS)
+13 QUIT RTSTRING
+14 ;
RTRIMCH(STR,CHRS) ; Remove the trailing chars from string
+1 NEW R,L
+2 SET L=1
SET CHRS=$GET(CHRS," ")
+3 FOR R=$LENGTH(STR):-1:1
if CHRS'[$EXTRACT(STR,R)
QUIT
+4 IF L=R
IF (CHRS[$EXTRACT(STR))
SET STR=""
+5 QUIT $EXTRACT(STR,L,R)
+6 ;
DFP(IBN) ; Date of First Payment Function
+1 ; Input Parameter
+2 ; IBN = IEN of the bill number from file 430
+3 ;
+4 NEW VAL,IBPAY,IBT,IBT0,IBT1
+5 SET VAL=0
+6 ; No payments made.
+7 IF '$PIECE($GET(^PRCA(430,IBN,7)),U,7)
QUIT ""
+8 SET (IBPAY,IBT)=0
FOR
SET IBT=$ORDER(^PRCA(433,"C",IBN,IBT))
if 'IBT
QUIT
Begin DoDot:1
+9 SET IBT0=$GET(^PRCA(433,IBT,0))
SET IBT1=$GET(^(1))
+10 ; Not complete.
IF $PIECE(IBT0,U,4)'=2
QUIT
+11 ; Not a payment.
IF $PIECE(IBT1,U,2)'=2
IF $PIECE(IBT1,U,2)'=34
QUIT
+12 SET X=$SELECT(+IBT1:+IBT1,1:$PIECE(IBT1,U,9)\1)
SET $PIECE(VAL,U,4)=X
SET IBPAY=1
End DoDot:1
if IBPAY
QUIT
+13 QUIT $PIECE(VAL,U,4)
+14 ;
DATE(X) ; Pass in External Date and get FileMan date format
+1 ;
+2 ; Input Parameter
+3 ; X = a date in any regular date format
+4 ; Output Parameter
+5 ; Y = a date in FileMan format
+6 ; Parameters
+7 ; DIC(0) = FileMan date parameter
+8 ;
+9 IF X["@"
SET %DT="T"
+10 IF $GET(DIC(0))=""
SET DIC(0)=""
+11 DO ^%DT
+12 IF Y=-1
SET Y=""
+13 KILL DIC,%DT
+14 QUIT Y
+15 ;
TASK(RCDSC) ; Check on Task Status
+1 ;
+2 ; Input Parameter
+3 ; RCDSC = Task Description
+4 ;
+5 NEW RTASKS,RTSK,ZTSK,ZTKEY
+6 DO DESC^%ZTLOAD(RCDSC,"RTASKS")
+7 SET RTSK=""
+8 FOR
SET RTSK=$ORDER(RTASKS(RTSK))
if RTSK=""
QUIT
Begin DoDot:1
+9 SET ZTSK=RTSK
DO STAT^%ZTLOAD
End DoDot:1
+10 ;
+11 KILL RTASKS
+12 IF $GET(ZTSK(2))="Inactive: Finished"
QUIT 0
+13 IF $GET(ZTSK(2))="Inactive: Interrupted"
QUIT 0
+14 IF $GET(ZTSK(2))="Active: Pending"
QUIT 1
+15 QUIT 0
+16 ;
SAT(RDATE) ; Find the next Saturday date from the passed in date
+1 NEW CDOW,FDATE,NDAYS
+2 SET CDOW=$$DOW^XLFDT(RDATE,1)
SET NDAYS=6-CDOW
+3 IF NDAYS=0
SET NDAYS=7
+4 SET FDATE=$$FMADD^XLFDT(RDATE,NDAYS)
+5 QUIT FDATE
+6 ;
CARE(RCXVIEN) ; Is bill VA or NON-VA care?
+1 ;
+2 ; Input parameter
+3 ; RCXVIEN = Bill ien
+4 ;
+5 ; Output parameter
+6 ; RCXVCFL = Care Flag
+7 ; 0 = Non-VA Care
+8 ; 1 = VA Care
+9 ; *308 phase II criteria for inpatient and outpatient
+10 ; -Non-VA care if op visit in 9000010/.22 & stop code=669 in /.08
+11 ; -VA care if the bill # with prosthetic item is found in 362.5
+12 ; -VA care if rate type'=REIMBURSABLE INS or none of types below:
+13 ; FEE;FEE BASIS;FEE-INPT;NON VA CARE;NON-VA;NON-VA FEE BASIS CARE
+14 ; -VA care if item type=RX in 399.042/.1 & charge item found in 362.4
+15 ; -Non-VA care if item type=RX in 399.042/.1 & charge item not found
+16 ; -Non-VA care if op visit in 9000010/.22 matching to any below:
+17 ; NVCC;NVC;VCL;NON-VA CARE;NONVA CARE;NONCOUNT FEE;FEE BASIS
+18 ; -VA care if op vist in 9000010/.22 not matching to any above
+19 ; -Non-VA care if no encounter on op visit date(s) is found in 409.68
+20 ; -VA care if the bill not meet above criteria
+21 ;
+22 ; *299 criteria for inpatient and outpatient
+23 ; -Non-VA care if bill classification is inpt/(med. part A) & no ptf #.
+24 ; -Non-VA care if ptf # & discharge dt are not null and ward is null.
+25 ; -VA care if ptf # & discharge dt are not null and ward is not null.
+26 ; -Non-VA care if ptf # & fee basis are not null, otherwise VA care.
+27 ; -VA care if at least one assoc. opt encounter is not a NON-COUNT (12)
+28 ; encounter, otherwise Non-VA care.
+29 ; -VA care or Non-VA care in the final indicator is determined based on
+30 ; the opt encounter criteria if the flow reaches it.
+31 ;
+32 NEW RCXVCARE,RCXVRATE,RCXVODT,RPTF
+33 NEW RCIBX,RCIBY,RCTY,RCTYPE,RCTMP,RCIBRX
+34 ;
+35 ; if visit has hospital location & stop code 669, it's non-va care
+36 NEW RCDAT,RCDFN,RCXTMP
SET (RCDAT,RCTYPE)=0
+37 SET RCDFN=$PIECE($GET(^DGCR(399,RCXVIEN,0)),U,2)
+38 ; if no date then check yymm only
+39 SET RCTY="N RCIBX S RCIBX=$P($P($G(^(0)),U),""."") S:'+$E(RCDAT,6,7) RCIBX=$E(RCIBX,1,5) I RCIBX=RCDAT"
+40 FOR
SET RCDAT=$ORDER(^DGCR(399,RCXVIEN,"OP",RCDAT))
if 'RCDAT
QUIT
Begin DoDot:1
+41 KILL RCXTMP
DO FIND^DIC(9000010,,"@;.01I","QPX",RCDFN,,"C",RCTY,,"RCXTMP")
+42 SET RCIBX=0
FOR
SET RCIBX=$ORDER(RCXTMP("DILIST",RCIBX))
if 'RCIBX
QUIT
Begin DoDot:2
+43 SET RCIBY=$$GET1^DIQ(9000010,+RCXTMP("DILIST",RCIBX,0),.22)
if RCIBY=""
QUIT
+44 SET RCIBY=$$GET1^DIQ(9000010,+RCXTMP("DILIST",RCIBX,0),.08,"I")
if RCIBY=""
QUIT
+45 IF +$PIECE($GET(^DIC(40.7,+RCIBY,0)),U,2)=669
SET RCTYPE=1
QUIT
End DoDot:2
if RCTYPE
QUIT
End DoDot:1
if RCTYPE
QUIT
+46 IF RCTYPE
SET RCXVCFL=0
QUIT
+47 ;
+48 ; if the bill # with prosthetics item in file 362.5, it's va care
+49 SET RCIBRX="AIFN"_RCXVIEN
+50 IF $DATA(^IBA(362.5,RCIBRX))
SET RCXVCFL=1
QUIT
+51 ;
+52 ; if not Reimbursable Insurance & not fee basis, it's va care
+53 SET RCTYPE=0
+54 SET RCIBX=+$PIECE($GET(^DGCR(399,RCXVIEN,0)),U,7)
+55 SET RCXVRATE=$PIECE($GET(^DGCR(399.3,RCIBX,0)),U)
+56 IF $FIND(",FEE,FEE BASIS,FEE-INPT,NON VA CARE,NON-VA,NON-VA CARE,NON-VA FEE BASIS CARE,",","_RCXVRATE_",")
SET RCTYPE=1
+57 IF 'RCTYPE
IF RCXVRATE'="REIMBURSABLE INS."
SET RCXVCFL=1
QUIT
+58 ;
+59 ; non-va discharge date
+60 IF $PIECE($GET(^DGCR(399,RCXVIEN,0)),U,16)'=""
SET RCXVCFL=0
QUIT
+61 ;
+62 ; non-va facility, non-va care type, non-va care id
+63 SET RCXVCARE=$GET(^DGCR(399,RCXVIEN,"U2"))
+64 IF $PIECE(RCXVCARE,U,10)'=""
SET RCXVCFL=0
QUIT
+65 IF $PIECE(RCXVCARE,U,11)'=""
SET RCXVCFL=0
QUIT
+66 IF $PIECE(RCXVCARE,U,12)'=""
SET RCXVCFL=0
QUIT
+67 ;
+68 ; Prescription item charge in file 362.4
+69 SET (RCIBX,RCTYPE)=0
SET RCIBRX="AIFN"_RCXVIEN
+70 ; DBIA#3811
+71 KILL RCTMP
DO RCITEM^IBCSC5A(RCXVIEN,"RCTMP",3)
+72 FOR
SET RCIBX=$ORDER(^IBA(362.4,RCIBRX,RCIBX))
if 'RCIBX
QUIT
SET RCIBY=0
Begin DoDot:1
+73 FOR
SET RCIBY=$ORDER(^IBA(362.4,RCIBRX,RCIBX,RCIBY))
if 'RCIBY
QUIT
Begin DoDot:2
+74 IF $$IBCHG(RCIBY,3,.RCTMP)'=""
SET RCTYPE=1
QUIT
End DoDot:2
if 'RCTYPE
QUIT
End DoDot:1
if 'RCTYPE
QUIT
+75 ; no item and no charge, then continue to check
+76 IF $ORDER(RCTMP(3,""))'=""
SET RCXVCFL=0
QUIT
+77 IF RCTYPE
SET RCXVCFL=1
QUIT
+78 ;
+79 ; Check inpatient
+80 ; -ptf entry number (#399/.08) & bill classification (#399/.05)
+81 SET RPTF=$PIECE($GET(^DGCR(399,RCXVIEN,0)),U,8)
+82 IF $PIECE($GET(^DGCR(399,RCXVIEN,0)),U,5)=1
IF RPTF=""
SET RCXVCFL=0
QUIT
+83 ;
+84 ; -discharge date (#45/70) and ward at discharge (#45/2.2)
+85 ; -fee basis (#45/4) exits, it's non-va care
+86 ; DBIA#6030
+87 IF RPTF'=""
Begin DoDot:1
+88 IF $PIECE($GET(^DGPT(RPTF,70)),U,1)'=""
Begin DoDot:2
+89 NEW X
SET X=""
DO PTF^DGPMUTL(RPTF)
+90 IF X=""
SET RCXVCFL=0
QUIT
+91 SET RCXVCFL=1
End DoDot:2
QUIT
+92 IF $PIECE($GET(^DGPT(RPTF,0)),U,4)=1
SET RCXVCFL=0
QUIT
+93 SET RCXVCFL=1
End DoDot:1
QUIT
+94 ;
+95 ; If at least bedsection=non-va care, it's non-va care
+96 SET (RCIBX,RCTYPE)=0
+97 FOR
SET RCIBX=$ORDER(^DGCR(399,RCXVIEN,"RC",RCIBX))
if 'RCIBX
QUIT
Begin DoDot:1
+98 SET RCIBY=$PIECE($GET(^DGCR(399,RCXVIEN,"RC",RCIBX,0)),U,5)
if RCIBY=""
QUIT
+99 SET RCIBY=$PIECE(^DGCR(399.1,+RCIBY,0),U)
if RCIBY=""
QUIT
+100 IF $FIND(",NON-VA CARE,NON-VA CARE AT VA EXPENSE,NON-VA CARE%,",","_RCIBY_",")
SET RCTYPE=1
End DoDot:1
if RCTYPE
QUIT
+101 IF RCTYPE
SET RCXVCFL=0
QUIT
+102 ;
+103 ; Hospital location meets the va care checks
+104 SET RCTYPE=0
+105 SET RCIBX=0
FOR
SET RCIBX=$ORDER(RCXTMP("DILIST",RCIBX))
if 'RCIBX
QUIT
Begin DoDot:1
+106 SET RCIBY=$$GET1^DIQ(9000010,+RCXTMP("DILIST",RCIBX,0),.22)
if RCIBY=""
QUIT
+107 FOR RCTY="NVCC","NON-VA CARE","NONVA CARE","NONCOUNT FEE","FEE BASIS"
IF $FIND(RCIBY,RCTY)
SET RCTYPE=1
QUIT
+108 ;abbreviation
if RCTYPE
QUIT
+109 SET RCIBY=+$ORDER(^SC("B",RCIBY,0))
SET RCIBY=$PIECE($GET(^SC(RCIBY,0)),U,2)
+110 FOR RCTY="NVCC","NVC","VCL"
IF $FIND(RCIBY,RCTY)
SET RCTYPE=1
End DoDot:1
if RCTYPE
QUIT
+111 ; if no op visit then continue to check
+112 IF $ORDER(RCXTMP("DILIST",0))'=""
SET RCXVCFL=$SELECT('RCTYPE:1,1:0)
QUIT
+113 ;
+114 ; Check outpatient encounter
+115 ; If no encounter on op visit date, it's non va care
+116 NEW IBCBK,IBVAL
+117 SET IBCBK="I '$P(Y0,U,6) S ^TMP(""RCXVOE"",$J,+$P(Y0,U,8),Y)=Y0"
+118 SET IBVAL("DFN")=$PIECE(^DGCR(399,RCXVIEN,0),U,2)
+119 SET (RCTYPE,RCXVODT)=0
KILL ^TMP("RCXVOE",$JOB)
+120 ; DBIA# 2351 for call to scan^ibsdu
+121 FOR
SET RCXVODT=$ORDER(^DGCR(399,RCXVIEN,"OP",RCXVODT))
if 'RCXVODT
QUIT
Begin DoDot:1
+122 SET RCTYPE=1
SET IBVAL("BDT")=RCXVODT
SET IBVAL("EDT")=RCXVODT+.9999
+123 DO SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1)
End DoDot:1
+124 IF RCTYPE
IF $ORDER(^TMP("RCXVOE",$JOB,0))=""
SET RCXVCFL=0
QUIT
+125 KILL ^TMP("RCXVOE",$JOB)
+126 SET RCXVCFL=1
+127 QUIT
+128 ;
IBCHG(RCIBY,RCTY,RCTMP) ; Return charge for item entry or null if no charge
+1 ; RCTMP=array containing the RC and unit(s) and unit charge
+2 ; RCTY=3 for prescription or RCTY=5 for prosthetics or RCTY=4 for cpt
+3 ; delete charge entry in rctmp if item found
+4 NEW RCIBZ,RCIBYC
+5 SET RCTMP=$SELECT($DATA(RCTMP(RCTY,RCIBY)):RCIBY,1:0)
SET RCIBYC=""
+6 FOR RCTMP=RCTMP,0
if '$DATA(RCTMP(RCTY,RCTMP))
QUIT
SET RCIBZ=""
Begin DoDot:1
+7 FOR
SET RCIBZ=$ORDER(RCTMP(RCTY,RCTMP,RCIBZ))
if RCIBZ=""
QUIT
IF RCTMP(RCTY,RCTMP,RCIBZ)
SET $PIECE(RCTMP(RCTY,RCTMP,RCIBZ),U)=RCTMP(RCTY,RCTMP,RCIBZ)-1
SET RCIBYC=$PIECE(RCTMP(RCTY,RCTMP,RCIBZ),U,2)
if 'RCTMP(RCTY,RCTMP,RCIBZ)
KILL RCTMP(RCTY,RCTMP,RCIBZ)
QUIT
End DoDot:1
if RCIBZ'=""!(RCTMP=0)
QUIT
+8 QUIT RCIBYC
+9 ;
