- IBCSC4F ;ALB/ARH - GET PTF DIAGNOSIS ;10-OCT-1998
- ;;2.0;INTEGRATED BILLING;**106,403,400,522,547**;21-MAR-94;Build 119
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- PTFDXDT(IBPTF,IBDT1,IBDT2,TF) ; collect PTF Transfer (501) and Discharge (701) movements and diagnosis within a date range
- ; if end date is before Discharge date delete Discharge Diagnosis
- ; if bill is an interim first or interim continuous then the last date on the bill is included in the bill
- N IBSTAY,IBADM,IBDSCH,IBDT,IBLAST,IBMDT K ^TMP($J,"IBDX","D"),^TMP($J,"IBDX","M") Q:'$G(IBPTF)
- S IBDT1=+$G(IBDT1)\1 Q:IBDT1'?7N S IBDT2=+$G(IBDT2)\1 Q:IBDT2'?7N
- ;
- D PTFDX(IBPTF)
- ;
- S IBSTAY=$G(^TMP($J,"IBDX","M")),IBADM=+$P($P(IBSTAY,U,2),".",1),IBDSCH=+$P($P(IBSTAY,U,3),".",1)
- ;
- I IBADM=IBDSCH Q ; 1 day stay, accept all
- I IBDT1=IBADM,IBDT2=IBDSCH Q ; bill for entire length of stay, accept all
- ;
- I IBDT2<IBDSCH K ^TMP($J,"IBDX","D") ; discharge date not on bill, exclude 701 Dxs
- I 'IBDSCH,IBDT2<DT K ^TMP($J,"IBDX","D") ; not discharged, current end date (today) not on bill, exclude 701 Dxs
- ;
- ; determine which of the movements should be included based on dates and timeframe
- S TF=$G(TF) I (TF=2)!(TF=3) S IBDT2=$$FMADD^XLFDT(IBDT2,1) ; if first or continuous bill include end date
- ;
- S (IBLAST,IBDT)="" F S IBDT=$O(^TMP($J,"IBDX","M",IBDT)) Q:'IBDT D S IBLAST=IBDT
- . S IBMDT=$P(IBDT,".",1)
- . I IBMDT'>IBDT1 K ^TMP($J,"IBDX","M",IBDT)
- . I IBLAST>IBDT2 K ^TMP($J,"IBDX","M",IBDT)
- Q
- ;
- PTFDX(IBPTF) ; collect all PTF Transfer (501) and Discharge (701) movements and diagnosis and try to assign SC
- ; PTF movements are assigned SC or NSC but diagnosis are not
- ; this routine 'interprets' this PTF data and 'assigns' SC/NSC to individual Diagnosis
- ; Movement (501) Diagnosis: all Dx on SC movements are assigned SC
- ; a Dx on an NSC movement that is also the first Dx on an SC move is assigned SC
- ; Discharge (701) Diagnosis: if admit is for SC care all discharge Dx are assigned SC
- ; if the Dx is also the first Dx on an SC movement then is assigned SC
- ; a Dx on an SC movement only is assigned SC
- ;
- ; Output: TMP($J,"IBDX","D")=PTF # ^ ADMIT DATE ^ DISCHARGE DATE
- ; TMP($J,"IBDX","D", DISCHARGE DATE) = DISCHARGE DATE ^ SPECIALTY ^ SC (1/0) ^ DRG ^ PROVIDER
- ; TMP($J,"IBDX","D", DISCHARGE DATE, x) = DIAGNOSIS ^ SC? (1/0) ^ POA
- ;
- ; TMP($J,"IBDX","M")=PTF # ^ ADMIT DATE ^ DISCHARGE DATE
- ; TMP($J,"IBDX","M", MOVEMENT DATE) = MOVEMENT DATE ^ SPECIALTY ^ SC (1/0) ^ DRG ^ PROVIDER
- ; TMP($J,"IBDX","M", MOVEMENT DATE, x) = DIAGNOSIS ^ SC? (1/0) ^ POA
- ; if patient not discharged then NOW is used as date subscript and first piece will be null, SC?=interpreted SC
- ;
- N IBSTAY,IBMI,IBM0,IBDT,IBMDT,IBMBS,IBMP,IBMDRG,IBMPRV,IBMSC,IBMDX,IBD0,IBDDT,IBDBS,IBDDRG,IBDPRV,IBDSC,IBDDX
- N IBCNT,IBI,IBTMP,DFN,DGVAR,DRG,DRGCAL,ICDCAL,PTF,PTFCOD K ^TMP($J,"IBDX","M"),^TMP($J,"IBDX","D") Q:'$G(IBPTF)
- ;
- S IBSTAY=IBPTF_U_$P($G(^DGPT(IBPTF,0)),U,2)_U_$P($G(^DGPT(IBPTF,70)),U,1) Q:'$P(IBSTAY,U,2)
- ;
- ; collect PTF Movement Diagnosis (501)
- S ^TMP($J,"IBDX","M")=IBSTAY
- S IBMI=0 F S IBMI=$O(^DGPT(IBPTF,"M",IBMI)) Q:'IBMI D
- . S IBM0=$G(^DGPT(IBPTF,"M",IBMI,0)) Q:'IBM0
- . S (IBDT,IBMDT)=$P(IBM0,U,10) I 'IBDT S IBDT=$$NOW^XLFDT
- . S IBMBS=$P(IBM0,U,2),IBMSC=$P(IBM0,U,18),IBMSC=$S(IBMSC=1:1,1:"")
- . S IBMP=$G(^DGPT(IBPTF,"M",IBMI,"P")),IBMPRV=$P(IBMP,U,5),IBMDRG=$$MVDRG^IBCRBG(IBPTF,IBMI)
- . ;
- . S ^TMP($J,"IBDX","M",IBDT)=IBMDT_U_IBMBS_U_IBMSC_U_IBMDRG_U_IBMPRV
- . ;
- . D PTFCDS(IBPTF,501,IBMI,.PTFCOD) D K PTFCOD ; get movements diagnosis
- .. S IBCNT=0,IBI="" F S IBI=$O(PTFCOD(IBI)) Q:IBI="" S IBMDX=PTFCOD(IBI) I +IBMDX S IBCNT=IBCNT+1 D
- ... S ^TMP($J,"IBDX","M",IBDT,IBCNT)=+IBMDX_U_U_$P(IBMDX,U,2),IBTMP("DXSC",+IBMDX,+IBMSC,IBCNT)=""
- ;
- ; collect PTF Discharge Diagnosis (701)
- S ^TMP($J,"IBDX","D")=IBSTAY
- S IBD0=$G(^DGPT(IBPTF,70)),IBDPRV=$P(IBD0,U,15),IBDDRG=$$PTFDDRG(IBPTF)
- S (IBDT,IBDDT)=$P(IBD0,U,1) I 'IBDT S IBDT=$$NOW^XLFDT
- S IBDBS=$P(IBD0,U,2),IBDSC=$P(IBD0,U,25),IBDSC=$S(IBDSC=1:1,1:"")
- ;
- S ^TMP($J,"IBDX","D",IBDT)=IBDDT_U_IBDBS_U_IBDSC_U_IBDDRG_U_IBDPRV
- ;
- D PTFCDS(IBPTF,701,,.PTFCOD) D K PTFCOD ; get discharge diagnosis
- . S IBCNT=0,IBI="" F S IBI=$O(PTFCOD(IBI)) Q:IBI="" S IBDDX=PTFCOD(IBI) I +IBDDX S IBCNT=IBCNT+1 D
- .. S ^TMP($J,"IBDX","D",IBDT,IBCNT)=+IBDDX_U_U_$P(IBDDX,U,2)
- ;
- ; Try to assign SC to PTF Diagnosis
- ;
- ; assign SC to Movement Diagnosis (501): if movement is SC or first Dx on an SC movement
- S IBMDT=0 F S IBMDT=$O(^TMP($J,"IBDX","M",IBMDT)) Q:'IBMDT D
- . S IBI="" F S IBI=$O(^TMP($J,"IBDX","M",IBMDT,IBI)) Q:'IBI D
- .. S IBMDX=+$G(^TMP($J,"IBDX","M",IBMDT,IBI)) Q:'IBMDX
- .. ;
- .. S IBMSC=+$P($G(^TMP($J,"IBDX","M",IBMDT)),U,3) ; sc move
- .. I 'IBMSC,$D(IBTMP("DXSC",IBMDX,1,1)) S IBMSC=1 ; first dx on sc move
- .. ;
- .. I +IBMSC S $P(^TMP($J,"IBDX","M",IBMDT,IBI),U,2)=1
- ;
- ; assign SC to Discharge Diagnosis (701): if stay is SC or first Dx on an SC movement or only on SC movement
- S IBDDT=0 F S IBDDT=$O(^TMP($J,"IBDX","D",IBDDT)) Q:'IBDDT D
- . S IBI="" F S IBI=$O(^TMP($J,"IBDX","D",IBDDT,IBI)) Q:'IBI D
- .. S IBDDX=+$G(^TMP($J,"IBDX","D",IBDDT,IBI)) Q:'IBDDX
- .. ;
- .. S IBDSC=+$P($G(^TMP($J,"IBDX","D",IBDDT)),U,3) ; sc stay
- .. I 'IBDSC,$D(IBTMP("DXSC",IBDDX,1,1)) S IBDSC=1 ; first dx on sc move
- .. I 'IBDSC,+$O(IBTMP("DXSC",IBDDX,"")) S IBDSC=1 ; on sc move only
- .. ;
- .. I +IBDSC S $P(^TMP($J,"IBDX","D",IBDDT,IBI),U,2)=1
- ;
- Q
- ;
- SETPOA(IBIFN) ; get POAs from file 19640.1 and put them into file 362.3
- N DIAG,DIEN,IBPTF,IEN362,ORDER,POASET
- ; ICD-9 only, beginning with ICD-10 DSS will pass POA to PTF
- I $$BDATE^IBACSV(IBIFN)'<$$CSVDATE^IBACSV(30) Q
- ; get PTF ien
- S IBPTF=$P($G(^DGCR(399,IBIFN,0)),U,8) Q:IBPTF=""
- ; loop through all entries in 19640.1 for this PTF
- S DIEN="" F S DIEN=$O(^DSIPPOA("B",IBPTF,DIEN)) Q:DIEN="" D
- .S DIAG=$P($G(^DSIPPOA(DIEN,0)),U,3) Q:DIAG=""
- .; loop through all DXes in 362.3 for this claim and try to find a match for 19640.1 entry
- .S POASET=0,ORDER="" F S ORDER=$O(^IBA(362.3,"AO",IBIFN,ORDER)) Q:ORDER=""!(POASET=1) D
- ..S IEN362=$O(^IBA(362.3,"AO",IBIFN,ORDER,""))
- ..; if DX in 362.3 matches DX in 19640.1, put proper POA indicator into 362.3 and bail out
- ..; ib*2.0*547 IB no longer uses POA of 1, should be null
- ..;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
- ..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
- ..Q
- .Q
- Q
- ;
- MAXECODE(IBIFN) ; returns 1 if there are already 3 Ecode diagnoses on the claim, 0 otherwise
- N IBDATE,IBDX,CNT
- Q:'IBIFN 0
- S CNT=0,IBDX="",IBDATE=$$BDATE^IBACSV(IBIFN)
- F S IBDX=$O(^IBA(362.3,"AIFN"_IBIFN,IBDX)) Q:'IBDX I $E($$ICD9^IBACSV(IBDX,IBDATE))="E" S CNT=CNT+1
- Q CNT>2
- ;
- ;
- PTFDDRG(PTF) ; Returns PTF Discharge DRG (#45, 9) calculated field (clean up DG and ICD variables)
- N IBI,DFN,DGDAT,DGPMAN,DGPMCA,DGPTDAT,DGPTTMP,DGTMP,DGVAR,DRG,DRGCAL,EFFDATE
- N ICD10ORNIT,ICD10ORT,ICD10SDT,ICDCAL,ICDCDSY,ICDCSYS,ICDDATE,ICDDA,ICDIEN,ICDPOA,ICDRG,ICDTMP,ICDX,IMPDATE
- ;
- S IBI="" I +$G(PTF) S IBI=$$GET1^DIQ(45,PTF,9,"")
- Q IBI
- ;
- PTFCDS(PTF,TYPE,NODE,PTFARR) ; Get PTF Diagnosis (501, 701) and PTF ICD Procedures (401, 601) Codes DBIA ICR #6130
- ; returns codes for a single event: Discharge, one Movement, one Procedure or one Surgery
- ; Input: PTF #, TYPE: 701, 501, 401, 601, NODE: subfile IEN requested (501, 401, 601)
- ; Output: PTFARR returned array of Diagnosis or Procedure codes found for event, pass by reference
- ; PTFARR(x) = Dx IEN ^ POA ^ ... for 701 and 501, PTFARR(x) = ICD Prc IEN ^ ... for 401 and 601
- ;
- N DGPMAN,DGPMCA K PTFARR S PTFARR=0 Q:'$G(PTF)
- S TYPE=$G(TYPE) I TYPE'=401,TYPE'=501,TYPE'=601,TYPE'=701 Q
- S NODE=$G(NODE) I TYPE'=701,'NODE Q
- ;
- D PTFICD^DGPTFUT(TYPE,PTF,NODE,.PTFARR)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC4F 8157 printed Feb 18, 2025@23:46:42 Page 2
- IBCSC4F ;ALB/ARH - GET PTF DIAGNOSIS ;10-OCT-1998
- +1 ;;2.0;INTEGRATED BILLING;**106,403,400,522,547**;21-MAR-94;Build 119
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- 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
- +2 ; if bill is an interim first or interim continuous then the last date on the bill is included in the bill
- +3 NEW IBSTAY,IBADM,IBDSCH,IBDT,IBLAST,IBMDT
- KILL ^TMP($JOB,"IBDX","D"),^TMP($JOB,"IBDX","M")
- if '$GET(IBPTF)
- QUIT
- +4 SET IBDT1=+$GET(IBDT1)\1
- if IBDT1'?7N
- QUIT
- SET IBDT2=+$GET(IBDT2)\1
- if IBDT2'?7N
- QUIT
- +5 ;
- +6 DO PTFDX(IBPTF)
- +7 ;
- +8 SET IBSTAY=$GET(^TMP($JOB,"IBDX","M"))
- SET IBADM=+$PIECE($PIECE(IBSTAY,U,2),".",1)
- SET IBDSCH=+$PIECE($PIECE(IBSTAY,U,3),".",1)
- +9 ;
- +10 ; 1 day stay, accept all
- IF IBADM=IBDSCH
- QUIT
- +11 ; bill for entire length of stay, accept all
- IF IBDT1=IBADM
- IF IBDT2=IBDSCH
- QUIT
- +12 ;
- +13 ; discharge date not on bill, exclude 701 Dxs
- IF IBDT2<IBDSCH
- KILL ^TMP($JOB,"IBDX","D")
- +14 ; not discharged, current end date (today) not on bill, exclude 701 Dxs
- IF 'IBDSCH
- IF IBDT2<DT
- KILL ^TMP($JOB,"IBDX","D")
- +15 ;
- +16 ; determine which of the movements should be included based on dates and timeframe
- +17 ; if first or continuous bill include end date
- SET TF=$GET(TF)
- IF (TF=2)!(TF=3)
- SET IBDT2=$$FMADD^XLFDT(IBDT2,1)
- +18 ;
- +19 SET (IBLAST,IBDT)=""
- FOR
- SET IBDT=$ORDER(^TMP($JOB,"IBDX","M",IBDT))
- if 'IBDT
- QUIT
- Begin DoDot:1
- +20 SET IBMDT=$PIECE(IBDT,".",1)
- +21 IF IBMDT'>IBDT1
- KILL ^TMP($JOB,"IBDX","M",IBDT)
- +22 IF IBLAST>IBDT2
- KILL ^TMP($JOB,"IBDX","M",IBDT)
- End DoDot:1
- SET IBLAST=IBDT
- +23 QUIT
- +24 ;
- 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
- +2 ; this routine 'interprets' this PTF data and 'assigns' SC/NSC to individual Diagnosis
- +3 ; Movement (501) Diagnosis: all Dx on SC movements are assigned SC
- +4 ; a Dx on an NSC movement that is also the first Dx on an SC move is assigned SC
- +5 ; Discharge (701) Diagnosis: if admit is for SC care all discharge Dx are assigned SC
- +6 ; if the Dx is also the first Dx on an SC movement then is assigned SC
- +7 ; a Dx on an SC movement only is assigned SC
- +8 ;
- +9 ; Output: TMP($J,"IBDX","D")=PTF # ^ ADMIT DATE ^ DISCHARGE DATE
- +10 ; TMP($J,"IBDX","D", DISCHARGE DATE) = DISCHARGE DATE ^ SPECIALTY ^ SC (1/0) ^ DRG ^ PROVIDER
- +11 ; TMP($J,"IBDX","D", DISCHARGE DATE, x) = DIAGNOSIS ^ SC? (1/0) ^ POA
- +12 ;
- +13 ; TMP($J,"IBDX","M")=PTF # ^ ADMIT DATE ^ DISCHARGE DATE
- +14 ; TMP($J,"IBDX","M", MOVEMENT DATE) = MOVEMENT DATE ^ SPECIALTY ^ SC (1/0) ^ DRG ^ PROVIDER
- +15 ; TMP($J,"IBDX","M", MOVEMENT DATE, x) = DIAGNOSIS ^ SC? (1/0) ^ POA
- +16 ; if patient not discharged then NOW is used as date subscript and first piece will be null, SC?=interpreted SC
- +17 ;
- +18 NEW IBSTAY,IBMI,IBM0,IBDT,IBMDT,IBMBS,IBMP,IBMDRG,IBMPRV,IBMSC,IBMDX,IBD0,IBDDT,IBDBS,IBDDRG,IBDPRV,IBDSC,IBDDX
- +19 NEW IBCNT,IBI,IBTMP,DFN,DGVAR,DRG,DRGCAL,ICDCAL,PTF,PTFCOD
- KILL ^TMP($JOB,"IBDX","M"),^TMP($JOB,"IBDX","D")
- if '$GET(IBPTF)
- QUIT
- +20 ;
- +21 SET IBSTAY=IBPTF_U_$PIECE($GET(^DGPT(IBPTF,0)),U,2)_U_$PIECE($GET(^DGPT(IBPTF,70)),U,1)
- if '$PIECE(IBSTAY,U,2)
- QUIT
- +22 ;
- +23 ; collect PTF Movement Diagnosis (501)
- +24 SET ^TMP($JOB,"IBDX","M")=IBSTAY
- +25 SET IBMI=0
- FOR
- SET IBMI=$ORDER(^DGPT(IBPTF,"M",IBMI))
- if 'IBMI
- QUIT
- Begin DoDot:1
- +26 SET IBM0=$GET(^DGPT(IBPTF,"M",IBMI,0))
- if 'IBM0
- QUIT
- +27 SET (IBDT,IBMDT)=$PIECE(IBM0,U,10)
- IF 'IBDT
- SET IBDT=$$NOW^XLFDT
- +28 SET IBMBS=$PIECE(IBM0,U,2)
- SET IBMSC=$PIECE(IBM0,U,18)
- SET IBMSC=$SELECT(IBMSC=1:1,1:"")
- +29 SET IBMP=$GET(^DGPT(IBPTF,"M",IBMI,"P"))
- SET IBMPRV=$PIECE(IBMP,U,5)
- SET IBMDRG=$$MVDRG^IBCRBG(IBPTF,IBMI)
- +30 ;
- +31 SET ^TMP($JOB,"IBDX","M",IBDT)=IBMDT_U_IBMBS_U_IBMSC_U_IBMDRG_U_IBMPRV
- +32 ;
- +33 ; get movements diagnosis
- DO PTFCDS(IBPTF,501,IBMI,.PTFCOD)
- Begin DoDot:2
- +34 SET IBCNT=0
- SET IBI=""
- FOR
- SET IBI=$ORDER(PTFCOD(IBI))
- if IBI=""
- QUIT
- SET IBMDX=PTFCOD(IBI)
- IF +IBMDX
- SET IBCNT=IBCNT+1
- Begin DoDot:3
- +35 SET ^TMP($JOB,"IBDX","M",IBDT,IBCNT)=+IBMDX_U_U_$PIECE(IBMDX,U,2)
- SET IBTMP("DXSC",+IBMDX,+IBMSC,IBCNT)=""
- End DoDot:3
- End DoDot:2
- KILL PTFCOD
- End DoDot:1
- +36 ;
- +37 ; collect PTF Discharge Diagnosis (701)
- +38 SET ^TMP($JOB,"IBDX","D")=IBSTAY
- +39 SET IBD0=$GET(^DGPT(IBPTF,70))
- SET IBDPRV=$PIECE(IBD0,U,15)
- SET IBDDRG=$$PTFDDRG(IBPTF)
- +40 SET (IBDT,IBDDT)=$PIECE(IBD0,U,1)
- IF 'IBDT
- SET IBDT=$$NOW^XLFDT
- +41 SET IBDBS=$PIECE(IBD0,U,2)
- SET IBDSC=$PIECE(IBD0,U,25)
- SET IBDSC=$SELECT(IBDSC=1:1,1:"")
- +42 ;
- +43 SET ^TMP($JOB,"IBDX","D",IBDT)=IBDDT_U_IBDBS_U_IBDSC_U_IBDDRG_U_IBDPRV
- +44 ;
- +45 ; get discharge diagnosis
- DO PTFCDS(IBPTF,701,,.PTFCOD)
- Begin DoDot:1
- +46 SET IBCNT=0
- SET IBI=""
- FOR
- SET IBI=$ORDER(PTFCOD(IBI))
- if IBI=""
- QUIT
- SET IBDDX=PTFCOD(IBI)
- IF +IBDDX
- SET IBCNT=IBCNT+1
- Begin DoDot:2
- +47 SET ^TMP($JOB,"IBDX","D",IBDT,IBCNT)=+IBDDX_U_U_$PIECE(IBDDX,U,2)
- End DoDot:2
- End DoDot:1
- KILL PTFCOD
- +48 ;
- +49 ; Try to assign SC to PTF Diagnosis
- +50 ;
- +51 ; assign SC to Movement Diagnosis (501): if movement is SC or first Dx on an SC movement
- +52 SET IBMDT=0
- FOR
- SET IBMDT=$ORDER(^TMP($JOB,"IBDX","M",IBMDT))
- if 'IBMDT
- QUIT
- Begin DoDot:1
- +53 SET IBI=""
- FOR
- SET IBI=$ORDER(^TMP($JOB,"IBDX","M",IBMDT,IBI))
- if 'IBI
- QUIT
- Begin DoDot:2
- +54 SET IBMDX=+$GET(^TMP($JOB,"IBDX","M",IBMDT,IBI))
- if 'IBMDX
- QUIT
- +55 ;
- +56 ; sc move
- SET IBMSC=+$PIECE($GET(^TMP($JOB,"IBDX","M",IBMDT)),U,3)
- +57 ; first dx on sc move
- IF 'IBMSC
- IF $DATA(IBTMP("DXSC",IBMDX,1,1))
- SET IBMSC=1
- +58 ;
- +59 IF +IBMSC
- SET $PIECE(^TMP($JOB,"IBDX","M",IBMDT,IBI),U,2)=1
- End DoDot:2
- End DoDot:1
- +60 ;
- +61 ; assign SC to Discharge Diagnosis (701): if stay is SC or first Dx on an SC movement or only on SC movement
- +62 SET IBDDT=0
- FOR
- SET IBDDT=$ORDER(^TMP($JOB,"IBDX","D",IBDDT))
- if 'IBDDT
- QUIT
- Begin DoDot:1
- +63 SET IBI=""
- FOR
- SET IBI=$ORDER(^TMP($JOB,"IBDX","D",IBDDT,IBI))
- if 'IBI
- QUIT
- Begin DoDot:2
- +64 SET IBDDX=+$GET(^TMP($JOB,"IBDX","D",IBDDT,IBI))
- if 'IBDDX
- QUIT
- +65 ;
- +66 ; sc stay
- SET IBDSC=+$PIECE($GET(^TMP($JOB,"IBDX","D",IBDDT)),U,3)
- +67 ; first dx on sc move
- IF 'IBDSC
- IF $DATA(IBTMP("DXSC",IBDDX,1,1))
- SET IBDSC=1
- +68 ; on sc move only
- IF 'IBDSC
- IF +$ORDER(IBTMP("DXSC",IBDDX,""))
- SET IBDSC=1
- +69 ;
- +70 IF +IBDSC
- SET $PIECE(^TMP($JOB,"IBDX","D",IBDDT,IBI),U,2)=1
- End DoDot:2
- End DoDot:1
- +71 ;
- +72 QUIT
- +73 ;
- SETPOA(IBIFN) ; get POAs from file 19640.1 and put them into file 362.3
- +1 NEW DIAG,DIEN,IBPTF,IEN362,ORDER,POASET
- +2 ; ICD-9 only, beginning with ICD-10 DSS will pass POA to PTF
- +3 IF $$BDATE^IBACSV(IBIFN)'<$$CSVDATE^IBACSV(30)
- QUIT
- +4 ; get PTF ien
- +5 SET IBPTF=$PIECE($GET(^DGCR(399,IBIFN,0)),U,8)
- if IBPTF=""
- QUIT
- +6 ; loop through all entries in 19640.1 for this PTF
- +7 SET DIEN=""
- FOR
- SET DIEN=$ORDER(^DSIPPOA("B",IBPTF,DIEN))
- if DIEN=""
- QUIT
- Begin DoDot:1
- +8 SET DIAG=$PIECE($GET(^DSIPPOA(DIEN,0)),U,3)
- if DIAG=""
- QUIT
- +9 ; loop through all DXes in 362.3 for this claim and try to find a match for 19640.1 entry
- +10 SET POASET=0
- SET ORDER=""
- FOR
- SET ORDER=$ORDER(^IBA(362.3,"AO",IBIFN,ORDER))
- if ORDER=""!(POASET=1)
- QUIT
- Begin DoDot:2
- +11 SET IEN362=$ORDER(^IBA(362.3,"AO",IBIFN,ORDER,""))
- +12 ; if DX in 362.3 matches DX in 19640.1, put proper POA indicator into 362.3 and bail out
- +13 ; ib*2.0*547 IB no longer uses POA of 1, should be null
- +14 ;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
- +15 IF DIAG=$PIECE($GET(^IBA(362.3,IEN362,0)),U)
- SET $PIECE(^IBA(362.3,IEN362,0),U,4)=$SELECT($PIECE(^DSIPPOA(DIEN,0),U,4)=1:"",1:$PIECE(^DSIPPOA(DIEN,0),U,4))
- SET POASET=1
- +16 QUIT
- End DoDot:2
- +17 QUIT
- End DoDot:1
- +18 QUIT
- +19 ;
- MAXECODE(IBIFN) ; returns 1 if there are already 3 Ecode diagnoses on the claim, 0 otherwise
- +1 NEW IBDATE,IBDX,CNT
- +2 if 'IBIFN
- QUIT 0
- +3 SET CNT=0
- SET IBDX=""
- SET IBDATE=$$BDATE^IBACSV(IBIFN)
- +4 FOR
- SET IBDX=$ORDER(^IBA(362.3,"AIFN"_IBIFN,IBDX))
- if 'IBDX
- QUIT
- IF $EXTRACT($$ICD9^IBACSV(IBDX,IBDATE))="E"
- SET CNT=CNT+1
- +5 QUIT CNT>2
- +6 ;
- +7 ;
- PTFDDRG(PTF) ; Returns PTF Discharge DRG (#45, 9) calculated field (clean up DG and ICD variables)
- +1 NEW IBI,DFN,DGDAT,DGPMAN,DGPMCA,DGPTDAT,DGPTTMP,DGTMP,DGVAR,DRG,DRGCAL,EFFDATE
- +2 NEW ICD10ORNIT,ICD10ORT,ICD10SDT,ICDCAL,ICDCDSY,ICDCSYS,ICDDATE,ICDDA,ICDIEN,ICDPOA,ICDRG,ICDTMP,ICDX,IMPDATE
- +3 ;
- +4 SET IBI=""
- IF +$GET(PTF)
- SET IBI=$$GET1^DIQ(45,PTF,9,"")
- +5 QUIT IBI
- +6 ;
- 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
- +2 ; Input: PTF #, TYPE: 701, 501, 401, 601, NODE: subfile IEN requested (501, 401, 601)
- +3 ; Output: PTFARR returned array of Diagnosis or Procedure codes found for event, pass by reference
- +4 ; PTFARR(x) = Dx IEN ^ POA ^ ... for 701 and 501, PTFARR(x) = ICD Prc IEN ^ ... for 401 and 601
- +5 ;
- +6 NEW DGPMAN,DGPMCA
- KILL PTFARR
- SET PTFARR=0
- if '$GET(PTF)
- QUIT
- +7 SET TYPE=$GET(TYPE)
- IF TYPE'=401
- IF TYPE'=501
- IF TYPE'=601
- IF TYPE'=701
- QUIT
- +8 SET NODE=$GET(NODE)
- IF TYPE'=701
- IF 'NODE
- QUIT
- +9 ;
- +10 DO PTFICD^DGPTFUT(TYPE,PTF,NODE,.PTFARR)
- +11 QUIT