IBCU5 ;ALB/AAS - MCCR MAILING ADDRESS UTILITY ROUTINE ; 26-FEB-90
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;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",$D(^DGCR(399,DA,"M")),+^("M"),$D(^("I1")) 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
;
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",1,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 Primary Insurance 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),IB01=+$G(^DGCR(399,DA,"M"))
G MAILQ:'$D(^DIC(36,+IB01,0))
;S IB02=$S($D(^DIC(36,+IB01,.11)):^(.11),1:"")
;
S IB02=$$ADD^IBCNADD(DA)
;
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,"^",7)'="",+$P(IB02,"^",7)'=$P(IBO2,"^",7) S $P(^DGCR(399,DA,"M"),"^",4)=$P(IB02,"^",7)
;
S $P(^DGCR(399,DA,"M1"),U,1)=$P(IB02,U,3)
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
;
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)_"^"_$P(IB02,U,4)
S $P(^DGCR(399,IBIFN,"M1"),"^",1)=""
MAILINQ K IB01,IB02,IB03 Q
;
MAILP ;Store Patient Mailing address
S DA=$S('$D(DA):IBIFN,DA']"":IBIFN,1:DA)
N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),VAPA("P")="" D DEM^VADPT,ADD^VADPT
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,9)=DGNAM_"^"_VAPA(1)_"^"_VAPA(2)_"^"_VAPA(4)_"^"_+VAPA(5)_"^"_$P(VAPA(11),U,1)
S $P(^DGCR(399,DA,"M1"),"^",1)=VAPA(3)
MAILPQ K VAPA,DGNAM Q
;
INSUR ;
Q
DEL S $P(^DGCR(399,DA,"M"),"^",4,9)="^^^^^",$P(^("M1"),"^",1)=""
Q
IBCU5 ;ALB/AAS - MCCR MAILING ADDRESS UTILITY ROUTINE ; 26-FEB-90
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+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 $DATA(^DGCR(399,DA,"M"))
IF +^("M")
IF $DATA(^("I1"))
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 IF $SELECT('$DATA(IBAC):1,IBAC=6:1,1:0)
QUIT
+7 ;
+8 SET IBINDT=$SELECT($GET(IBIDS(151)):IBIDS(151),$PIECE($GET(^DGCR(399,DA,"U")),"^"):$PIECE($GET(^DGCR(399,DA,"U")),"^"),1:DT)
+9 DO ALL^IBCNS1(DFN,"IBDD",1,IBINDT)
+10 IF $GET(IBDD(0))=1
SET X=+$ORDER(IBDD(0))
GOTO EN1Q
+11 ;
+12 ;S IBOUTP=1,IBINDT=$S($G(IBIDS(151)):IBIDS(151),$P($G(^DGCR(399,DA,"U")),"^"):$P($G(^DGCR(399,DA,"U")),"^"),1:DT)
+13 ;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
+14 SET X=""
EN1Q KILL IBDD,IBINS,IBIN
QUIT
+1 ;
MAILA ;Store Mailing Address for Primary Insurance 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)
SET IB01=+$GET(^DGCR(399,DA,"M"))
+4 IF '$DATA(^DIC(36,+IB01,0))
GOTO MAILQ
+5 ;S IB02=$S($D(^DIC(36,+IB01,.11)):^(.11),1:"")
+6 ;
+7 SET IB02=$$ADD^IBCNADD(DA)
+8 ;
+9 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)
+10 ;
+11 ; -- if send bill to employer, piece 7 = name
+12 IF $PIECE(IB02,"^",7)'=""
IF +$PIECE(IB02,"^",7)'=$PIECE(IBO2,"^",7)
SET $PIECE(^DGCR(399,DA,"M"),"^",4)=$PIECE(IB02,"^",7)
+13 ;
+14 SET $PIECE(^DGCR(399,DA,"M1"),U,1)=$PIECE(IB02,U,3)
+15 IF '$DATA(IBCAN)!($GET(IBAC)<3)
SET $PIECE(^DGCR(399,DA,"U1"),U,13)=$PIECE($GET(^DIC(36,+IB01,0)),U,10)
MAILQ KILL IB01,IB02,IB03
QUIT
+1 ;
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)_"^"_$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 SET DA=$SELECT('$DATA(DA):IBIFN,DA']"":IBIFN,1:DA)
+2 NEW DFN
SET DFN=$PIECE(^DGCR(399,DA,0),"^",2)
SET VAPA("P")=""
DO DEM^VADPT
DO ADD^VADPT
+3 SET DGNAM=$PIECE(VADM(1),",",2)_" "_$PIECE(VADM(1),",",1)
+4 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
+5 SET $PIECE(^DGCR(399,DA,"M"),"^",4,9)=DGNAM_"^"_VAPA(1)_"^"_VAPA(2)_"^"_VAPA(4)_"^"_+VAPA(5)_"^"_$PIECE(VAPA(11),U,1)
+6 SET $PIECE(^DGCR(399,DA,"M1"),"^",1)=VAPA(3)
MAILPQ KILL VAPA,DGNAM
QUIT
+1 ;
INSUR ;
+1 QUIT
DEL SET $PIECE(^DGCR(399,DA,"M"),"^",4,9)="^^^^^"
SET $PIECE(^("M1"),"^",1)=""
+1 QUIT
