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

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

revised back to 6/30/08 version

File size: 3.3 KB
Line 
1IBCC1 ;ALB/MJB - CANCEL UB-82 THIRD PARTY BILL ;10-OCT-94
2 ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347**;21-MAR-94;Build 24
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5RNB ; -- Add a reason not billable to claims tracking
6 N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD
7 Q:'$G(IBIFN)
8 S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0
9 I '$D(DFN) S DFN=$P(IB(0),"^",2)
10 ;
11 ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit
12INPT I IBTYP<3 D
13 .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
14 .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih
15 .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0))
16 .I $G(IBTRE) D RNBEDIT
17 .Q:IBQUIT
18 .;
19 .; -- alternate inpt method
20 .S IBCODE=$O(^IBE(356.6,"ACODE",1,0))
21 .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
22 .S IBDT=(DATE-.25) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24)) D
23 ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D:$G(IBTSAV)'=IBTRE RNBEDIT
24 .Q
25 ;
26OPT ; -- is opt-find entries in IBT(356, for opt dates and then edit
27 I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D
28 .S IBAPPT=0 F S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT) D
29 ..S IBDT=(IBAPPT-.01) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24)) D
30 ...S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D RNBEDIT
31 .Q
32 ;
33RX ; -- find rx's on bill
34 S IBDD=0 F S IBDD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D
35 .S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3)
36 .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1
37 .S FILL="" F S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT) D
38 ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT) I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D RNBEDIT
39 ;
40PRO ; -- find prosthetics on bill
41 S IBDD=0 F S IBDD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D
42 .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4)
43 .Q:'$G(IBPRO)
44 .S IBTRE=0 F S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT) D RNBEDIT
45 Q
46 ;
47RNBEDIT ;
48 Q:IBQUIT
49 W:'$D(IBTALK) !!,"Since you have canceled this bill, you may enter a Reason Not Billable",!,"into Claims Tracking. This will take the care off of the UNBILLED lists"
50 S IBTALK=1
51 ;
52 N %,IBTRED S IBTRED=$G(^IBT(356,IBTRE,0))
53 W !!,"Claims Tracking entry: ",+IBTRED," ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,"^",18))," ",$$FMTE^XLFDT($P(IBTRED,"^",6))
54 I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note: A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record."
55 S DA=IBTRE,DIE="^IBT(356,",DR=".19"
56 I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2) ; IB*320 MCS cancel
57 D ^DIE
58 ;
59 ; - if the RNB changed, update the user and date/time last edited
60 I $P(IBTRED,"^",19)'=$P($G(^IBT(356,IBTRE,0)),"^",19) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE
61 ;
62 ; $D(Y) indicates an up-arrow exit from the DIE call (??)
63 I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1
64 Q
Note: See TracBrowser for help on using the repository browser.