Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCCC3

IBCCC3.m

Go to the documentation of this file.
  1. IBCCC3 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90
  1. ;;2.0;INTEGRATED BILLING;**363,381,389,405,403**;21-MAR-94;Build 24
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;copy entries from table files:
  1. ;passed in: IBIFN=new bill, IBIFN1=old bill
  1. ;
  1. I '$D(^DGCR(399,+$G(IBIFN),0))!'$D(^DGCR(399,+$G(IBIFN1),0)) Q
  1. N IBXR,X,Y,IBX
  1. ;
  1. DX ;copy diagnosis' (362.3)
  1. N IBDX,IBDIFN
  1. ;copy diagnosis from old bill
  1. I $D(^IBA(362.3,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
  1. . S IBDX=0 F S IBDX=$O(^IBA(362.3,IBXR,IBDX)) Q:'IBDX D
  1. .. S IBDIFN=0 F S IBDIFN=$O(^IBA(362.3,IBXR,IBDX,IBDIFN)) Q:'IBDIFN D
  1. ... S IBX=$G(^IBA(362.3,IBDIFN,0)) I 'IBX!($P(IBX,U,2)'=IBIFN1) Q
  1. ... S DIC="^IBA(362.3,",DIC(0)="L",X=+IBX K DA,DO D FILE^DICN
  1. ... S DIE=DIC,DA=+Y,DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3)_";.04////"_$P(IBX,U,4) D ^DIE K DIC,DIE,DA,DO,DR
  1. K DIE,DIC,DA,DO,DR,X,Y
  1. ;
  1. PRDX ;repoint procedure's associated diagnosis (2,304,10-13 -> 362.3)
  1. N IBCPT,IBDIFN1,IBLN,IBI
  1. S IBCPT=0 F S IBCPT=$O(^DGCR(399,+IBIFN,"CP",IBCPT)) Q:'IBCPT D
  1. . S IBLN=$G(^DGCR(399,+IBIFN,"CP",IBCPT,0)) F IBI=11:1:14 S IBDIFN1=$P(IBLN,U,IBI) I +IBDIFN1 D
  1. .. S IBDX=+$G(^IBA(362.3,+IBDIFN1,0)) Q:'IBDX
  1. .. S IBDIFN=$O(^IBA(362.3,"AIFN"_IBIFN,IBDX,0)) Q:'IBDIFN
  1. .. S $P(^DGCR(399,+IBIFN,"CP",IBCPT,0),U,IBI)=IBDIFN
  1. ;
  1. RX ;copy rx refills (362.4)
  1. N IBRX,IBRIFN,IBRXDA,IBDATE,IBNDC,IBDFN,IB3624DA
  1. ;copy rx refills from old bill
  1. ; IB*2*363 - get NDC# from PRESCRIPTION file (#52) before creating new
  1. ; record entry in 362.4
  1. I $D(^IBA(362.4,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
  1. . S IBRX=0 F S IBRX=$O(^IBA(362.4,IBXR,IBRX)) Q:IBRX="" D
  1. .. S IBRIFN=0 F S IBRIFN=$O(^IBA(362.4,IBXR,IBRX,IBRIFN)) Q:'IBRIFN D
  1. ... S IBX=$G(^IBA(362.4,IBRIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
  1. ... 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
  1. ... S IB3624DA=+Y,IBRXDA=$P(IBX,U,5),IBDATE=$P(IBX,U,3),IBDFN=$$GET1^DIQ(399,IBIFN1,.02,"I")
  1. ... S IBNDC=$S(IBRXDA:$$GETNDC^IBEFUNC3(IBDFN,IBRXDA,IBDATE),1:$P(IBX,U,8))
  1. ... 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
  1. ... S:$L($P(IBX,U,10)) DR=DR_";.1////"_$P(IBX,U,10)
  1. ... S DIE=DIC,DA=IB3624DA D ^DIE K DIC,DIE,DA,DO,DR
  1. K DIE,DIC,DA,DO,DR,X,Y
  1. ;
  1. PROS ;copy prosthetics (362.5)
  1. N IBPR,IBPIFN
  1. ;copy rx refills from old bill
  1. I $D(^IBA(362.5,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
  1. . S IBPR=0 F S IBPR=$O(^IBA(362.5,IBXR,IBPR)) Q:IBPR="" D
  1. .. S IBPIFN=0 F S IBPIFN=$O(^IBA(362.5,IBXR,IBPR,IBPIFN)) Q:'IBPIFN D
  1. ... S IBX=$G(^IBA(362.5,IBPIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
  1. ... 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
  1. ... S DR=".02////"_IBIFN_";.04////"_$P(IBX,U,4)_";.05////^S X=$P(IBX,U,5)"
  1. ... S DIE=DIC,DA=+Y D ^DIE K DIC,DIE,DA,DO,DR
  1. K DIE,DIC,DA,DO,DR,X,Y
  1. Q
  1. ;IBCCC3