Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCXVUTIL

RCXVUTIL.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. SPAR(REF) ; HL7 Segment Parsing
  1. ; Input Parameter
  1. ; REF = Array or global reference
  1. ; Global or array should end with ')'
  1. ; e.g. ^TMP($J,"XXX",#)
  1. ;
  1. ; Output Parameters
  1. ; RCXSEG(#) = Each sequence of the segment in the array
  1. ;
  1. NEW ISCT,II,IJ,IK,ISDATA,ISPEC,ISBEG,ISEND,IS,LSDATA,IM,NPC
  1. ;
  1. S ISCT="",II=0,IS=0
  1. F S ISCT=$O(@REF@(ISCT)) Q:ISCT="" D
  1. . S IS=IS+1
  1. . S ISDATA(IS)=$G(@REF@(ISCT))
  1. . I $O(@REF@(ISCT))="" S ISDATA(IS)=ISDATA(IS)_HLFS
  1. . S ISPEC(IS)=$L(ISDATA(IS),HLFS)
  1. ;
  1. S IM=0,LSDATA=""
  1. LP S IM=IM+1 Q:IM>IS
  1. S LSDATA=LSDATA_ISDATA(IM),NPC=ISPEC(IM)
  1. F IJ=1:1:NPC-1 D
  1. . S II=II+1,RCXSEG(II)=$$CLNSTR($P(LSDATA,HLFS,IJ),HL("ECH"),$E(HL("ECH")))
  1. S LSDATA=$P(LSDATA,HLFS,NPC)
  1. G LP
  1. ;
  1. CLNSTR(STRING,CHARS,SUBSEP) ; Remove extra trailing components and subcomponents
  1. ; in the HL7 segment
  1. ;
  1. ; Input parameters
  1. ; STRING - The data value to be 'cleansed'
  1. ; CHARS - The component character to be removed
  1. ; SUSEP - The subcomponent character to be removed
  1. ;
  1. N RTSTRING,NUMPEC,PEC
  1. S RTSTRING=$$RTRIMCH(STRING,CHARS)
  1. ; Now we have string without trailing chars, remove from subs
  1. S NUMPEC=$L(RTSTRING,SUBSEP)
  1. F PEC=1:1:NUMPEC S $P(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($P(RTSTRING,SUBSEP,PEC),CHARS)
  1. Q RTSTRING
  1. ;
  1. RTRIMCH(STR,CHRS) ; Remove the trailing chars from string
  1. N R,L
  1. S L=1,CHRS=$G(CHRS," ")
  1. F R=$L(STR):-1:1 Q:CHRS'[$E(STR,R)
  1. I L=R,(CHRS[$E(STR)) S STR=""
  1. Q $E(STR,L,R)
  1. ;
  1. DFP(IBN) ; Date of First Payment Function
  1. ; Input Parameter
  1. ; IBN = IEN of the bill number from file 430
  1. ;
  1. N VAL,IBPAY,IBT,IBT0,IBT1
  1. S VAL=0
  1. ; No payments made.
  1. I '$P($G(^PRCA(430,IBN,7)),U,7) Q ""
  1. S (IBPAY,IBT)=0 F S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT D Q:IBPAY
  1. . S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1))
  1. . I $P(IBT0,U,4)'=2 Q ; Not complete.
  1. . I $P(IBT1,U,2)'=2,$P(IBT1,U,2)'=34 Q ; Not a payment.
  1. . S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1
  1. Q $P(VAL,U,4)
  1. ;
  1. DATE(X) ; Pass in External Date and get FileMan date format
  1. ;
  1. ; Input Parameter
  1. ; X = a date in any regular date format
  1. ; Output Parameter
  1. ; Y = a date in FileMan format
  1. ; Parameters
  1. ; DIC(0) = FileMan date parameter
  1. ;
  1. I X["@" S %DT="T"
  1. I $G(DIC(0))="" S DIC(0)=""
  1. D ^%DT
  1. I Y=-1 S Y=""
  1. K DIC,%DT
  1. Q Y
  1. ;
  1. TASK(RCDSC) ; Check on Task Status
  1. ;
  1. ; Input Parameter
  1. ; RCDSC = Task Description
  1. ;
  1. NEW RTASKS,RTSK,ZTSK,ZTKEY
  1. D DESC^%ZTLOAD(RCDSC,"RTASKS")
  1. S RTSK=""
  1. F S RTSK=$O(RTASKS(RTSK)) Q:RTSK="" D
  1. . S ZTSK=RTSK D STAT^%ZTLOAD
  1. ;
  1. K RTASKS
  1. I $G(ZTSK(2))="Inactive: Finished" Q 0
  1. I $G(ZTSK(2))="Inactive: Interrupted" Q 0
  1. I $G(ZTSK(2))="Active: Pending" Q 1
  1. Q 0
  1. ;
  1. SAT(RDATE) ; Find the next Saturday date from the passed in date
  1. NEW CDOW,FDATE,NDAYS
  1. S CDOW=$$DOW^XLFDT(RDATE,1),NDAYS=6-CDOW
  1. I NDAYS=0 S NDAYS=7
  1. S FDATE=$$FMADD^XLFDT(RDATE,NDAYS)
  1. Q FDATE
  1. ;
  1. CARE(RCXVIEN) ; Is bill VA or NON-VA care?
  1. ;
  1. ; Input parameter
  1. ; RCXVIEN = Bill ien
  1. ;
  1. ; Output parameter
  1. ; RCXVCFL = Care Flag
  1. ; 0 = Non-VA Care
  1. ; 1 = VA Care
  1. ; *308 phase II criteria for inpatient and outpatient
  1. ; -Non-VA care if op visit in 9000010/.22 & stop code=669 in /.08
  1. ; -VA care if the bill # with prosthetic item is found in 362.5
  1. ; -VA care if rate type'=REIMBURSABLE INS or none of types below:
  1. ; FEE;FEE BASIS;FEE-INPT;NON VA CARE;NON-VA;NON-VA FEE BASIS CARE
  1. ; -VA care if item type=RX in 399.042/.1 & charge item found in 362.4
  1. ; -Non-VA care if item type=RX in 399.042/.1 & charge item not found
  1. ; -Non-VA care if op visit in 9000010/.22 matching to any below:
  1. ; NVCC;NVC;VCL;NON-VA CARE;NONVA CARE;NONCOUNT FEE;FEE BASIS
  1. ; -VA care if op vist in 9000010/.22 not matching to any above
  1. ; -Non-VA care if no encounter on op visit date(s) is found in 409.68
  1. ; -VA care if the bill not meet above criteria
  1. ;
  1. ; *299 criteria for inpatient and outpatient
  1. ; -Non-VA care if bill classification is inpt/(med. part A) & no ptf #.
  1. ; -Non-VA care if ptf # & discharge dt are not null and ward is null.
  1. ; -VA care if ptf # & discharge dt are not null and ward is not null.
  1. ; -Non-VA care if ptf # & fee basis are not null, otherwise VA care.
  1. ; -VA care if at least one assoc. opt encounter is not a NON-COUNT (12)
  1. ; encounter, otherwise Non-VA care.
  1. ; -VA care or Non-VA care in the final indicator is determined based on
  1. ; the opt encounter criteria if the flow reaches it.
  1. ;
  1. N RCXVCARE,RCXVRATE,RCXVODT,RPTF
  1. N RCIBX,RCIBY,RCTY,RCTYPE,RCTMP,RCIBRX
  1. ;
  1. ; if visit has hospital location & stop code 669, it's non-va care
  1. N RCDAT,RCDFN,RCXTMP S (RCDAT,RCTYPE)=0
  1. S RCDFN=$P($G(^DGCR(399,RCXVIEN,0)),U,2)
  1. ; if no date then check yymm only
  1. S RCTY="N RCIBX S RCIBX=$P($P($G(^(0)),U),""."") S:'+$E(RCDAT,6,7) RCIBX=$E(RCIBX,1,5) I RCIBX=RCDAT"
  1. F S RCDAT=$O(^DGCR(399,RCXVIEN,"OP",RCDAT)) Q:'RCDAT D Q:RCTYPE
  1. . K RCXTMP D FIND^DIC(9000010,,"@;.01I","QPX",RCDFN,,"C",RCTY,,"RCXTMP")
  1. . S RCIBX=0 F S RCIBX=$O(RCXTMP("DILIST",RCIBX)) Q:'RCIBX D Q:RCTYPE
  1. .. S RCIBY=$$GET1^DIQ(9000010,+RCXTMP("DILIST",RCIBX,0),.22) Q:RCIBY=""
  1. .. S RCIBY=$$GET1^DIQ(9000010,+RCXTMP("DILIST",RCIBX,0),.08,"I") Q:RCIBY=""
  1. .. I +$P($G(^DIC(40.7,+RCIBY,0)),U,2)=669 S RCTYPE=1 Q
  1. I RCTYPE S RCXVCFL=0 Q
  1. ;
  1. ; if the bill # with prosthetics item in file 362.5, it's va care
  1. S RCIBRX="AIFN"_RCXVIEN
  1. I $D(^IBA(362.5,RCIBRX)) S RCXVCFL=1 Q
  1. ;
  1. ; if not Reimbursable Insurance & not fee basis, it's va care
  1. S RCTYPE=0
  1. S RCIBX=+$P($G(^DGCR(399,RCXVIEN,0)),U,7)
  1. S RCXVRATE=$P($G(^DGCR(399.3,RCIBX,0)),U)
  1. I $F(",FEE,FEE BASIS,FEE-INPT,NON VA CARE,NON-VA,NON-VA CARE,NON-VA FEE BASIS CARE,",","_RCXVRATE_",") S RCTYPE=1
  1. I 'RCTYPE,RCXVRATE'="REIMBURSABLE INS." S RCXVCFL=1 Q
  1. ;
  1. ; non-va discharge date
  1. I $P($G(^DGCR(399,RCXVIEN,0)),U,16)'="" S RCXVCFL=0 Q
  1. ;
  1. ; non-va facility, non-va care type, non-va care id
  1. S RCXVCARE=$G(^DGCR(399,RCXVIEN,"U2"))
  1. I $P(RCXVCARE,U,10)'="" S RCXVCFL=0 Q
  1. I $P(RCXVCARE,U,11)'="" S RCXVCFL=0 Q
  1. I $P(RCXVCARE,U,12)'="" S RCXVCFL=0 Q
  1. ;
  1. ; Prescription item charge in file 362.4
  1. S (RCIBX,RCTYPE)=0,RCIBRX="AIFN"_RCXVIEN
  1. ; DBIA#3811
  1. K RCTMP D RCITEM^IBCSC5A(RCXVIEN,"RCTMP",3)
  1. F S RCIBX=$O(^IBA(362.4,RCIBRX,RCIBX)) Q:'RCIBX S RCIBY=0 D Q:'RCTYPE
  1. . F S RCIBY=$O(^IBA(362.4,RCIBRX,RCIBX,RCIBY)) Q:'RCIBY D Q:'RCTYPE
  1. .. I $$IBCHG(RCIBY,3,.RCTMP)'="" S RCTYPE=1 Q
  1. ; no item and no charge, then continue to check
  1. I $O(RCTMP(3,""))'="" S RCXVCFL=0 Q
  1. I RCTYPE S RCXVCFL=1 Q
  1. ;
  1. ; Check inpatient
  1. ; -ptf entry number (#399/.08) & bill classification (#399/.05)
  1. S RPTF=$P($G(^DGCR(399,RCXVIEN,0)),U,8)
  1. I $P($G(^DGCR(399,RCXVIEN,0)),U,5)=1,RPTF="" S RCXVCFL=0 Q
  1. ;
  1. ; -discharge date (#45/70) and ward at discharge (#45/2.2)
  1. ; -fee basis (#45/4) exits, it's non-va care
  1. ; DBIA#6030
  1. I RPTF'="" D Q
  1. . I $P($G(^DGPT(RPTF,70)),U,1)'="" D Q
  1. .. N X S X="" D PTF^DGPMUTL(RPTF)
  1. .. I X="" S RCXVCFL=0 Q
  1. .. S RCXVCFL=1
  1. . I $P($G(^DGPT(RPTF,0)),U,4)=1 S RCXVCFL=0 Q
  1. . S RCXVCFL=1
  1. ;
  1. ; If at least bedsection=non-va care, it's non-va care
  1. S (RCIBX,RCTYPE)=0
  1. F S RCIBX=$O(^DGCR(399,RCXVIEN,"RC",RCIBX)) Q:'RCIBX D Q:RCTYPE
  1. . S RCIBY=$P($G(^DGCR(399,RCXVIEN,"RC",RCIBX,0)),U,5) Q:RCIBY=""
  1. . S RCIBY=$P(^DGCR(399.1,+RCIBY,0),U) Q:RCIBY=""
  1. . I $F(",NON-VA CARE,NON-VA CARE AT VA EXPENSE,NON-VA CARE%,",","_RCIBY_",") S RCTYPE=1
  1. I RCTYPE S RCXVCFL=0 Q
  1. ;
  1. ; Hospital location meets the va care checks
  1. S RCTYPE=0
  1. S RCIBX=0 F S RCIBX=$O(RCXTMP("DILIST",RCIBX)) Q:'RCIBX D Q:RCTYPE
  1. . S RCIBY=$$GET1^DIQ(9000010,+RCXTMP("DILIST",RCIBX,0),.22) Q:RCIBY=""
  1. . F RCTY="NVCC","NON-VA CARE","NONVA CARE","NONCOUNT FEE","FEE BASIS" I $F(RCIBY,RCTY) S RCTYPE=1 Q
  1. . Q:RCTYPE ;abbreviation
  1. . S RCIBY=+$O(^SC("B",RCIBY,0)),RCIBY=$P($G(^SC(RCIBY,0)),U,2)
  1. . F RCTY="NVCC","NVC","VCL" I $F(RCIBY,RCTY) S RCTYPE=1
  1. ; if no op visit then continue to check
  1. I $O(RCXTMP("DILIST",0))'="" S RCXVCFL=$S('RCTYPE:1,1:0) Q
  1. ;
  1. ; Check outpatient encounter
  1. ; If no encounter on op visit date, it's non va care
  1. NEW IBCBK,IBVAL
  1. S IBCBK="I '$P(Y0,U,6) S ^TMP(""RCXVOE"",$J,+$P(Y0,U,8),Y)=Y0"
  1. S IBVAL("DFN")=$P(^DGCR(399,RCXVIEN,0),U,2)
  1. S (RCTYPE,RCXVODT)=0 K ^TMP("RCXVOE",$J)
  1. ; DBIA# 2351 for call to scan^ibsdu
  1. F S RCXVODT=$O(^DGCR(399,RCXVIEN,"OP",RCXVODT)) Q:'RCXVODT D
  1. . S RCTYPE=1,IBVAL("BDT")=RCXVODT,IBVAL("EDT")=RCXVODT+.9999
  1. . D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1)
  1. I RCTYPE,$O(^TMP("RCXVOE",$J,0))="" S RCXVCFL=0 Q
  1. K ^TMP("RCXVOE",$J)
  1. S RCXVCFL=1
  1. Q
  1. ;
  1. 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
  1. ; RCTY=3 for prescription or RCTY=5 for prosthetics or RCTY=4 for cpt
  1. ; delete charge entry in rctmp if item found
  1. N RCIBZ,RCIBYC
  1. S RCTMP=$S($D(RCTMP(RCTY,RCIBY)):RCIBY,1:0),RCIBYC=""
  1. F RCTMP=RCTMP,0 Q:'$D(RCTMP(RCTY,RCTMP)) S RCIBZ="" D Q:RCIBZ'=""!(RCTMP=0)
  1. . 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
  1. Q RCIBYC
  1. ;