- IBCCC3 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90
- ;;2.0;INTEGRATED BILLING;**363,381,389,405,403**;21-MAR-94;Build 24
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;copy entries from table files:
- ;passed in: IBIFN=new bill, IBIFN1=old bill
- ;
- I '$D(^DGCR(399,+$G(IBIFN),0))!'$D(^DGCR(399,+$G(IBIFN1),0)) Q
- N IBXR,X,Y,IBX
- ;
- DX ;copy diagnosis' (362.3)
- N IBDX,IBDIFN
- ;copy diagnosis from old bill
- I $D(^IBA(362.3,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
- . S IBDX=0 F S IBDX=$O(^IBA(362.3,IBXR,IBDX)) Q:'IBDX D
- .. S IBDIFN=0 F S IBDIFN=$O(^IBA(362.3,IBXR,IBDX,IBDIFN)) Q:'IBDIFN D
- ... S IBX=$G(^IBA(362.3,IBDIFN,0)) I 'IBX!($P(IBX,U,2)'=IBIFN1) Q
- ... S DIC="^IBA(362.3,",DIC(0)="L",X=+IBX K DA,DO D FILE^DICN
- ... 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
- K DIE,DIC,DA,DO,DR,X,Y
- ;
- PRDX ;repoint procedure's associated diagnosis (2,304,10-13 -> 362.3)
- N IBCPT,IBDIFN1,IBLN,IBI
- S IBCPT=0 F S IBCPT=$O(^DGCR(399,+IBIFN,"CP",IBCPT)) Q:'IBCPT D
- . S IBLN=$G(^DGCR(399,+IBIFN,"CP",IBCPT,0)) F IBI=11:1:14 S IBDIFN1=$P(IBLN,U,IBI) I +IBDIFN1 D
- .. S IBDX=+$G(^IBA(362.3,+IBDIFN1,0)) Q:'IBDX
- .. S IBDIFN=$O(^IBA(362.3,"AIFN"_IBIFN,IBDX,0)) Q:'IBDIFN
- .. S $P(^DGCR(399,+IBIFN,"CP",IBCPT,0),U,IBI)=IBDIFN
- ;
- RX ;copy rx refills (362.4)
- N IBRX,IBRIFN,IBRXDA,IBDATE,IBNDC,IBDFN,IB3624DA
- ;copy rx refills from old bill
- ; IB*2*363 - get NDC# from PRESCRIPTION file (#52) before creating new
- ; record entry in 362.4
- I $D(^IBA(362.4,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
- . S IBRX=0 F S IBRX=$O(^IBA(362.4,IBXR,IBRX)) Q:IBRX="" D
- .. S IBRIFN=0 F S IBRIFN=$O(^IBA(362.4,IBXR,IBRX,IBRIFN)) Q:'IBRIFN D
- ... S IBX=$G(^IBA(362.4,IBRIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
- ... 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
- ... S IB3624DA=+Y,IBRXDA=$P(IBX,U,5),IBDATE=$P(IBX,U,3),IBDFN=$$GET1^DIQ(399,IBIFN1,.02,"I")
- ... S IBNDC=$S(IBRXDA:$$GETNDC^IBEFUNC3(IBDFN,IBRXDA,IBDATE),1:$P(IBX,U,8))
- ... 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
- ... S:$L($P(IBX,U,10)) DR=DR_";.1////"_$P(IBX,U,10)
- ... S DIE=DIC,DA=IB3624DA D ^DIE K DIC,DIE,DA,DO,DR
- K DIE,DIC,DA,DO,DR,X,Y
- ;
- PROS ;copy prosthetics (362.5)
- N IBPR,IBPIFN
- ;copy rx refills from old bill
- I $D(^IBA(362.5,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
- . S IBPR=0 F S IBPR=$O(^IBA(362.5,IBXR,IBPR)) Q:IBPR="" D
- .. S IBPIFN=0 F S IBPIFN=$O(^IBA(362.5,IBXR,IBPR,IBPIFN)) Q:'IBPIFN D
- ... S IBX=$G(^IBA(362.5,IBPIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
- ... 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
- ... S DR=".02////"_IBIFN_";.04////"_$P(IBX,U,4)_";.05////^S X=$P(IBX,U,5)"
- ... S DIE=DIC,DA=+Y D ^DIE K DIC,DIE,DA,DO,DR
- K DIE,DIC,DA,DO,DR,X,Y
- Q
- ;IBCCC3
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCCC3 2966 printed Feb 18, 2025@23:35:30 Page 2
- 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
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;copy entries from table files:
- +5 ;passed in: IBIFN=new bill, IBIFN1=old bill
- +6 ;
- +7 IF '$DATA(^DGCR(399,+$GET(IBIFN),0))!'$DATA(^DGCR(399,+$GET(IBIFN1),0))
- QUIT
- +8 NEW IBXR,X,Y,IBX
- +9 ;
- DX ;copy diagnosis' (362.3)
- +1 NEW IBDX,IBDIFN
- +2 ;copy diagnosis from old bill
- +3 IF $DATA(^IBA(362.3,"AIFN"_IBIFN1))
- SET IBXR="AIFN"_IBIFN1
- Begin DoDot:1
- +4 SET IBDX=0
- FOR
- SET IBDX=$ORDER(^IBA(362.3,IBXR,IBDX))
- if 'IBDX
- QUIT
- Begin DoDot:2
- +5 SET IBDIFN=0
- FOR
- SET IBDIFN=$ORDER(^IBA(362.3,IBXR,IBDX,IBDIFN))
- if 'IBDIFN
- QUIT
- Begin DoDot:3
- +6 SET IBX=$GET(^IBA(362.3,IBDIFN,0))
- IF 'IBX!($PIECE(IBX,U,2)'=IBIFN1)
- QUIT
- +7 SET DIC="^IBA(362.3,"
- SET DIC(0)="L"
- SET X=+IBX
- KILL DA,DO
- DO FILE^DICN
- +8 SET DIE=DIC
- SET DA=+Y
- SET DR=".02////"_IBIFN_";.03////"_$PIECE(IBX,U,3)_";.04////"_$PIECE(IBX,U,4)
- DO ^DIE
- KILL DIC,DIE,DA,DO,DR
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +9 KILL DIE,DIC,DA,DO,DR,X,Y
- +10 ;
- PRDX ;repoint procedure's associated diagnosis (2,304,10-13 -> 362.3)
- +1 NEW IBCPT,IBDIFN1,IBLN,IBI
- +2 SET IBCPT=0
- FOR
- SET IBCPT=$ORDER(^DGCR(399,+IBIFN,"CP",IBCPT))
- if 'IBCPT
- QUIT
- Begin DoDot:1
- +3 SET IBLN=$GET(^DGCR(399,+IBIFN,"CP",IBCPT,0))
- FOR IBI=11:1:14
- SET IBDIFN1=$PIECE(IBLN,U,IBI)
- IF +IBDIFN1
- Begin DoDot:2
- +4 SET IBDX=+$GET(^IBA(362.3,+IBDIFN1,0))
- if 'IBDX
- QUIT
- +5 SET IBDIFN=$ORDER(^IBA(362.3,"AIFN"_IBIFN,IBDX,0))
- if 'IBDIFN
- QUIT
- +6 SET $PIECE(^DGCR(399,+IBIFN,"CP",IBCPT,0),U,IBI)=IBDIFN
- End DoDot:2
- End DoDot:1
- +7 ;
- RX ;copy rx refills (362.4)
- +1 NEW IBRX,IBRIFN,IBRXDA,IBDATE,IBNDC,IBDFN,IB3624DA
- +2 ;copy rx refills from old bill
- +3 ; IB*2*363 - get NDC# from PRESCRIPTION file (#52) before creating new
- +4 ; record entry in 362.4
- +5 IF $DATA(^IBA(362.4,"AIFN"_IBIFN1))
- SET IBXR="AIFN"_IBIFN1
- Begin DoDot:1
- +6 SET IBRX=0
- FOR
- SET IBRX=$ORDER(^IBA(362.4,IBXR,IBRX))
- if IBRX=""
- QUIT
- Begin DoDot:2
- +7 SET IBRIFN=0
- FOR
- SET IBRIFN=$ORDER(^IBA(362.4,IBXR,IBRX,IBRIFN))
- if 'IBRIFN
- QUIT
- Begin DoDot:3
- +8 SET IBX=$GET(^IBA(362.4,IBRIFN,0))
- IF IBX=""!($PIECE(IBX,U,2)'=IBIFN1)
- QUIT
- +9 SET DIC="^IBA(362.4,"
- SET DIC(0)="L"
- SET X=$PIECE(IBX,U,1)
- KILL DA,DO
- DO FILE^DICN
- KILL DA,DO
- if Y'>0
- QUIT
- +10 SET IB3624DA=+Y
- SET IBRXDA=$PIECE(IBX,U,5)
- SET IBDATE=$PIECE(IBX,U,3)
- SET IBDFN=$$GET1^DIQ(399,IBIFN1,.02,"I")
- +11 SET IBNDC=$SELECT(IBRXDA:$$GETNDC^IBEFUNC3(IBDFN,IBRXDA,IBDATE),1:$PIECE(IBX,U,8))
- +12 SET DR=".02////"_IBIFN_";.03////"_IBDATE_";.04////"_$PIECE(IBX,U,4)_";.05////"_IBRXDA_";.06////"_$PIECE(IBX,U,6)_";.07////"_$PIECE(IBX,U,7)_";.08////"_IBNDC
- +13 if $LENGTH($PIECE(IBX,U,10))
- SET DR=DR_";.1////"_$PIECE(IBX,U,10)
- +14 SET DIE=DIC
- SET DA=IB3624DA
- DO ^DIE
- KILL DIC,DIE,DA,DO,DR
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 KILL DIE,DIC,DA,DO,DR,X,Y
- +16 ;
- PROS ;copy prosthetics (362.5)
- +1 NEW IBPR,IBPIFN
- +2 ;copy rx refills from old bill
- +3 IF $DATA(^IBA(362.5,"AIFN"_IBIFN1))
- SET IBXR="AIFN"_IBIFN1
- Begin DoDot:1
- +4 SET IBPR=0
- FOR
- SET IBPR=$ORDER(^IBA(362.5,IBXR,IBPR))
- if IBPR=""
- QUIT
- Begin DoDot:2
- +5 SET IBPIFN=0
- FOR
- SET IBPIFN=$ORDER(^IBA(362.5,IBXR,IBPR,IBPIFN))
- if 'IBPIFN
- QUIT
- Begin DoDot:3
- +6 SET IBX=$GET(^IBA(362.5,IBPIFN,0))
- IF IBX=""!($PIECE(IBX,U,2)'=IBIFN1)
- QUIT
- +7 SET DIC="^IBA(362.5,"
- SET DIC(0)="L"
- SET X=$PIECE(IBX,U,1)
- KILL DA,DO
- DO FILE^DICN
- KILL DA,DO
- if Y'>0
- QUIT
- +8 SET DR=".02////"_IBIFN_";.04////"_$PIECE(IBX,U,4)_";.05////^S X=$P(IBX,U,5)"
- +9 SET DIE=DIC
- SET DA=+Y
- DO ^DIE
- KILL DIC,DIE,DA,DO,DR
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 KILL DIE,DIC,DA,DO,DR,X,Y
- +11 QUIT
- +12 ;IBCCC3