Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNS1

IBCNS1.m

Go to the documentation of this file. 
  1. IBCNS1	;ALB/AAS - INSURANCE MANAGEMENT SUPPORTED FUNCTIONS ; 22-JULY-91
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. INSURED(DFN,IBINDT)	; -- Is patient insured
  1. 	; --Input  DFN     = patient
  1. 	;          IBINDT  = (optional) date insured (default = today)
  1. 	; -- Output        = 0 - not insured
  1. 	;                  = 1 - insured
  1. 	;
  1. 	N J,X,IBINS S IBINS=0,J=0
  1. 	I '$G(IBINDT) S IBINDT=DT
  1. 	F  S J=$O(^DPT(DFN,.312,J)) Q:'J  S X=$G(^(J,0)) S IBINS=$$CHK(X,IBINDT) Q:IBINS
  1. INSQ	Q IBINS
  1. 	;
  1. PRE(DFN,IBINDT)	; -- is pre-certification required for patient
  1. 	N X,Y,J,IBPRE
  1. 	S IBPRE=0,J=0
  1. 	S:'$G(IBINDT) IBINDT=DT
  1. 	F  S J=$O(^DPT(DFN,.312,J)) Q:'J  S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",6) S IBPRE=1 Q
  1. PREQ	Q IBPRE
  1. 	;
  1. UR(DFN,IBINDT)	; -- is ur required for patient
  1. 	N X,Y,J,IBPRE
  1. 	S IBUR=0,J=0
  1. 	S:'$G(IBINDT) IBINDT=DT
  1. 	F  S J=$O(^DPT(DFN,.312,J)) Q:'J  S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",5) S IBUR=1 Q
  1. URQ	Q IBUR
  1. 	;
  1. CHK(X,Z,Y)	; -- check one entry for active
  1. 	; --  Input   X    = Zeroth node of entry in insurance multiple (2.312)
  1. 	;             Z    = date to check
  1. 	;             Y    = 2 if want will not reimburse
  1. 	; --  Output  1    = Insurance Active
  1. 	;             0    = Inactive
  1. 	;
  1. 	N Z1,X1 S Z1=0
  1. 	I $$INDEM(X) G CHKQ ; is and indemnity policy or company
  1. 	S X1=$G(^DIC(36,+X,0)) G:X1="" CHKQ ;insurance company entry doesn't exist
  1. 	I $P(X,"^",8) G:Z<$P(X,"^",8) CHKQ ;effective date later than care
  1. 	I $P(X,"^",4) G:Z>$P(X,"^",4) CHKQ ;care after expiration date
  1. 	G:$P(X1,"^",5) CHKQ ;insurance company inactive
  1. 	I $G(Y)'=2 G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse
  1. 	S Z1=1
  1. CHKQ	Q Z1
  1. 	;
  1. ACTIVE(IBCIFN)	; -- is this company active for this patient for this date
  1. 	; -- called from input transform and x-refs for fields 101,102,103
  1. 	; -- input
  1. 	N ACTIVE,DFN,IBINDT
  1. 	S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
  1. 	;
  1. ACTIVEQ	Q ACTIVE
  1. 	;
  1. DD	;  - called from input transform and x-refs for field 101,102,103
  1. 	;  - input requires da=internal entry number in 399
  1. 	;  - outputs IBdd(ins co.) array
  1. 	N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
  1. 	D ALLACT
  1. DDQ	K IBINDT Q
  1. 	;
  1. 	;
  1. ALLACT	; -- return active insurance zeroth nodes in ibdd(ins co,entry in mult)
  1. 	N X,X1
  1. 	S (X1,IBDD)=0
  1. 	F  S X1=$O(^DPT(DFN,.312,X1)) Q:'X1  S X=$G(^(X,0)) I $$CHK(X,IBINDT) S IBDD(+X,X1)=X
  1. 	;
  1. ALLACTQ	Q
  1. 	;
  1. HDR	W !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires" S X="",$P(X,"=",IOM-4)="" W !?4,X
  1. 	Q
  1. 	;
  1. 	;
  1. D1	N X Q:'$D(IBINS)
  1. 	W !?4,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN")
  1. 	W ?22,$E($P(IBINS,"^",2),1,16)
  1. 	W ?40,$E($$GRP^IBCNS($P(IBINS,"^",18)),1,10)
  1. 	S X=$P(IBINS,"^",6) W ?52,$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
  1. 	W ?60,$$DAT1^IBOUTL($P(IBINS,"^",8)),?70,$$DAT1^IBOUTL($P(IBINS,"^",4))
  1. 	Q
  1. 	;
  1. ALL(DFN,VAR,ACT,ADT)	; -- find all insurance data on a patient
  1. 	;
  1. 	; -- input DFN  = patient
  1. 	;          VAR  = variable to output in format of abc
  1. 	;                 or abc(dfn)
  1. 	;                 or ^tmp($j,"Insurance")
  1. 	;          ACT  = 1 if only active ins. desired
  1. 	;               = 2 if active and will not reimburse desired (medicare)
  1. 	;          ADT  = if ACT=1, then ADT is the internal date to check
  1. 	;                 active for, default = dt
  1. 	;
  1. 	; -- output var(0)   =: number of entries insurance multiple
  1. 	;           var(x,0) =: ^dpt(dfn,.312,x,0)
  1. 	;           var(x,1) =: ^dpt(dfn,.312,x,1)
  1. 	;           var(x,2) =: ^dpt(dfn,.312,x,2)
  1. 	;
  1. 	N X
  1. 	S X=0 I $G(ACT),$E($G(ADT),1,7)'?7N S ADT=DT
  1. 	F  S X=$O(^DPT(DFN,.312,X)) Q:'X  D
  1. 	.I $G(ACT),'$$CHK(^DPT(DFN,.312,X,0),ADT,$G(ACT)) Q
  1. 	.S @VAR@(0)=$G(@VAR@(0))+1
  1. 	.S @VAR@(X,0)=$$ZND(DFN,X)
  1. 	.S @VAR@(X,1)=$G(^DPT(DFN,.312,X,1))
  1. 	.S @VAR@(X,2)=$G(^DPT(DFN,.312,X,2))
  1. 	.S @VAR@(X,355.3)=$G(^IBA(355.3,+$P($G(^DPT(DFN,.312,X,0)),"^",18),0))
  1. ALLQ	Q
  1. 	;
  1. ZND(DFN,NODE)	; -- set group number and group name back into zeroth node of ins. type
  1. 	N X,Y S (X,Y)=""
  1. 	I '$G(DFN)!('$G(NODE)) G ZNDQ
  1. 	S X=$G(^DPT(+DFN,.312,+NODE,0))
  1. 	S Y=$G(^IBA(355.3,+$P(X,"^",18),0)) I Y="" G ZNDQ
  1. 	S $P(X,"^",3)=$P(Y,"^",4) ; move group number
  1. 	S $P(X,"^",15)=$P(Y,"^",3) ; move group name
  1. 	;
  1. ZNDQ	Q X
  1. 	;
  1. INDEM(X)	; -- is this and indemnity plan
  1. 	; -- input zeroth node if insurance type field
  1. 	N IBINDEM,IBCTP
  1. 	S IBINDEM=1
  1. 	I $P($G(^DIC(36,+X,0)),"^",13)=15 G INDEMQ ; company is indemnity co.
  1. 	S IBCTP=$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",9)
  1. 	I IBCTP,$P($G(^IBE(355.1,+IBCTP,0)),"^",3)=9 G INDEMQ ; plan is and indemnity plan
  1. 	S IBINDEM=0
  1. INDEMQ	Q IBINDEM