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

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

revised back to 6/30/08 version

File size: 2.7 KB
Line 
1IBCCC3 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90
2 ;;2.0;INTEGRATED BILLING;**363,381**;21-MAR-94;Build 1
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;copy entries from table files:
6 ;passed in: IBIFN=new bill, IBIFN1=old bill
7 ;
8 I '$D(^DGCR(399,+$G(IBIFN),0))!'$D(^DGCR(399,+$G(IBIFN1),0)) Q
9 N IBXR,X,Y,IBX
10 ;
11DX ;copy diagnosis' (362.3)
12 N IBDX,IBDIFN
13 ;copy diagnosis from old bill
14 I $D(^IBA(362.3,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
15 . S IBDX=0 F S IBDX=$O(^IBA(362.3,IBXR,IBDX)) Q:'IBDX D
16 .. S IBDIFN=0 F S IBDIFN=$O(^IBA(362.3,IBXR,IBDX,IBDIFN)) Q:'IBDIFN D
17 ... S IBX=$G(^IBA(362.3,IBDIFN,0)) I 'IBX!($P(IBX,U,2)'=IBIFN1) Q
18 ... S DIC="^IBA(362.3,",DIC(0)="L",X=+IBX K DA,DO D FILE^DICN
19 ... S DIE=DIC,DA=+Y,DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3) D ^DIE K DIC,DIE,DA,DO,DR
20 K DIE,DIC,DA,DO,DR,X,Y
21 ;
22PRDX ;repoint procedure's associated diagnosis (2,304,10-13 -> 362.3)
23 N IBCPT,IBDIFN1,IBLN,IBI
24 S IBCPT=0 F S IBCPT=$O(^DGCR(399,+IBIFN,"CP",IBCPT)) Q:'IBCPT D
25 . S IBLN=$G(^DGCR(399,+IBIFN,"CP",IBCPT,0)) F IBI=11:1:14 S IBDIFN1=$P(IBLN,U,IBI) I +IBDIFN1 D
26 .. S IBDX=+$G(^IBA(362.3,+IBDIFN1,0)) Q:'IBDX
27 .. S IBDIFN=$O(^IBA(362.3,"AIFN"_IBIFN,IBDX,0)) Q:'IBDIFN
28 .. S $P(^DGCR(399,+IBIFN,"CP",IBCPT,0),U,IBI)=IBDIFN
29 ;
30RX ;copy rx refills (362.4)
31 N IBRX,IBRIFN,IBRXDA,IBDATE,IBNDC,IBDFN,IB3624DA
32 ;copy rx refills from old bill
33 ; IB*2*363 - get NDC# from PRESCRIPTION file (#52) before creating new
34 ; record entry in 362.4
35 I $D(^IBA(362.4,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
36 . S IBRX=0 F S IBRX=$O(^IBA(362.4,IBXR,IBRX)) Q:IBRX="" D
37 .. S IBRIFN=0 F S IBRIFN=$O(^IBA(362.4,IBXR,IBRX,IBRIFN)) Q:'IBRIFN D
38 ... S IBX=$G(^IBA(362.4,IBRIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
39 ... S DIC="^IBA(362.4,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0
40 ... S IB3624DA=+Y,IBRXDA=$P(IBX,U,5),IBDATE=$P(IBX,U,3),IBDFN=$$GET1^DIQ(399,IBIFN1,.02,"I")
41 ... S IBNDC=$S(IBRXDA:$$GETNDC^IBEFUNC3(IBDFN,IBRXDA,IBDATE),1:$P(IBX,U,8))
42 ... S DR=".02////"_IBIFN_";.03////"_IBDATE_";.04////"_$P(IBX,U,4)_";.05////"_IBRXDA_";.06////"_$P(IBX,U,6)_";.07////"_$P(IBX,U,7)_";.08////"_IBNDC
43 ... S DIE=DIC,DA=IB3624DA D ^DIE K DIC,DIE,DA,DO,DR
44 K DIE,DIC,DA,DO,DR,X,Y
45 ;
46PROS ;copy prosthetics (362.5)
47 N IBPR,IBPIFN
48 ;copy rx refills from old bill
49 I $D(^IBA(362.5,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
50 . S IBPR=0 F S IBPR=$O(^IBA(362.5,IBXR,IBPR)) Q:IBPR="" D
51 .. S IBPIFN=0 F S IBPIFN=$O(^IBA(362.5,IBXR,IBPR,IBPIFN)) Q:'IBPIFN D
52 ... S IBX=$G(^IBA(362.5,IBPIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
53 ... S DIC="^IBA(362.5,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0
54 ... S DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3)_";.04////"_$P(IBX,U,4)
55 ... S DIE=DIC,DA=+Y D ^DIE K DIC,DIE,DA,DO,DR
56 K DIE,DIC,DA,DO,DR,X,Y
57 Q
58 ;IBCCC3
Note: See TracBrowser for help on using the repository browser.