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 Oct 16, 2024@18:20:57 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
