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

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1IBTRE6 ;ALB/AAS - CLAIMS TRACKING OUTPUT CLIN DATA ;2-SEP-1993
2 ;;2.0;INTEGRATED BILLING;**210**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ADMDIAG(IBTRN) ; -- output admitting diagnosis (inpatient)
6 ;
7 N IBRES,IBDX,X
8 S IBRES=""
9 I '$G(IBTRN) G ADMDQ
10 S IBETYP=$$TRTP^IBTRE1(IBTRN) I IBETYP>1 G ADMDQ
11 S IBDX=+$O(^IBT(356.9,"ADG",+$P(^IBT(356,+IBTRN,0),"^",5),0))
12 I $D(VAIN(9)) S IBRES=VAIN(9) G ADMDQ
13 N VAIN,VAINDT,VA200
14 S VAINDT=$P($G(^IBT(356,+IBTRN,0)),U,6)
15 S VA200="" D INP^VADPT
16 S IBRES=VAIN(9)
17ADMDQ Q IBRES
18 ;
19PDIAG(IBTRN) ; -- return primary diagnosis (inpatient)
20 N IBRES,IBDX
21 S IBRES=""
22 I '$G(IBTRN) G PDIAGQ
23 S IBDX=+$G(^IBT(356.9,+$O(^IBT(356.9,"ATP",+$P(^IBT(356,+IBTRN,0),"^",5),1,0)),0))
24 S IBRES=$$DIAG(IBDX,1,$$TRNDATE^IBACSV(IBTRN))
25PDIAGQ Q IBRES
26 ;
27SDIAG ; -- return secondary diagnosis (inpatient
28 Q
29 ;
30ODIAG ; -- return outpatient diagnosis
31 Q
32 ;
33DIAG(IBDX,IBTXT,IBDT) ; -- Expand diagnosis from pointer
34 ; -- input IBDX = pointer to diag
35 ; IBTXT = if want text added (zero = number only)
36 N IBRES,IBZ
37 I '$G(IBDX) Q ""
38 S IBZ=$$ICD9^IBACSV(+IBDX,$G(IBDT)) I IBZ="" Q ""
39 S IBRES=$P(IBZ,U)
40 I $G(IBTXT) S IBRES=IBRES_" - "_$P(IBZ,U,3)
41 Q IBRES
42 ;
43 ;
44APROV(IBTRN) ; -- return provider (inpatient)
45 ;
46 N X S X=""
47 I '$G(IBTRN) G APROVQ
48 S X=$O(^IBT(356.94,"ATP",+$P(^IBT(356,+IBTRN,0),"^",5),2,0)) I X S X=$P($G(^IBT(356.94,+X,0)),"^",3) G APROVQ
49 S X=+$O(^IBT(356.94,"ATP",+$P(^IBT(356,+IBTRN,0),"^",5),1,0)) I X S X=$P($G(^IBT(356.94,+X,0)),"^",3) G APROVQ
50 I $D(VAIN(2)) S X=VAIN(2) I 'X S X=$G(VAIN(11))
51 I '$D(VAIN(2)) D
52 .N VAIN,VAINDT
53 .S VAINDT=$P(^IBT(356,IBTRN,0),U,6)
54 .S VA200="" D INP^VADPT
55 .S X=VAIN(2)
56 .I 'X S X=VAIN(11)
57APROVQ Q $P($G(^VA(200,+X,0)),"^")
58 ;
59ATTEND ; -- return attendings (inpatient)
60 Q
61 ;
62PROV ; -- return providers (inpatient)
63 Q
64 ;
65OPROV ; -- returns outpatient providers
66 Q
67 ;
68PROC(IBPR,IBTXT) ; -- Expand procedure from pointer
69 ; input IBPR=proc^^date (format of ^IBT(356.91,IEN,0))
70 ; IBTXT = if want text added (zero = number only)
71 N IBRES,IBZ
72 I '$G(Z) S Z=1 ; what is that?
73 I '$G(IBPR) Q ""
74 S IBZ=$$ICD0^IBACSV(+IBPR,$P(IBPR,U,3))
75 S IBRES=$P(IBZ,U)
76 I $G(IBTXT),IBZ'="" S IBRES=IBRES_" - "_$P(IBZ,U,4)
77 Q IBRES
78 ;
79 ;
80OPROC ; -- outpatient procedures
81 Q
82 ;
83IPROC ; -- inpatient procedures
84 Q
85 ;
86LISTP(IBTRN,IBXY) ; -- return last y procedures for a tracking entry
87 ; -- input ibtrn = tracking file pointer
88 ; -- output array of procedure by date - ibxy(date)=procedure node
89 ;
90 N IBDGPM,IBDT,IBDA,IBX,IBCNT
91 S (IBX,IBDT)="",IBXY=0
92 I '$G(IBTRN) G LISTPQ
93 S IBDGPM=$P($G(^IBT(356,IBTRN,0)),"^",5)
94 Q:'IBDGPM
95 F S IBDT=$O(^IBT(356.91,"APP",IBDGPM,IBDT)) Q:'IBDT S IBDA="" F S IBDA=$O(^IBT(356.91,"APP",IBDGPM,IBDT,IBDA)) Q:'IBDA D
96 .S IBX(-IBDT,IBDA)=$G(^IBT(356.91,IBDA,0))
97 ;
98 S IBDT="" F S IBDT=$O(IBX(IBDT)) Q:'IBDT S IBDA=0 F S IBDA=$O(IBX(IBDT,IBDA)) Q:'IBDA D
99 .S IBXY=IBXY+1
100 .S IBXY(IBXY)=IBX(IBDT,IBDA)
101LISTPQ Q
102 ;
103LSTPDG(X,IBDT,Y) ; -- return current diagnosis for a tracking entry
104 ; -- input X = tracking file pointer
105 ; ibdt = date for current diagnosis (null = last)
106 ; y = 1= primary (default)
107 ; 2= secondary
108 ;
109 N IBY,IBX S (IBY,IBX)=""
110 I '$G(X) G LSTPDQ
111 S:'$G(IBDT) IBDT=DT S IBDT=-(IBDT+.9)
112 S:'$G(Y) Y=1 I Y'=1,Y'=2 S Y=1
113 F S IBDT=$O(^IBT(356.9,"APD",X,IBDT)) Q:'IBDT!($G(IBY)) S IBDA="" F S IBDA=$O(^IBT(356.9,"APD",X,IBDT,IBDA)) Q:'IBDA!($G(IBY)) D
114 .I $P(^IBT(356.9,IBDA,0),U,4)=Y S IBY=+^(0)
115LSTPDQ Q IBY
116 ;
117DTCHK(DA,X) ; -- input transform for 356.94;.01. date not before admission or after discharge
118 N IBTRN,IBOK,IBCDT
119 S IBOK=1
120 G:'DA!($G(X)<1) DTCHKQ
121 S IBTRN=+$O(^IBT(356,"AD",+$P(^IBT(356.94,DA,0),"^",2),0))
122 G:'IBTRN DTCHKQ
123 S IBCDT=$$CDT^IBTODD1(IBTRN)
124 I X<$P(+IBCDT,".") S IBOK=0 G DTCHKQ ;before adm
125 I $P(IBCDT,"^",2),X>$P(IBCDT,"^",2) S IBOK=0 G DTCHKQ ; after disch
126 I X>$$FMADD^XLFDT(DT,7) S IBOK=0 G DTCHKQ
127 ;
128DTCHKQ Q IBOK
Note: See TracBrowser for help on using the repository browser.