- IBCU5 ;ALB/AAS - MCCR MAILING ADDRESS UTILITY ROUTINE ;26-FEB-90
- ;;2.0;INTEGRATED BILLING;**8,52,80,117,51,206,447**;21-MAR-94;Build 80
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;MAP TO DGCRU5
- ;
- EN ;Entry from X-REF from who's responsible
- ;doesn't set primary insurance field, must be second trigger.
- S X=$P(^DGCR(399,DA,0),"^",11)
- I X="p" D MAILP G ENQ
- I X="o" S DGTAG=$S('$D(^DGCR(399,DA,"M")):"MAILP",'$P(^("M"),"^",11):"MAILP",'$D(^DIC(4,$P(^("M"),"^",11),0)):"MAILP",1:"MAILIN") D @DGTAG G ENQ
- I X="i",+$G(^DGCR(399,DA,"MP")) D MAILA G ENQ
- ENQ K DGTAG Q
- ;
- EN1 ;Now Trigger of primary insurance policy from who's responsible
- ;if only one active policy
- ;; old Trigger of primary insurer from who's responsible
- ;Only should be called if primary insurer is null (condition of trigger)
- ;return ifn of insurer in X
- ;
- S X=""
- I $S('$D(IBAC):1,IBAC=6:1,1:0) Q
- ;
- S IBINDT=$S($G(IBIDS(151)):IBIDS(151),$P($G(^DGCR(399,DA,"U")),"^"):$P($G(^DGCR(399,DA,"U")),"^"),1:DT)
- D ALL^IBCNS1(DFN,"IBDD",2,IBINDT)
- I $G(IBDD(0))=1 S X=+$O(IBDD(0)) G EN1Q
- ;
- ;S IBOUTP=1,IBINDT=$S($G(IBIDS(151)):IBIDS(151),$P($G(^DGCR(399,DA,"U")),"^"):$P($G(^DGCR(399,DA,"U")),"^"),1:DT)
- ;D ^IBCNS I IBINS S X=IBDD($O(IBDD(0))) S:$O(IBDD(+X)) X="" S X=$S($D(^DIC(36,+X,0)):+X,1:"") G EN1Q
- S X=""
- EN1Q K IBDD,IBINS,IBIN Q
- ;
- MAILA ;Store Mailing Address for Bill Payer Carrier (and if not copying bill or bill not authorized,
- ; insert Attending Physican Id [36,.1] into Form Locator 92 [399,213]
- ;
- S DA=$S('$D(DA):IBIFN,DA']"":IBIFN,1:DA)
- G MAILQ:$P(^DGCR(399,DA,0),U,11)="p" ; Patient is responsible for bill
- G MAILQ:$P(^DGCR(399,DA,0),U,11)="o" ; Other party is responsible for bill
- ;
- S IB01=+$G(^DGCR(399,DA,"MP"))
- G MAILQ:'$D(^DIC(36,+IB01,0)) ; Bad insurance data
- ;
- S IB02=$$ADD^IBCNADD(DA)
- ;
- D UPDMA(DA,IB01,IB02)
- ;
- ; Removed reference to obsolete data field with IB*2.0*447 BI
- ;I '$D(IBCAN)!($G(IBAC)<3) S $P(^DGCR(399,DA,"U1"),U,13)=$P($G(^DIC(36,+IB01,0)),U,10)
- ;
- MAILQ K IB01,IB02,IB03 Q
- ;
- UPDMA(DA,IB01,IB02) ; Update insurance company mailing address in file 399
- ; DA = bill ifn
- ;IB02 = string returned from call to ADD^IBCNADD
- ;IB01 = insurance company ifn
- S $P(^DGCR(399,DA,"M"),"^",4,9)=$E($P($G(^DIC(36,+IB01,0)),"^",1),1,30)_"^"_$P(IB02,"^",1)_"^"_$P(IB02,"^",2)_"^"_$P(IB02,"^",4)_"^"_$P(IB02,"^",5)_"^"_$P(IB02,"^",6)
- ;
- ; -- if send bill to employer, piece 7 = name
- I $P(IB02,"^",8)'="",+$P(IB02,"^",8)'=$P(IB02,"^",8) S $P(^DGCR(399,DA,"M"),"^",4)=$P(IB02,"^",8)
- ;
- S $P(^DGCR(399,DA,"M1"),U,1)=$P(IB02,U,3)
- Q
- ;
- MAILIN ;Store Mailing Address for Institution
- S DA=$S('$D(DA):IBIFN,DA']"":IBIFN,1:DA),X=$P(^DGCR(399,DA,"M"),"^",11) G:X']"" MAILINQ G:'$D(^DIC(4,X,0)) MAILINQ
- S IB01=^DIC(4,X,0),IB02=$S($D(^(1)):^(1),1:"")
- S $P(^DGCR(399,IBIFN,"M"),"^",4,9)=$P(IB01,U,1)_"^"_$P(IB02,U,1)_"^"_$P(IB02,U,2)_"^"_$P(IB02,U,3)_"^"_$P(IB01,U,2)_"^"_$TR($P(IB02,U,4),"-")
- S $P(^DGCR(399,IBIFN,"M1"),"^",1)=""
- MAILINQ K IB01,IB02,IB03 Q
- ;
- MAILP ;Store Patient Mailing address
- N DFN,VAPA,DGNAM,IBCONF
- S DA=$S('$D(DA):IBIFN,DA']"":IBIFN,1:DA)
- S DFN=$P(^DGCR(399,DA,0),"^",2),VAPA("P")="" D DEM^VADPT,ADD^VADPT
- S IBCONF=$S('$G(VAPA(12)):0,$P($G(VAPA(22,3)),U,3)'="Y":0,1:1) ; Confidential Address
- S DGNAM=$P(VADM(1),",",2)_" "_$P(VADM(1),",",1)
- S DGNAM=$S($E(VADM(5))'="F":"MR.",'$D(^DIC(11,+$P(^DPT(DFN,0),"^",5),0)):"MS.","DMW"[$E(^DIC(11,$P(^DPT(DFN,0),"^",5),0)):"MRS.",1:"MS.")_DGNAM
- S $P(^DGCR(399,DA,"M"),"^",4)=DGNAM
- I IBCONF D ; use conf. address for mailing
- . S $P(^DGCR(399,DA,"M"),"^",5,9)=VAPA(13)_"^"_VAPA(14)_"^"_VAPA(16)_"^"_+VAPA(17)_"^"_$P(VAPA(18),U,1)
- . S $P(^DGCR(399,DA,"M1"),"^",1)=VAPA(15)
- I 'IBCONF D
- . S $P(^DGCR(399,DA,"M"),"^",5,9)=VAPA(1)_"^"_VAPA(2)_"^"_VAPA(4)_"^"_+VAPA(5)_"^"_$P(VAPA(11),U,1)
- . S $P(^DGCR(399,DA,"M1"),"^",1)=VAPA(3)
- MAILPQ Q
- ;
- INSUR ;
- Q
- DEL S $P(^DGCR(399,DA,"M"),"^",4,9)="^^^^^",$P(^("M1"),"^",1)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU5 4018 printed Feb 18, 2025@23:47:04 Page 2
- IBCU5 ;ALB/AAS - MCCR MAILING ADDRESS UTILITY ROUTINE ;26-FEB-90
- +1 ;;2.0;INTEGRATED BILLING;**8,52,80,117,51,206,447**;21-MAR-94;Build 80
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;MAP TO DGCRU5
- +5 ;
- EN ;Entry from X-REF from who's responsible
- +1 ;doesn't set primary insurance field, must be second trigger.
- +2 SET X=$PIECE(^DGCR(399,DA,0),"^",11)
- +3 IF X="p"
- DO MAILP
- GOTO ENQ
- +4 IF X="o"
- SET DGTAG=$SELECT('$DATA(^DGCR(399,DA,"M")):"MAILP",'$PIECE(^("M"),"^",11):"MAILP",'$DATA(^DIC(4,$PIECE(^("M"),"^",11),0)):"MAILP",1:"MAILIN")
- DO @DGTAG
- GOTO ENQ
- +5 IF X="i"
- IF +$GET(^DGCR(399,DA,"MP"))
- DO MAILA
- GOTO ENQ
- ENQ KILL DGTAG
- QUIT
- +1 ;
- EN1 ;Now Trigger of primary insurance policy from who's responsible
- +1 ;if only one active policy
- +2 ;; old Trigger of primary insurer from who's responsible
- +3 ;Only should be called if primary insurer is null (condition of trigger)
- +4 ;return ifn of insurer in X
- +5 ;
- +6 SET X=""
- +7 IF $SELECT('$DATA(IBAC):1,IBAC=6:1,1:0)
- QUIT
- +8 ;
- +9 SET IBINDT=$SELECT($GET(IBIDS(151)):IBIDS(151),$PIECE($GET(^DGCR(399,DA,"U")),"^"):$PIECE($GET(^DGCR(399,DA,"U")),"^"),1:DT)
- +10 DO ALL^IBCNS1(DFN,"IBDD",2,IBINDT)
- +11 IF $GET(IBDD(0))=1
- SET X=+$ORDER(IBDD(0))
- GOTO EN1Q
- +12 ;
- +13 ;S IBOUTP=1,IBINDT=$S($G(IBIDS(151)):IBIDS(151),$P($G(^DGCR(399,DA,"U")),"^"):$P($G(^DGCR(399,DA,"U")),"^"),1:DT)
- +14 ;D ^IBCNS I IBINS S X=IBDD($O(IBDD(0))) S:$O(IBDD(+X)) X="" S X=$S($D(^DIC(36,+X,0)):+X,1:"") G EN1Q
- +15 SET X=""
- EN1Q KILL IBDD,IBINS,IBIN
- QUIT
- +1 ;
- MAILA ;Store Mailing Address for Bill Payer Carrier (and if not copying bill or bill not authorized,
- +1 ; insert Attending Physican Id [36,.1] into Form Locator 92 [399,213]
- +2 ;
- +3 SET DA=$SELECT('$DATA(DA):IBIFN,DA']"":IBIFN,1:DA)
- +4 ; Patient is responsible for bill
- if $PIECE(^DGCR(399,DA,0),U,11)="p"
- GOTO MAILQ
- +5 ; Other party is responsible for bill
- if $PIECE(^DGCR(399,DA,0),U,11)="o"
- GOTO MAILQ
- +6 ;
- +7 SET IB01=+$GET(^DGCR(399,DA,"MP"))
- +8 ; Bad insurance data
- if '$DATA(^DIC(36,+IB01,0))
- GOTO MAILQ
- +9 ;
- +10 SET IB02=$$ADD^IBCNADD(DA)
- +11 ;
- +12 DO UPDMA(DA,IB01,IB02)
- +13 ;
- +14 ; Removed reference to obsolete data field with IB*2.0*447 BI
- +15 ;I '$D(IBCAN)!($G(IBAC)<3) S $P(^DGCR(399,DA,"U1"),U,13)=$P($G(^DIC(36,+IB01,0)),U,10)
- +16 ;
- MAILQ KILL IB01,IB02,IB03
- QUIT
- +1 ;
- UPDMA(DA,IB01,IB02) ; Update insurance company mailing address in file 399
- +1 ; DA = bill ifn
- +2 ;IB02 = string returned from call to ADD^IBCNADD
- +3 ;IB01 = insurance company ifn
- +4 SET $PIECE(^DGCR(399,DA,"M"),"^",4,9)=$EXTRACT($PIECE($GET(^DIC(36,+IB01,0)),"^",1),1,30)_"^"_$PIECE(IB02,"^",1)_"^"_$PIECE(IB02,"^",2)_"^"_$PIECE(IB02,"^",4)_"^"_$PIECE(IB02,"^",5)_"^"_$PIECE(IB02,"^",6)
- +5 ;
- +6 ; -- if send bill to employer, piece 7 = name
- +7 IF $PIECE(IB02,"^",8)'=""
- IF +$PIECE(IB02,"^",8)'=$PIECE(IB02,"^",8)
- SET $PIECE(^DGCR(399,DA,"M"),"^",4)=$PIECE(IB02,"^",8)
- +8 ;
- +9 SET $PIECE(^DGCR(399,DA,"M1"),U,1)=$PIECE(IB02,U,3)
- +10 QUIT
- +11 ;
- MAILIN ;Store Mailing Address for Institution
- +1 SET DA=$SELECT('$DATA(DA):IBIFN,DA']"":IBIFN,1:DA)
- SET X=$PIECE(^DGCR(399,DA,"M"),"^",11)
- if X']""
- GOTO MAILINQ
- if '$DATA(^DIC(4,X,0))
- GOTO MAILINQ
- +2 SET IB01=^DIC(4,X,0)
- SET IB02=$SELECT($DATA(^(1)):^(1),1:"")
- +3 SET $PIECE(^DGCR(399,IBIFN,"M"),"^",4,9)=$PIECE(IB01,U,1)_"^"_$PIECE(IB02,U,1)_"^"_$PIECE(IB02,U,2)_"^"_$PIECE(IB02,U,3)_"^"_$PIECE(IB01,U,2)_"^"_$TRANSLATE($PIECE(IB02,U,4),"-")
- +4 SET $PIECE(^DGCR(399,IBIFN,"M1"),"^",1)=""
- MAILINQ KILL IB01,IB02,IB03
- QUIT
- +1 ;
- MAILP ;Store Patient Mailing address
- +1 NEW DFN,VAPA,DGNAM,IBCONF
- +2 SET DA=$SELECT('$DATA(DA):IBIFN,DA']"":IBIFN,1:DA)
- +3 SET DFN=$PIECE(^DGCR(399,DA,0),"^",2)
- SET VAPA("P")=""
- DO DEM^VADPT
- DO ADD^VADPT
- +4 ; Confidential Address
- SET IBCONF=$SELECT('$GET(VAPA(12)):0,$PIECE($GET(VAPA(22,3)),U,3)'="Y":0,1:1)
- +5 SET DGNAM=$PIECE(VADM(1),",",2)_" "_$PIECE(VADM(1),",",1)
- +6 SET DGNAM=$SELECT($EXTRACT(VADM(5))'="F":"MR.",'$DATA(^DIC(11,+$PIECE(^DPT(DFN,0),"^",5),0)):"MS.","DMW"[$EXTRACT(^DIC(11,$PIECE(^DPT(DFN,0),"^",5),0)):"MRS.",1:"MS.")_DGNAM
- +7 SET $PIECE(^DGCR(399,DA,"M"),"^",4)=DGNAM
- +8 ; use conf. address for mailing
- IF IBCONF
- Begin DoDot:1
- +9 SET $PIECE(^DGCR(399,DA,"M"),"^",5,9)=VAPA(13)_"^"_VAPA(14)_"^"_VAPA(16)_"^"_+VAPA(17)_"^"_$PIECE(VAPA(18),U,1)
- +10 SET $PIECE(^DGCR(399,DA,"M1"),"^",1)=VAPA(15)
- End DoDot:1
- +11 IF 'IBCONF
- Begin DoDot:1
- +12 SET $PIECE(^DGCR(399,DA,"M"),"^",5,9)=VAPA(1)_"^"_VAPA(2)_"^"_VAPA(4)_"^"_+VAPA(5)_"^"_$PIECE(VAPA(11),U,1)
- +13 SET $PIECE(^DGCR(399,DA,"M1"),"^",1)=VAPA(3)
- End DoDot:1
- MAILPQ QUIT
- +1 ;
- INSUR ;
- +1 QUIT
- DEL SET $PIECE(^DGCR(399,DA,"M"),"^",4,9)="^^^^^"
- SET $PIECE(^("M1"),"^",1)=""
- +1 QUIT