source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC4F.m@ 1154

Last change on this file since 1154 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.2 KB
Line 
1IBCSC4F ;ALB/ARH - GET PTF DIAGNOSIS ; 10-OCT-1998
2 ;;2.0;INTEGRATED BILLING;**106**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5PTFDXDT(IBPTF,IBDT1,IBDT2,TF) ; collect PTF Transfer (501) and Discharge (701) movements and diagnosis within a date range
6 ; if end date is before Discharge date delete Discharge Diagnosis
7 ; if bill is an interim first or interim continuous then the last date on the bill is included in the bill
8 N IBSTAY,IBADM,IBDSCH,IBDT,IBLAST,IBMDT K ^TMP($J,"IBDX","D"),^TMP($J,"IBDX","M") Q:'$G(IBPTF)
9 S IBDT1=+$G(IBDT1)\1 Q:IBDT1'?7N S IBDT2=+$G(IBDT2)\1 Q:IBDT2'?7N
10 ;
11 D PTFDX(IBPTF)
12 ;
13 S IBSTAY=$G(^TMP($J,"IBDX","M")),IBADM=+$P($P(IBSTAY,U,2),".",1),IBDSCH=+$P($P(IBSTAY,U,3),".",1)
14 ;
15 I IBADM=IBDSCH Q ; 1 day stay, accept all
16 I IBDT1=IBADM,IBDT2=IBDSCH Q ; bill for entire length of stay, accept all
17 ;
18 I IBDT2<IBDSCH K ^TMP($J,"IBDX","D") ; discharge date not on bill, exclude 701 Dxs
19 I 'IBDSCH,IBDT2<DT K ^TMP($J,"IBDX","D") ; not discharged, current end date (today) not on bill, exclude 701 Dxs
20 ;
21 ; determine which of the movements should be included based on dates and timeframe
22 S TF=$G(TF) I (TF=2)!(TF=3) S IBDT2=$$FMADD^XLFDT(IBDT2,1) ; if first or continuous bill include end date
23 ;
24 S (IBLAST,IBDT)="" F S IBDT=$O(^TMP($J,"IBDX","M",IBDT)) Q:'IBDT D S IBLAST=IBDT
25 . S IBMDT=$P(IBDT,".",1)
26 . I IBMDT'>IBDT1 K ^TMP($J,"IBDX","M",IBDT)
27 . I IBLAST>IBDT2 K ^TMP($J,"IBDX","M",IBDT)
28 Q
29 ;
30PTFDX(IBPTF) ; collect all PTF Transfer (501) and Discharge (701) movements and diagnosis and try to assign SC
31 ; PTF movements are assigned SC or NSC but diagnosis are not
32 ; this routine 'interprets' this PTF data and 'assigns' SC/NSC to individual Diagnosis
33 ; Movement (501) Diagnosis: all Dx on SC movements are assigned SC
34 ; a Dx on an NSC movement that is also the first Dx on an SC move is assigned SC
35 ; Discharge (701) Diagnosis: if admit is for SC care all discharge Dx are assigned SC
36 ; if the Dx is also the first Dx on an SC movement then is assigned SC
37 ; a Dx on an SC movement only is assigned SC
38 ;
39 ; Output: TMP($J,"IBDX","D")=PTF # ^ ADMIT DATE ^ DISCHARGE DATE
40 ; TMP($J,"IBDX","D", DISCHARGE DATE) = DISCHARGE DATE ^ SPECIALTY ^ SC (1/0) ^ DRG ^ PROVIDER
41 ; TMP($J,"IBDX","D", DISCHARGE DATE, x) = DIAGNOSIS ^ SC? (1/0)
42 ;
43 ; TMP($J,"IBDX","M")=PTF # ^ ADMIT DATE ^ DISCHARGE DATE
44 ; TMP($J,"IBDX","M", MOVEMENT DATE) = MOVEMENT DATE ^ SPECIALTY ^ SC (1/0) ^ DRG ^ PROVIDER
45 ; TMP($J,"IBDX","M", MOVEMENT DATE, x) = DIAGNOSIS ^ SC? (1/0)
46 ; if patient not discharged then NOW is used as date subscript and first piece will be null, SC?=interpreted SC
47 ;
48 N IBSTAY,IBMI,IBM0,IBDT,IBMDT,IBMBS,IBMP,IBMDRG,IBMPRV,IBMSC,IBMDX,IBD0,IBDDT,IBDBS,IBDDRG,IBDPRV,IBDSC,IBDDX
49 N IBCNT,IBI,IBTMP,DFN,DGVAR,DRG,DRGCAL,ICDCAL,PTF K ^TMP($J,"IBDX","M"),^TMP($J,"IBDX","D") Q:'$G(IBPTF)
50 ;
51 S IBSTAY=IBPTF_U_$P($G(^DGPT(IBPTF,0)),U,2)_U_$P($G(^DGPT(IBPTF,70)),U,1) Q:'$P(IBSTAY,U,2)
52 ;
53 ; collect PTF Movement Diagnosis (501)
54 S ^TMP($J,"IBDX","M")=IBSTAY
55 S IBMI=0 F S IBMI=$O(^DGPT(IBPTF,"M",IBMI)) Q:'IBMI D
56 . S IBM0=$G(^DGPT(IBPTF,"M",IBMI,0)) Q:'IBM0
57 . S (IBDT,IBMDT)=$P(IBM0,U,10) I 'IBDT S IBDT=$$NOW^XLFDT
58 . S IBMBS=$P(IBM0,U,2),IBMSC=$P(IBM0,U,18),IBMSC=$S(IBMSC=1:1,1:"")
59 . S IBMP=$G(^DGPT(IBPTF,"M",IBMI,"P")),IBMPRV=$P(IBMP,U,5),IBMDRG=$$MVDRG^IBCRBG(IBPTF,IBMI)
60 . ;
61 . S ^TMP($J,"IBDX","M",IBDT)=IBMDT_U_IBMBS_U_IBMSC_U_IBMDRG_U_IBMPRV
62 . ;
63 . S IBCNT=0 F IBI=5:1:9 S IBMDX=+$P(IBM0,U,IBI) I +IBMDX S IBCNT=IBCNT+1 D
64 .. S ^TMP($J,"IBDX","M",IBDT,IBCNT)=IBMDX,IBTMP("DXSC",IBMDX,+IBMSC,IBCNT)=""
65 ;
66 ; collect PTF Discharge Diagnosis (701)
67 S ^TMP($J,"IBDX","D")=IBSTAY
68 S IBD0=$G(^DGPT(IBPTF,70)),IBDDRG=$$GET1^DIQ(45,IBPTF,9,""),IBDPRV=$P(IBD0,U,15)
69 S (IBDT,IBDDT)=$P(IBD0,U,1) I 'IBDT S IBDT=$$NOW^XLFDT
70 S IBDBS=$P(IBD0,U,2),IBDSC=$P(IBD0,U,25),IBDSC=$S(IBDSC=1:1,1:"")
71 ;
72 S ^TMP($J,"IBDX","D",IBDT)=IBDDT_U_IBDBS_U_IBDSC_U_IBDDRG_U_IBDPRV
73 ;
74 S IBCNT=0 F IBI=10,16:1:24 S IBDDX=+$P(IBD0,U,IBI) I +IBDDX S IBCNT=IBCNT+1 D
75 . S ^TMP($J,"IBDX","D",IBDT,IBCNT)=IBDDX
76 ;
77 ; Try to assign SC to PTF Diagnosis
78 ;
79 ; assign SC to Movement Diagnosis (501): if movement is SC or first Dx on an SC movement
80 S IBMDT=0 F S IBMDT=$O(^TMP($J,"IBDX","M",IBMDT)) Q:'IBMDT D
81 . S IBI="" F S IBI=$O(^TMP($J,"IBDX","M",IBMDT,IBI)) Q:'IBI D
82 .. S IBMDX=+$G(^TMP($J,"IBDX","M",IBMDT,IBI)) Q:'IBMDX
83 .. ;
84 .. S IBMSC=+$P($G(^TMP($J,"IBDX","M",IBMDT)),U,3) ; sc move
85 .. I 'IBMSC,$D(IBTMP("DXSC",IBMDX,1,1)) S IBMSC=1 ; first dx on sc move
86 .. ;
87 .. I +IBMSC S $P(^TMP($J,"IBDX","M",IBMDT,IBI),U,2)=1
88 ;
89 ; assign SC to Discharge Diagnosis (701): if stay is SC or first Dx on an SC movement or only on SC movement
90 S IBDDT=0 F S IBDDT=$O(^TMP($J,"IBDX","D",IBDDT)) Q:'IBDDT D
91 . S IBI="" F S IBI=$O(^TMP($J,"IBDX","D",IBDDT,IBI)) Q:'IBI D
92 .. S IBDDX=+$G(^TMP($J,"IBDX","D",IBDDT,IBI)) Q:'IBDDX
93 .. ;
94 .. S IBDSC=+$P($G(^TMP($J,"IBDX","D",IBDDT)),U,3) ; sc stay
95 .. I 'IBDSC,$D(IBTMP("DXSC",IBDDX,1,1)) S IBDSC=1 ; first dx on sc move
96 .. I 'IBDSC,+$O(IBTMP("DXSC",IBDDX,"")) S IBDSC=1 ; on sc move only
97 .. ;
98 .. I +IBDSC S $P(^TMP($J,"IBDX","D",IBDDT,IBI),U,2)=1
99 ;
100 Q
Note: See TracBrowser for help on using the repository browser.