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

IBCSC4F.m

Go to the documentation of this file.
  1. IBCSC4F ;ALB/ARH - GET PTF DIAGNOSIS ;10-OCT-1998
  1. ;;2.0;INTEGRATED BILLING;**106,403,400,522,547**;21-MAR-94;Build 119
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. PTFDXDT(IBPTF,IBDT1,IBDT2,TF) ; collect PTF Transfer (501) and Discharge (701) movements and diagnosis within a date range
  1. ; if end date is before Discharge date delete Discharge Diagnosis
  1. ; if bill is an interim first or interim continuous then the last date on the bill is included in the bill
  1. N IBSTAY,IBADM,IBDSCH,IBDT,IBLAST,IBMDT K ^TMP($J,"IBDX","D"),^TMP($J,"IBDX","M") Q:'$G(IBPTF)
  1. S IBDT1=+$G(IBDT1)\1 Q:IBDT1'?7N S IBDT2=+$G(IBDT2)\1 Q:IBDT2'?7N
  1. ;
  1. D PTFDX(IBPTF)
  1. ;
  1. S IBSTAY=$G(^TMP($J,"IBDX","M")),IBADM=+$P($P(IBSTAY,U,2),".",1),IBDSCH=+$P($P(IBSTAY,U,3),".",1)
  1. ;
  1. I IBADM=IBDSCH Q ; 1 day stay, accept all
  1. I IBDT1=IBADM,IBDT2=IBDSCH Q ; bill for entire length of stay, accept all
  1. ;
  1. I IBDT2<IBDSCH K ^TMP($J,"IBDX","D") ; discharge date not on bill, exclude 701 Dxs
  1. I 'IBDSCH,IBDT2<DT K ^TMP($J,"IBDX","D") ; not discharged, current end date (today) not on bill, exclude 701 Dxs
  1. ;
  1. ; determine which of the movements should be included based on dates and timeframe
  1. S TF=$G(TF) I (TF=2)!(TF=3) S IBDT2=$$FMADD^XLFDT(IBDT2,1) ; if first or continuous bill include end date
  1. ;
  1. S (IBLAST,IBDT)="" F S IBDT=$O(^TMP($J,"IBDX","M",IBDT)) Q:'IBDT D S IBLAST=IBDT
  1. . S IBMDT=$P(IBDT,".",1)
  1. . I IBMDT'>IBDT1 K ^TMP($J,"IBDX","M",IBDT)
  1. . I IBLAST>IBDT2 K ^TMP($J,"IBDX","M",IBDT)
  1. Q
  1. ;
  1. PTFDX(IBPTF) ; collect all PTF Transfer (501) and Discharge (701) movements and diagnosis and try to assign SC
  1. ; PTF movements are assigned SC or NSC but diagnosis are not
  1. ; this routine 'interprets' this PTF data and 'assigns' SC/NSC to individual Diagnosis
  1. ; Movement (501) Diagnosis: all Dx on SC movements are assigned SC
  1. ; a Dx on an NSC movement that is also the first Dx on an SC move is assigned SC
  1. ; Discharge (701) Diagnosis: if admit is for SC care all discharge Dx are assigned SC
  1. ; if the Dx is also the first Dx on an SC movement then is assigned SC
  1. ; a Dx on an SC movement only is assigned SC
  1. ;
  1. ; Output: TMP($J,"IBDX","D")=PTF # ^ ADMIT DATE ^ DISCHARGE DATE
  1. ; TMP($J,"IBDX","D", DISCHARGE DATE) = DISCHARGE DATE ^ SPECIALTY ^ SC (1/0) ^ DRG ^ PROVIDER
  1. ; TMP($J,"IBDX","D", DISCHARGE DATE, x) = DIAGNOSIS ^ SC? (1/0) ^ POA
  1. ;
  1. ; TMP($J,"IBDX","M")=PTF # ^ ADMIT DATE ^ DISCHARGE DATE
  1. ; TMP($J,"IBDX","M", MOVEMENT DATE) = MOVEMENT DATE ^ SPECIALTY ^ SC (1/0) ^ DRG ^ PROVIDER
  1. ; TMP($J,"IBDX","M", MOVEMENT DATE, x) = DIAGNOSIS ^ SC? (1/0) ^ POA
  1. ; if patient not discharged then NOW is used as date subscript and first piece will be null, SC?=interpreted SC
  1. ;
  1. N IBSTAY,IBMI,IBM0,IBDT,IBMDT,IBMBS,IBMP,IBMDRG,IBMPRV,IBMSC,IBMDX,IBD0,IBDDT,IBDBS,IBDDRG,IBDPRV,IBDSC,IBDDX
  1. N IBCNT,IBI,IBTMP,DFN,DGVAR,DRG,DRGCAL,ICDCAL,PTF,PTFCOD K ^TMP($J,"IBDX","M"),^TMP($J,"IBDX","D") Q:'$G(IBPTF)
  1. ;
  1. S IBSTAY=IBPTF_U_$P($G(^DGPT(IBPTF,0)),U,2)_U_$P($G(^DGPT(IBPTF,70)),U,1) Q:'$P(IBSTAY,U,2)
  1. ;
  1. ; collect PTF Movement Diagnosis (501)
  1. S ^TMP($J,"IBDX","M")=IBSTAY
  1. S IBMI=0 F S IBMI=$O(^DGPT(IBPTF,"M",IBMI)) Q:'IBMI D
  1. . S IBM0=$G(^DGPT(IBPTF,"M",IBMI,0)) Q:'IBM0
  1. . S (IBDT,IBMDT)=$P(IBM0,U,10) I 'IBDT S IBDT=$$NOW^XLFDT
  1. . S IBMBS=$P(IBM0,U,2),IBMSC=$P(IBM0,U,18),IBMSC=$S(IBMSC=1:1,1:"")
  1. . S IBMP=$G(^DGPT(IBPTF,"M",IBMI,"P")),IBMPRV=$P(IBMP,U,5),IBMDRG=$$MVDRG^IBCRBG(IBPTF,IBMI)
  1. . ;
  1. . S ^TMP($J,"IBDX","M",IBDT)=IBMDT_U_IBMBS_U_IBMSC_U_IBMDRG_U_IBMPRV
  1. . ;
  1. . D PTFCDS(IBPTF,501,IBMI,.PTFCOD) D K PTFCOD ; get movements diagnosis
  1. .. S IBCNT=0,IBI="" F S IBI=$O(PTFCOD(IBI)) Q:IBI="" S IBMDX=PTFCOD(IBI) I +IBMDX S IBCNT=IBCNT+1 D
  1. ... S ^TMP($J,"IBDX","M",IBDT,IBCNT)=+IBMDX_U_U_$P(IBMDX,U,2),IBTMP("DXSC",+IBMDX,+IBMSC,IBCNT)=""
  1. ;
  1. ; collect PTF Discharge Diagnosis (701)
  1. S ^TMP($J,"IBDX","D")=IBSTAY
  1. S IBD0=$G(^DGPT(IBPTF,70)),IBDPRV=$P(IBD0,U,15),IBDDRG=$$PTFDDRG(IBPTF)
  1. S (IBDT,IBDDT)=$P(IBD0,U,1) I 'IBDT S IBDT=$$NOW^XLFDT
  1. S IBDBS=$P(IBD0,U,2),IBDSC=$P(IBD0,U,25),IBDSC=$S(IBDSC=1:1,1:"")
  1. ;
  1. S ^TMP($J,"IBDX","D",IBDT)=IBDDT_U_IBDBS_U_IBDSC_U_IBDDRG_U_IBDPRV
  1. ;
  1. D PTFCDS(IBPTF,701,,.PTFCOD) D K PTFCOD ; get discharge diagnosis
  1. . S IBCNT=0,IBI="" F S IBI=$O(PTFCOD(IBI)) Q:IBI="" S IBDDX=PTFCOD(IBI) I +IBDDX S IBCNT=IBCNT+1 D
  1. .. S ^TMP($J,"IBDX","D",IBDT,IBCNT)=+IBDDX_U_U_$P(IBDDX,U,2)
  1. ;
  1. ; Try to assign SC to PTF Diagnosis
  1. ;
  1. ; assign SC to Movement Diagnosis (501): if movement is SC or first Dx on an SC movement
  1. S IBMDT=0 F S IBMDT=$O(^TMP($J,"IBDX","M",IBMDT)) Q:'IBMDT D
  1. . S IBI="" F S IBI=$O(^TMP($J,"IBDX","M",IBMDT,IBI)) Q:'IBI D
  1. .. S IBMDX=+$G(^TMP($J,"IBDX","M",IBMDT,IBI)) Q:'IBMDX
  1. .. ;
  1. .. S IBMSC=+$P($G(^TMP($J,"IBDX","M",IBMDT)),U,3) ; sc move
  1. .. I 'IBMSC,$D(IBTMP("DXSC",IBMDX,1,1)) S IBMSC=1 ; first dx on sc move
  1. .. ;
  1. .. I +IBMSC S $P(^TMP($J,"IBDX","M",IBMDT,IBI),U,2)=1
  1. ;
  1. ; assign SC to Discharge Diagnosis (701): if stay is SC or first Dx on an SC movement or only on SC movement
  1. S IBDDT=0 F S IBDDT=$O(^TMP($J,"IBDX","D",IBDDT)) Q:'IBDDT D
  1. . S IBI="" F S IBI=$O(^TMP($J,"IBDX","D",IBDDT,IBI)) Q:'IBI D
  1. .. S IBDDX=+$G(^TMP($J,"IBDX","D",IBDDT,IBI)) Q:'IBDDX
  1. .. ;
  1. .. S IBDSC=+$P($G(^TMP($J,"IBDX","D",IBDDT)),U,3) ; sc stay
  1. .. I 'IBDSC,$D(IBTMP("DXSC",IBDDX,1,1)) S IBDSC=1 ; first dx on sc move
  1. .. I 'IBDSC,+$O(IBTMP("DXSC",IBDDX,"")) S IBDSC=1 ; on sc move only
  1. .. ;
  1. .. I +IBDSC S $P(^TMP($J,"IBDX","D",IBDDT,IBI),U,2)=1
  1. ;
  1. Q
  1. ;
  1. SETPOA(IBIFN) ; get POAs from file 19640.1 and put them into file 362.3
  1. N DIAG,DIEN,IBPTF,IEN362,ORDER,POASET
  1. ; ICD-9 only, beginning with ICD-10 DSS will pass POA to PTF
  1. I $$BDATE^IBACSV(IBIFN)'<$$CSVDATE^IBACSV(30) Q
  1. ; get PTF ien
  1. S IBPTF=$P($G(^DGCR(399,IBIFN,0)),U,8) Q:IBPTF=""
  1. ; loop through all entries in 19640.1 for this PTF
  1. S DIEN="" F S DIEN=$O(^DSIPPOA("B",IBPTF,DIEN)) Q:DIEN="" D
  1. .S DIAG=$P($G(^DSIPPOA(DIEN,0)),U,3) Q:DIAG=""
  1. .; loop through all DXes in 362.3 for this claim and try to find a match for 19640.1 entry
  1. .S POASET=0,ORDER="" F S ORDER=$O(^IBA(362.3,"AO",IBIFN,ORDER)) Q:ORDER=""!(POASET=1) D
  1. ..S IEN362=$O(^IBA(362.3,"AO",IBIFN,ORDER,""))
  1. ..; if DX in 362.3 matches DX in 19640.1, put proper POA indicator into 362.3 and bail out
  1. ..; ib*2.0*547 IB no longer uses POA of 1, should be null
  1. ..;I DIAG=$P($G(^IBA(362.3,IEN362,0)),U) S $P(^IBA(362.3,IEN362,0),U,4)=$P(^DSIPPOA(DIEN,0),U,4),POASET=1
  1. ..I DIAG=$P($G(^IBA(362.3,IEN362,0)),U) S $P(^IBA(362.3,IEN362,0),U,4)=$S($P(^DSIPPOA(DIEN,0),U,4)=1:"",1:$P(^DSIPPOA(DIEN,0),U,4)),POASET=1
  1. ..Q
  1. .Q
  1. Q
  1. ;
  1. MAXECODE(IBIFN) ; returns 1 if there are already 3 Ecode diagnoses on the claim, 0 otherwise
  1. N IBDATE,IBDX,CNT
  1. Q:'IBIFN 0
  1. S CNT=0,IBDX="",IBDATE=$$BDATE^IBACSV(IBIFN)
  1. F S IBDX=$O(^IBA(362.3,"AIFN"_IBIFN,IBDX)) Q:'IBDX I $E($$ICD9^IBACSV(IBDX,IBDATE))="E" S CNT=CNT+1
  1. Q CNT>2
  1. ;
  1. ;
  1. PTFDDRG(PTF) ; Returns PTF Discharge DRG (#45, 9) calculated field (clean up DG and ICD variables)
  1. N IBI,DFN,DGDAT,DGPMAN,DGPMCA,DGPTDAT,DGPTTMP,DGTMP,DGVAR,DRG,DRGCAL,EFFDATE
  1. N ICD10ORNIT,ICD10ORT,ICD10SDT,ICDCAL,ICDCDSY,ICDCSYS,ICDDATE,ICDDA,ICDIEN,ICDPOA,ICDRG,ICDTMP,ICDX,IMPDATE
  1. ;
  1. S IBI="" I +$G(PTF) S IBI=$$GET1^DIQ(45,PTF,9,"")
  1. Q IBI
  1. ;
  1. PTFCDS(PTF,TYPE,NODE,PTFARR) ; Get PTF Diagnosis (501, 701) and PTF ICD Procedures (401, 601) Codes DBIA ICR #6130
  1. ; returns codes for a single event: Discharge, one Movement, one Procedure or one Surgery
  1. ; Input: PTF #, TYPE: 701, 501, 401, 601, NODE: subfile IEN requested (501, 401, 601)
  1. ; Output: PTFARR returned array of Diagnosis or Procedure codes found for event, pass by reference
  1. ; PTFARR(x) = Dx IEN ^ POA ^ ... for 701 and 501, PTFARR(x) = ICD Prc IEN ^ ... for 401 and 601
  1. ;
  1. N DGPMAN,DGPMCA K PTFARR S PTFARR=0 Q:'$G(PTF)
  1. S TYPE=$G(TYPE) I TYPE'=401,TYPE'=501,TYPE'=601,TYPE'=701 Q
  1. S NODE=$G(NODE) I TYPE'=701,'NODE Q
  1. ;
  1. D PTFICD^DGPTFUT(TYPE,PTF,NODE,.PTFARR)
  1. Q