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

RCXVDC3.m

Go to the documentation of this file.
  1. RCXVDC3 ;DAOU/ALA-AR Data Extraction Data Creation ; 23 Jul 2007 10:32 AM
  1. ;;4.5;Accounts Receivable;**201,227,228,232,248,251,270**;Mar 20, 1995;Build 25
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; CLAIMS (# 399)
  1. Q
  1. D399 ;
  1. NEW RCXVD,RCXVBC,RCXVDT,RCXVD1,RCXVD2,RCXVD3
  1. NEW RCXVD4,RCXVD5,RCXVD6,RCXVD7,RCXVDA,RCXVDB,RCXVDC,RCXVDD
  1. NEW RCXVP1,RCXVP2,RCXVD0C,RCXVP3,RCXVP4,RCXVP5,RCXVCFL,RCXVPAY
  1. NEW RCXVINS,RCXVVAN,RCXVDRG,RCXVCAN,RCXVSNR,IBD,X1,X2,RCXVNPI
  1. ;
  1. ;WCJ;PRCA*4.5*270;Start
  1. ;I $P(RCXVBLNA,"-",2)="" Q
  1. ;S RCXVD0=$O(^DGCR(399,"B",$P(RCXVBLNA,"-",2),""))
  1. ;I RCXVD0="" Q
  1. Q:'+$G(RCXVBLN)
  1. S RCXVD0=RCXVBLN
  1. ;WCJ;PRCA*4.5*270;End
  1. ;
  1. S RCXVD1=$G(^DGCR(399,RCXVD0,0))
  1. Q:RCXVD1="" ;WCJ;PRCA*4.5*270
  1. I $G(DFN)="" S DFN=$P(RCXVD1,U,2)
  1. Q:'DFN ;WCJ;PRCA*4.5*270
  1. S RCXVD2=$G(^DGCR(399,RCXVD0,"S"))
  1. S RCXVD3=$G(^DGCR(399,RCXVD0,"U"))
  1. S RCXVD7=$G(^DGCR(399,RCXVD0,"TX"))
  1. S RCXVDA=$P(RCXVD1,U,1) ; BILL #
  1. S (RCXVEVDT,RCXVDT)=$P($P(RCXVD1,U,3),".",1)
  1. ;S RCXVDA=RCXVBLNB_RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; EVNT DT
  1. S RCXVDA=RCXVBLNA_RCXVU_$P(^DPT(DFN,0),U,9) ; SSN
  1. S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; EVNT DT
  1. S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,5) ; BILL CLASS
  1. S RCXVP1=$P(RCXVD1,U,7),RCXVP2=""
  1. I RCXVP1'="" S RCXVP2=$P($G(^DGCR(399.3,RCXVP1,0)),U,1)
  1. S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; RATE TYPE (P)
  1. S RCXVP1=$P(RCXVD2,U,11),RCXVP2=""
  1. I RCXVP1'="" S RCXVP2=$P($G(^VA(200,RCXVP1,2,0)),U,1)_RCXVP1 ; SITE_IEN
  1. S RCXVDA=RCXVDA_RCXVU_RCXVSITE_RCXVP2 ; Authorizer (P)
  1. S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,13) ; Stat
  1. S RCXVDT=$P(RCXVD1,U,14)
  1. S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; Stat DT
  1. S RCXVP1=$P(RCXVD1,U,22),RCXVP2="",RCXVNPI=""
  1. I RCXVP1'="" S RCXVP2=$$GET1^DIQ(40.8,RCXVP1,1) ;$P($G(^DG(40.8,RCXVP1,0)),U,2)
  1. S:$G(RCXVP1)'="" RCXVNPI=$P($$NPI^XUSNPI("Organization_ID",$$GET1^DIQ(40.8,RCXVP1,.07,"I")),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" ;Default Division NPI
  1. S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI ; Default division^Default division NPI
  1. S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,24) ; UB92 Location
  1. S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,27) ; Bill Chrg type
  1. S RCXVDT=$P(RCXVD2,U,10)
  1. S RCXVDB=$E($$HLDATE^HLFNC(RCXVDT),1,8) ; Auth. DT
  1. S RCXVDT=$P(RCXVD2,U,12)
  1. S RCXVDB=RCXVDB_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; DT 1st printed
  1. S (RCXVP1,RCXVD0C)=$P($G(^DGCR(399,RCXVD0,"M")),U,1),RCXVP2=""
  1. I RCXVP1'="" S RCXVP2=$P($G(^DIC(36,RCXVP1,0)),U,1)
  1. S RCXVDB=RCXVDB_RCXVU_RCXVP2 ; PRIM. INSR (P)
  1. ;
  1. ; Type of Plan
  1. S RCXVP2="",RCXVI=0,RCXVP3="",RCXVP4="",RCXVP5=""
  1. S IBD=$$IBAREXT^IBRFN4(RCXVD0,.IBD)
  1. S RCXVP2=$P(IBD("IN"),U),RCXVP5=$P(IBD("IN"),U,2),RCXVP3=$P(IBD("IN"),U,3),RCXVP4=$P(IBD("IN"),U,4)
  1. S RCXVDB=RCXVDB_RCXVU_RCXVP2_RCXVU_RCXVP5_RCXVU_RCXVP3_RCXVU_RCXVP4,RCXVD5="",RCXVD6=""
  1. ;
  1. ; 36, 36.3 ADDRESS/EDI
  1. I RCXVD0C S RCXVD5=$G(^DIC(36,RCXVD0C,.11))
  1. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD5,U,1) ; STRT ADD 1
  1. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD5,U,2) ; STRT ADD 2
  1. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD5,U,4) ; CITY
  1. S RCXVP1=$P(RCXVD5,U,5),RCXVP2=""
  1. I RCXVP1'="" S RCXVP2=$P($G(^DIC(5,RCXVP1,0)),U,1)
  1. S RCXVDB=RCXVDB_RCXVU_RCXVP2 ; STATE (P)
  1. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD5,U,6) ; ZIP
  1. I RCXVD0C'="" S RCXVD6=$G(^DIC(36,RCXVD0C,3))
  1. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD6,U,2) ; EDI - PROF
  1. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD6,U,4) ; EDI - INST
  1. S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(36,RCXVD0C_",",1,"I") ; REIMBURSE?
  1. ;
  1. S RCXVPFDT=$P(RCXVD3,U,1)
  1. S RCXVDC=$$HLDATE^HLFNC(RCXVPFDT) ; STMT COVERS FROM
  1. S RCXVPTDT=$P(RCXVD3,U,2)
  1. S RCXVDC=RCXVDC_RCXVU_$$HLDATE^HLFNC(RCXVPTDT) ; STMT COVERS TO
  1. S RCXVP1=$P(RCXVD3,U,11),RCXVP2=""
  1. I RCXVP1'="" S RCXVP2=$P($G(^DGCR(399.1,RCXVP1,0)),U,1)
  1. S RCXVDC=RCXVDC_RCXVU_RCXVP2 ; DISCH. BED SEC.
  1. S RCXVD4=$G(^DGCR(399,RCXVD0,"U1"))
  1. S RCXVDC=RCXVDC_RCXVU_$P(RCXVD4,U,1) ; TOT CHRG
  1. ;
  1. S RCXVP1=$P($G(^DGCR(399,RCXVD0,"U2")),U,10),RCXVP2="",RCXVNPI=""
  1. I RCXVP1'="" S RCXVP2=$P($G(^IBA(355.93,RCXVP1,0)),U,1)
  1. S:$G(RCXVP2)'="" RCXVNPI=$P($$NPI^XUSNPI("Non_VA_Provider_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI=""
  1. I RCXVNPI="",$G(RCXVP2)'="" S RCXVNPI=$$GET1^DIQ(355.93,RCXVP1,41.01,"I") ;This line is used if the XUSNPI API does not work
  1. S RCXVDC=RCXVDC_RCXVU_RCXVP2_RCXVU_RCXVNPI ; NON VA FAC (P)^NON VA FAC NPI
  1. ;
  1. ; Get VACARE or NONVACARE flag
  1. NEW RCXVIEN
  1. D CARE^RCXVUTIL(RCXVD0)
  1. S RCXVDC=RCXVDC_RCXVU_$S(RCXVCFL=1:"VACARE",1:"NONVACARE")
  1. ; MRA data
  1. S RCXVDT=$P(IBD,U,2)
  1. S RCXVDD=$E($$HLDATE^HLFNC(RCXVDT),1,8) ; MRA Requested DT
  1. S RCXVDT=$P(IBD,U,3)
  1. S RCXVDD=RCXVDD_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ;Last Electronic Extract Date
  1. S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,4) ;Printed VIA EDI
  1. S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,5) ;Force Claim To Print
  1. S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,6) ;Claim MRA Status
  1. S RCXVDT=$P(IBD,U,7)
  1. S RCXVDD=RCXVDD_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ;MRA Recorded Date
  1. S RCXVDT=$P(IBD,U,8)
  1. S RCXVDD=RCXVDD_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ;Date Cancelled
  1. S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,9) ;Form Type
  1. S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,16)_RCXVU_$P(IBD,U,15) ;PAYER&VA NAT.ID #
  1. S RCXVDRG=$P(IBD,U,11)
  1. S RCXVDD=RCXVDD_RCXVU_RCXVDRG ;DRG
  1. S RCXVSNR=$P(IBD,U,14) ;Days site not responsible for MRA request
  1. S RCXVDD=RCXVDD_RCXVU_RCXVSNR
  1. S RCXVDD=RCXVDD_RCXVU_$P($P(IBD,U,12),";") ;ECME #
  1. S RCXVDD=RCXVDD_RCXVU_$P(IBD,U,17) ;Offset Amount
  1. S ^TMP($J,RCXVBLN,"3-399A")=RCXVDA
  1. S ^TMP($J,RCXVBLN,"3-399B")=RCXVDB
  1. S ^TMP($J,RCXVBLN,"3-399C")=RCXVDC
  1. S ^TMP($J,RCXVBLN,"3-399D")=RCXVDD
  1. Q
  1. ;
  1. REJ() ;Checks for reject on a claim
  1. S X="NO"
  1. S X1=$P(RCXVD1,U,15) S D0=RCXVD0
  1. F D G REJQ:'D0
  1. . S I=0 F S I=$O(^IBM(361,"B",D0,I)) Q:'I D Q:'D0
  1. ..S X2=$P($G(^IBM(361,I,0)),U,3)
  1. ..I X2="R" S X="YES",D0=""
  1. ..Q
  1. .I X="YES" Q
  1. .I X1=D0 S D0="" Q
  1. .S D0=X1 Q:'D0 S X1=$P($G(^DGCR(399,X1,0)),U,15)
  1. .Q
  1. K I
  1. REJQ Q X
  1. ;