- IBTRC2 ;ALB/AAS - INSURANCE POLICY CALLS FROM FILE 356.2 DD ; 22-JULY-91
- ;;Version 2.0 ; INTEGRATED BILLING ;**28**; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- Q
- DD(IBX,IBDA) ; - called from input transform for field 1.05
- ; -- input ibx = x from input transform
- ; ibda = internal entry in 356.2
- ; -- output returns x=internal entry in 2.3121 (ins. Mult.) if valid
- ;
- N DFN,INSDT,ACTIVE,IBDD,IBD,IBCDFN,DA,DR,DIC,DIE
- D VAR
- S X=$$SEL^IBCNS2(IBX,DFN,DT,ACTIVE)
- I +X<1 K X
- DDQ Q
- ;
- VAR S DFN=$P(^IBT(356.2,IBDA,0),"^",5)
- I DFN="" S DFN=$P($G(^IBT(356,+$P(^IBT(356.2,IBDA,0),"^",2),0)),"^",2)
- S ACTIVE=2,INSDT=DT
- Q
- ;
- SEL(IBX,DFN,INSDT,ACTIVE) ; -- Select insurance policy
- ; -- Input IBX = x from input transform
- ; DFN = patient
- ; INSDT = (optional) Active date of ins. (default = dt)
- ; ACTIVE = (optional) 1 if want active (default)
- ; = 2 if want all ins returned
- ;
- ; -- Output = pointer to 36 ^ pointer to 2.3121 ^ pointer to 355.3
- ;
- N I,J,Y,DA,DE,DQ,DR,DIC,DIE,DIR,DIV,IBSEL,IBDD,IBD
- S IBSEL=1,Y=""
- I '$G(ACTIVE) S ACTIVE=2
- S:'$G(INSDT) INSDT=DT
- I '$G(DFN) G SELQ
- D BLD
- ;
- ; -- call DIC to choose from list
- S X=IBX
- S DIC="^DPT("_DFN_",.312,",DIC(0)="EQMN"
- S DIC("S")="I $D(IBDD(+Y))"
- S DIC("W")="W $P(^DIC(36,+^(0),0),U)_"" Group: ""_$$GRP^IBCNS($P(^DPT(DFN,.312,+Y,0),U,18))"
- D ^DIC
- SELQ Q +Y
- ;
- BLD K IBD,IBDD
- S (IBDD,IBCDFN)=0 F S IBCDFN=$O(^DPT(+DFN,.312,IBCDFN)) Q:'IBCDFN I $D(^DPT(DFN,.312,+IBCDFN,0)) D CHK(IBCDFN,ACTIVE,INSDT)
- Q
- ;
- CHK(IBCDFN,ACTIVE,INSDT) ; -- see if active
- N X,X1
- S X=$G(^DPT(DFN,.312,IBCDFN,0))
- S IBDD(IBCDFN)=+X_"^"_IBCDFN_"^"_$P(X,"^",18)
- I ACTIVE=2 G CHKQ
- S X1=$G(^DIC(36,+X,0)) I X1="" G CQ ;ins co entry doesn't exist
- I $P(X,"^",8) G:INSDT<$P(X,"^",8) CQ ;effective date later than care
- I $P(X,"^",4) G:INSDT>$P(X,"^",4) CQ ;care after expiration date
- I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CQ ;plan is inactive
- G:$P(X1,"^",5) CQ ; ;ins company inactive
- G:$P(X1,"^",2)="N" CQ ; ;ins company will not reimburse
- G CHKQ
- CQ K IBDD(IBCDFN)
- CHKQ S:$D(IBDD(IBCDFN)) IBDD=IBDD+1,IBD(IBDD)=IBCDFN
- Q
- ;
- ;
- DDHELP(IBDA) ; -- Executable help
- ; -- write out list to choose from
- N DFN,INSDT,ACTIVE,IBDD,IBD,IBCDFN,I,IBINS
- D VAR,BLD
- ;
- I $G(IBDD)=0 W !,"No Insurance Policies to Select From" G DDHQ
- ;
- I '$D(IOM) D HOME^%ZIS
- W ! D HDR^IBCNS
- S I=0 F S I=$O(IBD(I)) Q:'I D
- .S IBINS=$G(^DPT(DFN,.312,$G(IBD(I)),0))
- .D D1^IBCNS
- DDHQ Q
- ;
- TRANS(IBDA,Y) ; -- output transform
- N DFN,INSDT,ACTIVE,IBDD,IBD,IBCDFN
- D VAR
- S Y=$P($G(^DIC(36,+$P($G(^DPT(DFN,.312,+$G(Y),0)),U),0)),U)
- Q Y
- ;
- INSCO(IBDA,IBCDFN) ; -- return pointer value of 36 from pt. file
- N DFN,INSDT,ACTIVE,IBDD,IBD
- D VAR
- S Y=+$G(^DPT(DFN,.312,IBCDFN,0))
- Q Y_$S(Y>0:"^"_$P($G(^DIC(36,+Y,0)),"^"),1:"")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRC2 2988 printed Jan 18, 2025@03:28:47 Page 2
- IBTRC2 ;ALB/AAS - INSURANCE POLICY CALLS FROM FILE 356.2 DD ; 22-JULY-91
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;**28**; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 QUIT
- DD(IBX,IBDA) ; - called from input transform for field 1.05
- +1 ; -- input ibx = x from input transform
- +2 ; ibda = internal entry in 356.2
- +3 ; -- output returns x=internal entry in 2.3121 (ins. Mult.) if valid
- +4 ;
- +5 NEW DFN,INSDT,ACTIVE,IBDD,IBD,IBCDFN,DA,DR,DIC,DIE
- +6 DO VAR
- +7 SET X=$$SEL^IBCNS2(IBX,DFN,DT,ACTIVE)
- +8 IF +X<1
- KILL X
- DDQ QUIT
- +1 ;
- VAR SET DFN=$PIECE(^IBT(356.2,IBDA,0),"^",5)
- +1 IF DFN=""
- SET DFN=$PIECE($GET(^IBT(356,+$PIECE(^IBT(356.2,IBDA,0),"^",2),0)),"^",2)
- +2 SET ACTIVE=2
- SET INSDT=DT
- +3 QUIT
- +4 ;
- SEL(IBX,DFN,INSDT,ACTIVE) ; -- Select insurance policy
- +1 ; -- Input IBX = x from input transform
- +2 ; DFN = patient
- +3 ; INSDT = (optional) Active date of ins. (default = dt)
- +4 ; ACTIVE = (optional) 1 if want active (default)
- +5 ; = 2 if want all ins returned
- +6 ;
- +7 ; -- Output = pointer to 36 ^ pointer to 2.3121 ^ pointer to 355.3
- +8 ;
- +9 NEW I,J,Y,DA,DE,DQ,DR,DIC,DIE,DIR,DIV,IBSEL,IBDD,IBD
- +10 SET IBSEL=1
- SET Y=""
- +11 IF '$GET(ACTIVE)
- SET ACTIVE=2
- +12 if '$GET(INSDT)
- SET INSDT=DT
- +13 IF '$GET(DFN)
- GOTO SELQ
- +14 DO BLD
- +15 ;
- +16 ; -- call DIC to choose from list
- +17 SET X=IBX
- +18 SET DIC="^DPT("_DFN_",.312,"
- SET DIC(0)="EQMN"
- +19 SET DIC("S")="I $D(IBDD(+Y))"
- +20 SET DIC("W")="W $P(^DIC(36,+^(0),0),U)_"" Group: ""_$$GRP^IBCNS($P(^DPT(DFN,.312,+Y,0),U,18))"
- +21 DO ^DIC
- SELQ QUIT +Y
- +1 ;
- BLD KILL IBD,IBDD
- +1 SET (IBDD,IBCDFN)=0
- FOR
- SET IBCDFN=$ORDER(^DPT(+DFN,.312,IBCDFN))
- if 'IBCDFN
- QUIT
- IF $DATA(^DPT(DFN,.312,+IBCDFN,0))
- DO CHK(IBCDFN,ACTIVE,INSDT)
- +2 QUIT
- +3 ;
- CHK(IBCDFN,ACTIVE,INSDT) ; -- see if active
- +1 NEW X,X1
- +2 SET X=$GET(^DPT(DFN,.312,IBCDFN,0))
- +3 SET IBDD(IBCDFN)=+X_"^"_IBCDFN_"^"_$PIECE(X,"^",18)
- +4 IF ACTIVE=2
- GOTO CHKQ
- +5 ;ins co entry doesn't exist
- SET X1=$GET(^DIC(36,+X,0))
- IF X1=""
- GOTO CQ
- +6 ;effective date later than care
- IF $PIECE(X,"^",8)
- if INSDT<$PIECE(X,"^",8)
- GOTO CQ
- +7 ;care after expiration date
- IF $PIECE(X,"^",4)
- if INSDT>$PIECE(X,"^",4)
- GOTO CQ
- +8 ;plan is inactive
- IF $PIECE($GET(^IBA(355.3,+$PIECE(X,"^",18),0)),"^",11)
- GOTO CQ
- +9 ; ;ins company inactive
- if $PIECE(X1,"^",5)
- GOTO CQ
- +10 ; ;ins company will not reimburse
- if $PIECE(X1,"^",2)="N"
- GOTO CQ
- +11 GOTO CHKQ
- CQ KILL IBDD(IBCDFN)
- CHKQ if $DATA(IBDD(IBCDFN))
- SET IBDD=IBDD+1
- SET IBD(IBDD)=IBCDFN
- +1 QUIT
- +2 ;
- +3 ;
- DDHELP(IBDA) ; -- Executable help
- +1 ; -- write out list to choose from
- +2 NEW DFN,INSDT,ACTIVE,IBDD,IBD,IBCDFN,I,IBINS
- +3 DO VAR
- DO BLD
- +4 ;
- +5 IF $GET(IBDD)=0
- WRITE !,"No Insurance Policies to Select From"
- GOTO DDHQ
- +6 ;
- +7 IF '$DATA(IOM)
- DO HOME^%ZIS
- +8 WRITE !
- DO HDR^IBCNS
- +9 SET I=0
- FOR
- SET I=$ORDER(IBD(I))
- if 'I
- QUIT
- Begin DoDot:1
- +10 SET IBINS=$GET(^DPT(DFN,.312,$GET(IBD(I)),0))
- +11 DO D1^IBCNS
- End DoDot:1
- DDHQ QUIT
- +1 ;
- TRANS(IBDA,Y) ; -- output transform
- +1 NEW DFN,INSDT,ACTIVE,IBDD,IBD,IBCDFN
- +2 DO VAR
- +3 SET Y=$PIECE($GET(^DIC(36,+$PIECE($GET(^DPT(DFN,.312,+$GET(Y),0)),U),0)),U)
- +4 QUIT Y
- +5 ;
- INSCO(IBDA,IBCDFN) ; -- return pointer value of 36 from pt. file
- +1 NEW DFN,INSDT,ACTIVE,IBDD,IBD
- +2 DO VAR
- +3 SET Y=+$GET(^DPT(DFN,.312,IBCDFN,0))
- +4 QUIT Y_$SELECT(Y>0:"^"_$PIECE($GET(^DIC(36,+Y,0)),"^"),1:"")