- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC3.m
r613 r623 1 IBCCC3 2 ;;2.0;INTEGRATED BILLING;**363,381,389**;21-MAR-94;Build 6 3 4 5 6 7 8 9 10 11 DX 12 13 14 15 16 17 18 19 20 21 22 PRDX 23 24 25 26 27 28 29 30 RX 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 PROS 47 48 49 50 51 52 53 54 ... S DR=".02////"_IBIFN_";.04////"_$P(IBX,U,4)_";.05////^S X=$P(IBX,U,5)" 55 56 57 58 1 IBCCC3 ;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 ; 11 DX ;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 ; 22 PRDX ;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 ; 30 RX ;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 ; 46 PROS ;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 TracChangeset
for help on using the changeset viewer.
