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

IBCNS2.m

Go to the documentation of this file. 
  1. IBCNS2	;ALB/AAS - INSURANCE POLICY CALLS FROM FILE 399 DD ; 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. 	Q
  1. DD(IBX,IBDA,LEVEL)	;  - called from input transform for field 111,112,113
  1. 	; -- input   ibx = x from input transform
  1. 	;           ibda = internal entry in 399
  1. 	;          level = 1=primary, 2=secondary, 3=tertiary
  1. 	; -- output  returns x=internal entry in 2.3121 (ins. Mult.) if valid
  1. 	;   
  1. 	N DFN,ACTIVE,INSDT
  1. 	D VAR
  1. 	S X=$$SEL(IBX,DFN,INSDT,ACTIVE)
  1. 	I +X<1 K X
  1. DDQ	Q
  1. 	;
  1. VAR	S DFN=$P(^DGCR(399,IBDA,0),"^",2),ACTIVE=1,INSDT=$S(+$G(^DGCR(399,IBDA,"U")):+$G(^("U")),1:DT)
  1. 	Q
  1. 	;
  1. SEL(IBX,DFN,INSDT,ACTIVE)	; -- Select insurance policy
  1. 	; -- Input    IBX  = x from input transform
  1. 	;             DFN  = patient
  1. 	;           INSDT  = (optional) Active date of ins. (default = dt)
  1. 	;          ACTIVE  = (optional) 1 if want active (default)
  1. 	;                  = 2 if want all ins returned
  1. 	;
  1. 	; -- Output      =  pointer to 36 ^ pointer to 2.3121 ^ pointer to 355.3
  1. 	;
  1. 	N I,J,Y,DA,DE,DQ,DR,DIC,DIE,DIR,DIV,IBSEL,IBDD,IBD
  1. 	S IBSEL=1,Y=""
  1. 	I '$G(ACTIVE) S ACTIVE=1
  1. 	S:'$G(INSDT) INSDT=DT
  1. 	I '$G(DFN) G SELQ
  1. 	D BLD
  1. 	;
  1. 	; -- call DIC to choose from list
  1. 	S X=IBX
  1. 	S DIC="^DPT("_DFN_",.312,",DIC(0)="EQMN"
  1. 	S DIC("S")="I $D(IBDD(+Y))" ; add not other selection
  1. 	S DIC("W")="W $P(^DIC(36,+^(0),0),U)_""  Group: ""_$$GRP^IBCNS($P(^DPT(DFN,.312,+Y,0),U,18))"
  1. 	D ^DIC
  1. SELQ	Q +Y
  1. 	;
  1. BLD	K IBD,IBDD
  1. 	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)
  1. 	Q
  1. 	;
  1. CHK(IBCDFN,ACTIVE,INSDT)	; -- see if active
  1. 	N X,X1
  1. 	S X=$G(^DPT(DFN,.312,IBCDFN,0))
  1. 	S IBDD(IBCDFN)=+X_"^"_IBCDFN_"^"_$P(X,"^",18)
  1. 	I ACTIVE=2 G CHKQ
  1. 	S X1=$G(^DIC(36,+X,0)) I X1="" G CQ ;ins co entry doesn't exist
  1. 	I $P(X,"^",8) G:INSDT<$P(X,"^",8) CQ ;effective date later than care
  1. 	I $P(X,"^",4) G:INSDT>$P(X,"^",4) CQ ;care after expiration date
  1. 	G:$P(X1,"^",5) CQ ;                  ;ins company inactive
  1. 	G:$P(X1,"^",2)="N" CQ ;              ;ins company will not reimburse
  1. 	G CHKQ
  1. CQ	K IBDD(IBCDFN)
  1. CHKQ	S:$D(IBDD(IBCDFN)) IBDD=IBDD+1,IBD(IBDD)=IBCDFN
  1. 	Q
  1. 	;
  1. 	;
  1. DDHELP(IBDA,LEVEL)	; -- Executable help
  1. 	; -- write out list to choose from
  1. 	N DFN,ACTIVE,INSDT,I,IBINS
  1. 	D VAR,BLD
  1. 	;
  1. 	I $G(IBDD)=0 W !,"No Insurance Policies to Select From" G DDHQ
  1. 	;
  1. 	I '$D(IOM) D HOME^%ZIS
  1. 	W ! D HDR^IBCNS
  1. 	S I=0 F  S I=$O(IBD(I)) Q:'I  D
  1. 	.S IBINS=$G(^DPT(DFN,.312,$G(IBD(I)),0))
  1. 	.D D1^IBCNS
  1. DDHQ	Q
  1. 	;
  1. TRANS(IBDA,Y)	; -- output transform
  1. 	N DFN,ACTIVE,INSDT
  1. 	D VAR
  1. 	S Y=$P($G(^DIC(36,+$P($G(^DPT(DFN,.312,+$G(Y),0)),U),0)),U)
  1. 	Q Y
  1. 	;
  1. INSCO(IBDA,IBCDFN)	; -- return pointer value of 36 from pt. file
  1. 	N DFN,ACTIVE,INSDT
  1. 	D VAR
  1. 	S Y=+$G(^DPT(DFN,.312,IBCDFN,0))
  1. 	Q Y_$S(Y>0:"^"_$P($G(^DIC(36,+Y,0)),"^"),1:"")
  1. 	;
  1. IX(DA,XREF)	; -- create i1, aic xrefs for fields 112, 113, 114
  1. 	;
  1. 	S ^DGCR(399,DA,XREF)=$$ZND^IBCNS1($P($G(^DGCR(399,DA,0)),"^",2),X)
  1. 	S ^DGCR(399,DA,"AIC",+$G(^DPT($P($G(^DGCR(399,DA,0)),"^",2),.312,+X,0)))=""
  1. 	Q
  1. 	;
  1. KIX(DA,XREF)	; -- kill logic for above xref
  1. 	K ^DGCR(399,DA,XREF)
  1. 	K ^DGCR(399,DA,"AIC",+$G(^DPT($P($G(^DGCR(399,DA,0)),"^",2),.312,+X,0)))
  1. 	Q