source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCA.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: 4.8 KB
Line 
1IBCA ;ALB/MRL - ADD NEW BILLING RECORD ;01 JUN 88 12:00
2 ;;2.0;INTEGRATED BILLING;**43,80,109,106,137,312**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;MAP TO DGCRA
6 ;
7 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
8 ;
9 D Q1 S IBCABRT=0,IOP="HOME" D ^%ZIS K IOP I $S('$D(DFN):1,'$D(^DPT(DFN,0)):1,1:0) S IBCABRT=1 G NREC
10 I $S('$D(^IBE(350.9,1,1)):1,'$P(^(1),U,14):1,1:0) S IBCABRT=4 G NREC
11 S PRCASV("SER")=$P(^IBE(350.9,1,1),U,14)
12 S PRCASV("SITE")=+$P($$SITE^VASITE,"^",3) I PRCASV("SITE")<1 S IBCABRT=5 G NREC
13 S IBNWBL="",IBQUIT=0 I '$D(DUZ(0)) S IBCABRT=2 G NREC
14 I $S($D(DLAYGO):2\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(399,0,"LAYGO")) S DLAYGO=399
15 ;I $S($D(DLAYGO):2\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(399,0,"LAYGO")) F I=1:1 I DUZ(0)[$E(^("LAYGO"),I) Q:I'>$L(^("LAYGO")) S IBCABRT=3 G NREC
16 ;
17CHKID D DEM^VADPT S DGDIR0="399,.04^399,.05^399,.06^399,155^399,151^399,152",DGDIRA="LOCATION OF CARE^EVENT INFORMATION SOURCE^TIMEFRAME^IS THIS A SENSITIVE RECORD?^STATEMENT COVERS FROM^STATEMENT COVERS TO"
18 S DGDIRB="1^^^NO"
19 F IBI=1:1:4 S:$P(DGDIRB,"^",IBI)]"" DIR("B")=$P(DGDIRB,"^",IBI) S DIR(0)=$P(DGDIR0,"^",IBI),DIR("A")=" BILLING "_$P(DGDIRA,"^",IBI) D READ G:IBQUIT NREC K DIR
20 S DIC="^DGCR(399.3,",DIC(0)="AEQMZ",DIC("A")=" BILLING RATE TYPE: ",DIC("S")="I '$P(^(0),U,3)" D ^DIC K DIC G NREC:Y'>0 S IBIDS(.07)=+Y,IBIDS(.11)=$P(^DGCR(399.3,+Y,0),"^",7)
21 ;
22OP G IP:IBIDS(.05)'>2 S %DT="EAX",%DT(0)="-NOW",%DT("A")=" BILLING OUTPATIENT EVENT DATE: " D ^%DT I Y'>0 G NREC
23 ;S X=Y D APPT^IBCU3
24 ; Do NOT PROCESS on VistA if Y >= Switch Eff Date ;CCR-930
25 I +IBSWINFO,(Y+1)>$P(IBSWINFO,"^",2) S IBCABRT=7 G NREC ;IB*2.0*312
26 ;
27 S X=$$APPT^IBCU3(Y,DFN,1)
28 S IBIDS(.03)=+Y X ^DD("DD") S DIR("B")=Y G CEOC
29 ;
30IP D DISPAD^IBCA0 G:'$D(IBIDS(.03)) NREC
31 ; Do NOT PROCESS on VistA if Date = Switch Eff Date ;CCR-930*312
32 I +IBSWINFO,(IBIDS(.03)+1)>$P(IBSWINFO,"^",2) S IBCABRT=7 G NREC ;P312
33 ;
34 I $D(IBDSDT) K:'IBDSDT IBDSDT S:$D(IBDSDT) IBDSDT=$P(IBDSDT,".")
35 S Y=$P(IBIDS(.03),".") X ^DD("DD") S DIR("B")=Y
36 ;
37CEOC S IBIDS(.27)="" I +$$BILLRATE^IBCRU3(IBIDS(.07),IBIDS(.05),IBIDS(.03),"RC") S IBIDS(.27)=1
38 S IBIDS(.22)=$P($G(^IBE(350.9,1,1)),"^",25)
39 I $G(IBIDS(.11))="i" N IBDTIN,IBCOVEXT S IBDTIN=$G(IBIDS(.03)),IBCOVEXT=1 W ! D DISPDT^IBCNS W !
40 W ! S X=$P(IBIDS(.03),".") D EN3^IBCA3 W ! S IBQUIT=0 ;show other bills this date
41 I IBIDS(.05)>2 S X=$$ADM^IBCU64(DFN,IBIDS(.03)) I +X W !,"Warning: Patient is an Inpatient on ",$$FMTE^XLFDT(IBIDS(.03),2),": ",$$FMTE^XLFDT(+X,2)," - " W:+$P(X,U,2) $$FMTE^XLFDT(+$P(X,U,2),2) W !
42 I +$G(IBIDS(.08)),+$P($G(^DGPT(+IBIDS(.08),70)),"^",2),$G(^DIC(42.4,+$P(^(70),"^",2),0))'="",$P(^(0),"^",5)="" W !!,"Discharge bedsection of this PTF record is NOT billable!",!!!
43 S IBI=5,DIR(0)="399,151",DIR("A")=" BILLING STATEMENT COVERS FROM" D READ G:IBQUIT NREC S DGX=IBIDS(151) D LASTDAY X ^DD("DD") S DIR("B")=Y
44 S IBI=6,DIR(0)="399,152",DIR("A")=" BILLING STATEMENT COVERS TO" D READ G:IBQUIT NREC
45 K %DT,DIR G ^IBCA1:'$O(^DGCR(399,"C",DFN,0)) S X=9999999-IBIDS(.03)
46 F I=0:0 S I=$O(^DGCR(399,"APDT",DFN,I)) Q:'I I $O(^DGCR(399,"APDT",DFN,I,0))=X,$D(^DGCR(399,+I,0)),$S('$D(^DGCR(399,I,"S")):1,$P(^("S"),"^",16)=1:0,1:1) S IBIDS(.17)=$P(^(0),"^",17) Q
47 I $D(IBIDS(.17)) G CHKINQ
48 I '$D(IBIDS(.17)),IBIDS(.05)<3 G CHKINQ
49CEOC1 D CEOC1^IBCA0 Q:'$D(IBIDS)
50CHKINQ G ^IBCA1
51 ;
52READ D ^DIR I X?1"^"1.ANP W !?6,*7,"Sorry '^' not allowed!" G READ
53 I $D(DIRUT) S IBQUIT=1 Q
54 S IBIDS($P($P(DGDIR0,"^",IBI),",",2))=Y
55 Q
56 ;
57NREC S IBYN=0 D SET W !?6,*7,"<",$S('$G(IBCABRT):"ABORTED",$P(IBCABRT(1),U,IBCABRT)]"":$P(IBCABRT(1),U,IBCABRT),1:"ABORTED"),", NO BILLING RECORD CREATED>" K IBIFN
58Q1 K IBIDS,IB
59Q K %,%DT,D,IBCABRT,IBNWBL,IBQUIT,IBYN,DIRUT,DTOUT,DIROUT,DUOUT,PRCASV,X1,X2,IBI,IBJ,IBX,DGX,IBDSDT,IBDFN,IBID0,IBSET,IBI,DGDIRB,DGDIR0,DGDIRA,DIR,DIC,DLAYGO,I,X,Y Q
60 Q
61SET S IBCABRT(1)="PATIENT INFORMATION LACKING^FILEMAN ACCESS UNDEFINED^"
62 S IBCABRT(1)=IBCABRT(1)_"NO LAYGO ACCESS TO BILLING FILE^"
63 S IBCABRT(1)=IBCABRT(1)_"MAS SERVICE PARAMETER UNKNOWN^"
64 S IBCABRT(1)=IBCABRT(1)_"FACILITY UNDEFINED^"
65 S IBCABRT(1)=IBCABRT(1)_"UNABLE TO CREATE ACCOUNTS RECEIVABLE ENTRY^"
66 S IBCABRT(1)=IBCABRT(1)_"EPISODE CANNOT BE ON OR AFTER PFSS EFFECTIVE DATE"
67 Q
68 ;
69LASTDAY ;find last day of last month
70 ; -set x to default last date
71 S X1=DT,X2=-($E(DT,6,7)) D C^%DTC S Y=X
72 K Y
73 I $D(IBDSDT) D G:$D(Y) LDQ
74 . ;I $E(DGX,4,5)<10 S Y=$E(DGX,1,3)_"0930" S:IBDSDT<Y Y=IBDSDT Q ;don't cross fy's
75 . ;I $E(DGX,4,5)>9 S Y=$E(DGX,1,3)_"1231" S:IBDSDT<Y Y=IBDSDT Q ;don't cross cy's
76 . S Y=IBDSDT
77 ;
78 I DGX>X S Y=DT Q ;billing for this month
79 ;
80 ;I $E(DGX,4,5)<10 S Y=$E(DGX,1,3)_"0930" S:X<Y Y=X G LDQ ; end of month, don't cross fy's
81 ;I $E(DGX,4,5)>9 S Y=$E(DGX,1,3)_"1231" S:X<Y Y=X G LDQ ; end of month, don't cross cy's
82 I '$D(Y) S Y=X
83LDQ Q
Note: See TracBrowser for help on using the repository browser.