IBTRC2 ;ALB/AAS - INSURANCE POLICY CALLS FROM FILE 356.2 DD ; 22-JULY-91
;;Version 2.0 ; INTEGRATED BILLING ;; 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
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:"")
IBTRC2 ;ALB/AAS - INSURANCE POLICY CALLS FROM FILE 356.2 DD ; 22-JULY-91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 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 ; ;ins company inactive
IF $PIECE(X1,"^",5)
GOTO CQ
+9 ; ;ins company will not reimburse
IF $PIECE(X1,"^",2)="N"
GOTO CQ
+10 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:"")
