- IBCNS ;ALB/AAS - IS INSURANCE ACTIVE ; 22-JULY-91
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;MAP TO DGCRNS
- ;
- ;Input - DFN = patient
- ; - IBINDT = (optional) date to check ins active for or today if not defined
- ; - IBOUTP = (optional) 1 if want active insurance returned in IBDD(insurance company)=node in patient file
- ; - = 2 if want all ins returned
- ;
- ;Output - IBINS = 1 if has active ins., 0 if no active ins.
- ; - IBDD() = internal node in patient file of valid ins.
- ; - IBDDI() = internal node in patient file of invalid ins.
- ;
- % N J,X S IBINS=0 K IBDD,IBDDI
- S J=0 F S J=$O(^DPT(DFN,.312,J)) Q:'J I $D(^DPT(DFN,.312,J,0)) S X=^(0) D CHK
- Q
- ;
- CHK ;
- ;Input - IBI = entry in insurance multiple
- ;
- S Z=$S($D(IBINDT):IBINDT,1:DT),Z1=$S($D(IBOUTP):IBOUTP,1:0)
- G:'$D(^DIC(36,+X,0)) CHKQ S X1=^(0) ;insurance company entry doesn't exist
- I $P(X,"^",8) G:Z<$P(X,"^",8) CHKQ ;effective date later than care
- I $P(X,"^",4) G:Z>$P(X,"^",4) CHKQ ;care after expiration date
- G:$P(X1,"^",5) CHKQ ;insurance company inactive
- G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse
- S IBINS=1 I Z1 D
- .S IBDD(+X)=X
- .Q:'$P(IBDD(+X),"^",18)
- .S Y=$G(^IBA(355.3,+$P(IBDD(+X),"^",18),0))
- .I $P(Y,"^",4)'="" S $P(IBDD(+X),"^",3)=$P(Y,"^",4) ; move group number
- .I $P(Y,"^",3)'="" S $P(IBDD(+X),"^",15)=$P(Y,"^",3) ; move group name
- CHKQ I Z1=2&('$D(IBDD(+X))) D
- .S IBDDI(+X)=X
- .Q:'$P(IBDDI(+X),"^",18)
- .S Y=$G(^IBA(355.3,+$P(IBDDI(+X),"^",18),0))
- .I $P(Y,"^",4)'="" S $P(IBDDI(+X),"^",3)=$P(Y,"^",4) ; move group number
- .I $P(Y,"^",3)'="" S $P(IBDDI(+X),"^",15)=$P(Y,"^",3) ; move group name
- K X,X1,Z,Z1,Y Q
- ;
- DD ; - called from input transform and x-refs for field 101,102,103
- ; - input requires da=internal entry number in 399
- ; - outputs IBdd(ins co.) array
- N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),IBOUTP=1,IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
- D %
- DDQ K IBOUTP,IBINDT Q
- ;
- ;
- DISP ; -Display all insurance company information
- ; -input DFN
- ;
- Q:'$D(DFN) D:'$D(IOF) HOME^%ZIS
- N X,IBINS,IBX
- D ALL^IBCNS1(DFN,"IBINS")
- ;
- D HDR
- I '$D(IBINS) W !," No Insurance Information" G DISPQ
- ;
- S X=0 F S X=$O(IBINS(X)) Q:'X S IBINS=IBINS(X,0) D D1 ; display
- ;
- DISPQ Q
- ;
- OLDISP ; -Display all insurance company information
- ; -input DFN
- ;
- Q:'$D(DFN) D:'$D(IOF) HOME^%ZIS
- ;
- S IBOUTP=2 D IBCNS
- ;
- D HDR
- I '$D(IBDD),'$D(IBDDI) W !," No Insurance Information" G DISPQ
- ;
- S X="" F S X=$O(IBDD(X)) Q:X="" S IBINS=IBDD(X) D D1 ;active insurance
- S X="" F S X=$O(IBDDI(X)) Q:X="" S IBINS=IBDDI(X) D D1 ;inactive ins
- ;
- OLDISPQ K IBDD,IBDDI,IBX
- Q
- ;
- HDR ; -- print standard header
- D HDR1("=",IOM-4)
- Q
- ;
- HDR1(CHAR,LENG) ; -- print header, specify character
- W !?4,"Insurance Co.",?22,"Subscriber ID",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires" I $G(CHAR)'="",LENG S X="",$P(X,CHAR,LENG)="" W !?4,X
- Q
- ;
- ;
- D1 N X Q:'$D(IBINS)
- W !?4,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN")
- W ?22,$E($P(IBINS,"^",2),1,16)
- ;W ?40,$E($S($P(IBINS,"^",15)'="":$P(IBINS,"^",15),1:$P(IBINS,"^",3)),1,10)
- W ?40,$E($$GRP($P(IBINS,"^",18)),1,10)
- S X=$P(IBINS,"^",6) W ?52,$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
- W ?60,$$DAT1^IBOUTL($P(IBINS,"^",8)),?70,$$DAT1^IBOUTL($P(IBINS,"^",4))
- Q
- ;
- GRP(IBCPOL) ; -- return group name/group policy
- ; input: IBCPOL = pointer to entry in 355.3
- ; output: group name or group number, if both group NUMBER
- ; if neither 'Individual PLAN'
- ;
- N X,Y S X=""
- S X=$G(^IBA(355.3,+$G(IBCPOL),0))
- S Y=$S($P(X,"^",4)'="":$P(X,"^",4),1:$P(X,"^",3))
- I $P(X,"^",10) S Y="Ind. Plan "_Y
- GRPQ Q Y
- IBCNS ;ALB/AAS - IS INSURANCE ACTIVE ; 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 ;MAP TO DGCRNS
- +5 ;
- +6 ;Input - DFN = patient
- +7 ; - IBINDT = (optional) date to check ins active for or today if not defined
- +8 ; - IBOUTP = (optional) 1 if want active insurance returned in IBDD(insurance company)=node in patient file
- +9 ; - = 2 if want all ins returned
- +10 ;
- +11 ;Output - IBINS = 1 if has active ins., 0 if no active ins.
- +12 ; - IBDD() = internal node in patient file of valid ins.
- +13 ; - IBDDI() = internal node in patient file of invalid ins.
- +14 ;
- % NEW J,X
- SET IBINS=0
- KILL IBDD,IBDDI
- +1 SET J=0
- FOR
- SET J=$ORDER(^DPT(DFN,.312,J))
- IF 'J
- QUIT
- IF $DATA(^DPT(DFN,.312,J,0))
- SET X=^(0)
- DO CHK
- +2 QUIT
- +3 ;
- CHK ;
- +1 ;Input - IBI = entry in insurance multiple
- +2 ;
- +3 SET Z=$SELECT($DATA(IBINDT):IBINDT,1:DT)
- SET Z1=$SELECT($DATA(IBOUTP):IBOUTP,1:0)
- +4 ;insurance company entry doesn't exist
- IF '$DATA(^DIC(36,+X,0))
- GOTO CHKQ
- SET X1=^(0)
- +5 ;effective date later than care
- IF $PIECE(X,"^",8)
- IF Z<$PIECE(X,"^",8)
- GOTO CHKQ
- +6 ;care after expiration date
- IF $PIECE(X,"^",4)
- IF Z>$PIECE(X,"^",4)
- GOTO CHKQ
- +7 ;insurance company inactive
- IF $PIECE(X1,"^",5)
- GOTO CHKQ
- +8 ;insurance company will not reimburse
- IF $PIECE(X1,"^",2)="N"
- GOTO CHKQ
- +9 SET IBINS=1
- IF Z1
- Begin DoDot:1
- +10 SET IBDD(+X)=X
- +11 IF '$PIECE(IBDD(+X),"^",18)
- QUIT
- +12 SET Y=$GET(^IBA(355.3,+$PIECE(IBDD(+X),"^",18),0))
- +13 ; move group number
- IF $PIECE(Y,"^",4)'=""
- SET $PIECE(IBDD(+X),"^",3)=$PIECE(Y,"^",4)
- +14 ; move group name
- IF $PIECE(Y,"^",3)'=""
- SET $PIECE(IBDD(+X),"^",15)=$PIECE(Y,"^",3)
- End DoDot:1
- CHKQ IF Z1=2&('$DATA(IBDD(+X)))
- Begin DoDot:1
- +1 SET IBDDI(+X)=X
- +2 IF '$PIECE(IBDDI(+X),"^",18)
- QUIT
- +3 SET Y=$GET(^IBA(355.3,+$PIECE(IBDDI(+X),"^",18),0))
- +4 ; move group number
- IF $PIECE(Y,"^",4)'=""
- SET $PIECE(IBDDI(+X),"^",3)=$PIECE(Y,"^",4)
- +5 ; move group name
- IF $PIECE(Y,"^",3)'=""
- SET $PIECE(IBDDI(+X),"^",15)=$PIECE(Y,"^",3)
- End DoDot:1
- +6 KILL X,X1,Z,Z1,Y
- QUIT
- +7 ;
- DD ; - called from input transform and x-refs for field 101,102,103
- +1 ; - input requires da=internal entry number in 399
- +2 ; - outputs IBdd(ins co.) array
- +3 NEW DFN
- SET DFN=$PIECE(^DGCR(399,DA,0),"^",2)
- SET IBOUTP=1
- SET IBINDT=$SELECT(+$GET(^DGCR(399,DA,"U")):+$GET(^("U")),1:DT)
- +4 DO %
- DDQ KILL IBOUTP,IBINDT
- QUIT
- +1 ;
- +2 ;
- DISP ; -Display all insurance company information
- +1 ; -input DFN
- +2 ;
- +3 IF '$DATA(DFN)
- QUIT
- IF '$DATA(IOF)
- DO HOME^%ZIS
- +4 NEW X,IBINS,IBX
- +5 DO ALL^IBCNS1(DFN,"IBINS")
- +6 ;
- +7 DO HDR
- +8 IF '$DATA(IBINS)
- WRITE !," No Insurance Information"
- GOTO DISPQ
- +9 ;
- +10 ; display
- SET X=0
- FOR
- SET X=$ORDER(IBINS(X))
- IF 'X
- QUIT
- SET IBINS=IBINS(X,0)
- DO D1
- +11 ;
- DISPQ QUIT
- +1 ;
- OLDISP ; -Display all insurance company information
- +1 ; -input DFN
- +2 ;
- +3 IF '$DATA(DFN)
- QUIT
- IF '$DATA(IOF)
- DO HOME^%ZIS
- +4 ;
- +5 SET IBOUTP=2
- DO IBCNS
- +6 ;
- +7 DO HDR
- +8 IF '$DATA(IBDD)
- IF '$DATA(IBDDI)
- WRITE !," No Insurance Information"
- GOTO DISPQ
- +9 ;
- +10 ;active insurance
- SET X=""
- FOR
- SET X=$ORDER(IBDD(X))
- IF X=""
- QUIT
- SET IBINS=IBDD(X)
- DO D1
- +11 ;inactive ins
- SET X=""
- FOR
- SET X=$ORDER(IBDDI(X))
- IF X=""
- QUIT
- SET IBINS=IBDDI(X)
- DO D1
- +12 ;
- OLDISPQ KILL IBDD,IBDDI,IBX
- +1 QUIT
- +2 ;
- HDR ; -- print standard header
- +1 DO HDR1("=",IOM-4)
- +2 QUIT
- +3 ;
- HDR1(CHAR,LENG) ; -- print header, specify character
- +1 WRITE !?4,"Insurance Co.",?22,"Subscriber ID",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires"
- IF $GET(CHAR)'=""
- IF LENG
- SET X=""
- SET $PIECE(X,CHAR,LENG)=""
- WRITE !?4,X
- +2 QUIT
- +3 ;
- +4 ;
- D1 NEW X
- IF '$DATA(IBINS)
- QUIT
- +1 WRITE !?4,$SELECT($DATA(^DIC(36,+IBINS,0)):$EXTRACT($PIECE(^(0),"^",1),1,16),1:"UNKNOWN")
- +2 WRITE ?22,$EXTRACT($PIECE(IBINS,"^",2),1,16)
- +3 ;W ?40,$E($S($P(IBINS,"^",15)'="":$P(IBINS,"^",15),1:$P(IBINS,"^",3)),1,10)
- +4 WRITE ?40,$EXTRACT($$GRP($PIECE(IBINS,"^",18)),1,10)
- +5 SET X=$PIECE(IBINS,"^",6)
- WRITE ?52,$SELECT(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
- +6 WRITE ?60,$$DAT1^IBOUTL($PIECE(IBINS,"^",8)),?70,$$DAT1^IBOUTL($PIECE(IBINS,"^",4))
- +7 QUIT
- +8 ;
- GRP(IBCPOL) ; -- return group name/group policy
- +1 ; input: IBCPOL = pointer to entry in 355.3
- +2 ; output: group name or group number, if both group NUMBER
- +3 ; if neither 'Individual PLAN'
- +4 ;
- +5 NEW X,Y
- SET X=""
- +6 SET X=$GET(^IBA(355.3,+$GET(IBCPOL),0))
- +7 SET Y=$SELECT($PIECE(X,"^",4)'="":$PIECE(X,"^",4),1:$PIECE(X,"^",3))
- +8 IF $PIECE(X,"^",10)
- SET Y="Ind. Plan "_Y
- GRPQ QUIT Y
