- 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 Feb 18, 2025@23:16:15 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 ;