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

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

initial load of WorldVistAEHR
File size: 3.2 KB
Line 
1IBJTU5 ;ALB/ARH - TPI UTILITIES - BILLS/CLAIMS TRACKING ; 2/14/95
2 ;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5IFNTRN(IBIFN,ARRAY,ARR2) ; find CT records for events on a bill: inpt adm, outpt vsts, rx refills, prosthetics
6 ; sets ARRAY=COUNT, ARRAY(IBTRN)="", if bill passed in defined
7 ; ARR2(DATE_TRN)=TRN
8 ;
9 N IBI,IBX,IBY,IBD0,DFN,IBTYP,IBTRN,IBDT,IBBDT,IBEDT,IBRX,IBRXN,IBPR,IBPRN,IBPM,IBPTF K ARRAY,ARR2
10 S ARRAY=0,IBD0=$G(^DGCR(399,+$G(IBIFN),0)) I IBD0="" G IFNQ
11 S DFN=$P(IBD0,U,2)
12 ;
13 ; -- directly linked through 356.399 (not always correct)
14 ;S IBI=0 F S IBI=$O(^IBT(356.399,"C",IBIFN,IBI)) Q:'IBI S IBX=+$G(^IBT(356.399,IBI,0)) I +IBX S ARRAY(+IBX)=""
15 ;
16 ; -- scheduled admissions (all on event date of inpatient bills)
17 S IBTYP=5 I $P(IBD0,U,5)<3 D
18 . S IBDT=$P(IBD0,U,3),IBBDT=$E(IBDT,1,7)-.00001,IBEDT=$E(IBDT,1,7)+.7
19 . F S IBBDT=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT)) Q:'IBBDT!(IBBDT>IBEDT) D
20 .. S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN)) Q:'IBTRN D
21 ... S ARRAY(IBTRN)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=IBTRN
22 ;
23 ; -- inpt admission (CT records on bill event date whose PM matches the bills PTF)
24 S IBTYP=1 S IBPTF=+$P(IBD0,U,8) I +IBPTF D
25 . S IBDT=$P(IBD0,U,3),IBBDT=$E(IBDT,1,7)-.00001,IBEDT=$E(IBDT,1,7)+.7
26 . F S IBBDT=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT)) Q:'IBBDT!(IBBDT>IBEDT) D
27 .. S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN)) Q:'IBTRN D
28 ... S IBPM=+$P($G(^IBT(356,IBTRN,0)),U,5) I +IBPM,$D(^DGPM("APTF",IBPTF,IBPM)) D
29 .... S ARRAY(IBTRN)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=IBTRN
30 ;
31 ; -- outpatient visits (all CT visits on bills's opt visit dates)
32 S IBTYP=2,IBDT=0 F S IBDT=$O(^DGCR(399,IBIFN,"OP",IBDT)) Q:'IBDT D
33 . S IBBDT=$E(IBDT,1,7)-.00001,IBEDT=$E(IBDT,1,7)+.7
34 . F S IBBDT=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT)) Q:'IBBDT!(IBBDT>IBEDT) D
35 .. S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN)) Q:'IBTRN D
36 ... S ARRAY(IBTRN)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=IBTRN
37 ;
38 ; -- rx refills (matches rx's (52: (362.4,.05)=(356,.08)) for refill dates on bill)
39 S IBTYP=4,IBI=0 F S IBI=$O(^IBA(362.4,"C",IBIFN,IBI)) Q:'IBI D
40 . S IBRX=$G(^IBA(362.4,IBI,0)),IBDT=$P(IBRX,U,3),IBRXN=$P(IBRX,U,5) Q:'IBRXN
41 . S IBBDT=$E(IBDT,1,7)-.00001,IBEDT=$E(IBDT,1,7)+.7
42 . F S IBBDT=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT)) Q:'IBBDT!(IBBDT>IBEDT) D
43 .. S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN)) Q:'IBTRN D
44 ... I $P($G(^IBT(356,IBTRN,0)),U,8)=IBRXN S ARRAY(IBTRN)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=IBTRN
45 ;
46 ; -- prosthetics (matches pd's (660: (362.5,.04)=(356,.09)) for delivery dates on bill)
47 S IBTYP=3,IBX="AIFN"_IBIFN,IBDT=0 F S IBDT=$O(^IBA(362.5,IBX,IBDT)) Q:'IBDT D
48 . S IBI=0 F S IBI=$O(^IBA(362.5,IBX,IBDT,IBI)) Q:'IBI D
49 .. S IBPR=$G(^IBA(362.5,IBI,0)),IBPRN=$P(IBPR,U,4) Q:'IBPRN
50 .. S IBBDT=$E(IBDT,1,7)-.00001,IBEDT=$E(IBDT,1,7)+.7
51 .. F S IBBDT=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT)) Q:'IBBDT!(IBBDT>IBEDT) D
52 ... S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN)) Q:'IBTRN D
53 .... I $P($G(^IBT(356,IBTRN,0)),U,9)=IBPRN S ARRAY(IBTRN)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=IBTRN
54 ;
55 S IBI=0 F S IBI=$O(ARRAY(IBI)) Q:'IBI S ARRAY=ARRAY+1
56IFNQ Q
Note: See TracBrowser for help on using the repository browser.