source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAUTL3.m@ 1397

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1IBAUTL3 ;ALB/CPM-MEANS TEST BILLING UTILITIES (CON'T.) ; 05-SEP-91
2 ;;2.0;INTEGRATED BILLING;**176**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5DED ; Find Medicare deductible rate on the billing clock date.
6 ; Input: IBSERV, IBCLDT Output: IBMED - Medicare deductible
7 N X S IBMED=0
8 S X=$O(^IBE(350.1,"ANEW",IBSERV,81,0)) I 'X S IBY="-1^IB031" G DEDQ
9 S X=$O(^IBE(350.2,"AIVDT",+X,-(IBCLDT+.1))),X=$O(^(+X,0))
10 S IBMED=$P($G(^IBE(350.2,+X,0)),"^",4) I 'IBMED S IBY="-1^IB032"
11DEDQ Q
12 ;
13EVADD ; Add a new billable event in File #350.
14 ; Input: IBSITE, DFN, IBSL, IBEVDT, IBSERV, IBNH Output: IBEVDA
15 ; IBNHLTC (optional for LTC only)
16 D ADD^IBAUTL I Y<1 S IBY=Y G EVADDQ
17 N IBATYP,IBDESC
18 S IBEVDA=IBN
19 S IBATYP=$O(^IBE(350.1,"ANEW",IBSERV,$S($G(IBNHLTC):93,IBNH:92,1:91),0)) I 'IBATYP S IBY="-1^IB008" G EVADDQ
20 S IBDESC=$P($G(^IBE(350.1,+IBATYP,0)),"^")
21 S $P(^IB(IBN,0),"^",3,17)=IBATYP_"^"_IBSL_"^1^^^"_IBDESC_"^^^^^"_IBFAC_"^^^"_IBN_"^"_IBEVDT
22 D NOW^%DTC S $P(^IB(IBN,1),"^")=DUZ,$P(^(1),"^",3,4)=DUZ_"^"_%
23 S DIK="^IB(",DA=IBN D IX1^DIK
24EVADDQ K DIK,DA Q
25 ;
26EVFIND ; Find most recent active (incomplete - still being billed)
27 ; inpatient/NHCU event since original admission.
28 ; Input: DFN, IBADMDT Output: IBEVDT, IBEVDA, IBEVCAL
29 N IBD,J S IBD=IBADMDT\1,(IBEVDA,IBEVCAL,IBEVDT)=0,J=-DT
30 F S J=$O(^IB("AFDT",DFN,J)) Q:'J!(-J<IBD)!(IBEVDT) F S IBEVDA=$O(^IB("AFDT",DFN,J,IBEVDA)) Q:'IBEVDA I $P($G(^IB(IBEVDA,0)),"^",5)=1 S IBEVDT=-J,IBEVCAL=$P(^(0),"^",18) Q
31 Q
32 ;
33EVCLOS1 ; Set Last Calc date to yesterday before closing event. Input: IBDT
34 S X1=IBDT,X2=-1 D C^%DTC S IBEVCLD=X
35EVCLOSE ; Close event record. Input: IBEVDA, IBEVCLD
36 N IBDR S IBDR=".05////2;"
37EVUPD ; Update event record. Input: IBEVDA, IBEVCLD
38 S DR=".18////"_IBEVCLD_";13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"
39 I $D(IBDR) S DR=IBDR_DR
40 S DIE="^IB(",DA=IBEVDA D ^DIE K DIE,DA,DR Q
41 ;
42CLADD ; Add a new billing clock in File #351.
43 ; Input: IBSITE, DFN, IBCLDT, IBSERV Output: IBCLDA, IBMED
44 L +^IBE(351,0):10 E S IBY="-1^IB014" G CLADDQ
45 S X=$P($S($D(^IBE(351,0)):^(0),1:"^^-1"),"^",3)+1 I 'X S IBY="-1^IB015" G CLADDQ
46 K DD,DO,DIC,DR S DIC="^IBE(351,",DIC(0)="L",DLAYGO=351
47 F X=X:1 I X>0,'$D(^IBE(351,X)) L +^IBE(351,X):1 I $T,'$D(^IBE(351,X)) S DINUM=X,X=+IBSITE_X D FILE^DICN I +Y>0 Q
48 S (DA,IBCLDA)=+Y,DIE="^IBE(351,",DR=".02////"_DFN_";.03////"_IBCLDT_";.04////1;11////"_$S($D(DUZ):DUZ,1:.5)_";12///NOW;13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"
49 D ^DIE K DA,DR,DIE L -^IBE(351,IBCLDA)
50 S IBY=$S('$D(Y):1,1:"-1^IB028") D:IBY>0 DED
51CLADDQ L -^IBE(351,0) K DO,DD,DINUM,DIC Q
52 ;
53CLOCK ; Determine if the patient has an active billing clock.
54 ; Input: IBSERV Output: IBCLDA, IBCLDT, IBCLDAY, IBCLDOL
55 S IBCLDA=+$O(^IBE(351,"ACT",DFN,0))
56 D:IBCLDA CLDATA,DED Q
57 ;
58CLDATA ; Return data from the current billing clock.
59 N X S X=$G(^IBE(351,+IBCLDA,0)),IBCLDT=$P(X,"^",3),IBCLDAY=$P(X,"^",9)
60 S IBCLDOL=$P(X,"^",$S(IBCLDAY<91:5,IBCLDAY<181:6,IBCLDAY<271:7,1:8)) Q
61 ;
62CLOCKCL ; Close out the current billing clock.
63 ; Input: DFN, IBCLDA, IBCLDT; IBCLDOL, IBCLDAY {opt}
64 ; Output: IBCLDA=0
65 N IBCLENDT,K S K=$$BILST^DGMTUB(DFN)
66 S X1=IBCLDT,X2=364 D C^%DTC S IBCLENDT=X
67 I K S:K<IBCLENDT IBCLENDT=K
68 I $D(IBCLDOL),$D(IBCLDAY) D CLUPD
69 S DA=IBCLDA,DIE="^IBE(351,",DR=".04////2;.1////"_IBCLENDT_";13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"
70 D ^DIE K DA,DR,DIE S IBY=$S('$D(Y):1,1:"-1^IB028"),IBCLDA=0 Q
71 ;
72CLUPD ; - update billing clock. Input: IBCLDA, IBCLDOL, IBCLDAY
73 D NOW^%DTC
74 S $P(^IBE(351,IBCLDA,0),"^",$S(IBCLDAY<91:5,IBCLDAY<181:6,IBCLDAY<271:7,1:8))=IBCLDOL,$P(^(0),"^",9)=IBCLDAY,$P(^(1),"^",3,4)=$S($D(DUZ):DUZ,1:.5)_"^"_%
75 S DIK="^IBE(351,",DA=IBCLDA D IX1^DIK K DIK,DA Q
Note: See TracBrowser for help on using the repository browser.