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

IBCNSU.m

Go to the documentation of this file. 
  1. IBCNSU	;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. AB(IBCPOL,IBYR,IBASK)	; -- Return entry in Annual Benefits file
  1. 	;  Input:  IBCPOL  = pointer to health insurance policy file
  1. 	;          IBYR    = fileman internal date, Default = dt
  1. 	;          IBASK   = 1 if want to ask okay to add new entry
  1. 	;
  1. 	; Output:  IBCAB   = pointer to Annual Benefits file if added, else null
  1. 	;
  1. 	N DIR,IBCAB
  1. 	S IBCAB=""
  1. 	I $G(IBCPOL)="" G ABQ
  1. 	I $G(IBYR)="" S IBYR=DT
  1. 	;S IBYR=$E(IBYR,1,3)_"0000"
  1. 	;
  1. 	; -- try to find entry for policy for year
  1. 	S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0))
  1. 	;
  1. 	; -- if no match add new entry
  1. 	I 'IBCAB D
  1. 	.I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Annual Benefits YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
  1. 	.S IBCAB=$$ADDB(IBCPOL,IBYR)
  1. 	.Q
  1. ABQ	Q IBCAB
  1. 	;
  1. ADDB(IBCPOL,IBYR)	; -- add entries to Annual Benefits file
  1. 	;  Input:  IBCPOL  = pointer to health insurance policy file
  1. 	;          IBYR    = fileman internal date, Default = dt
  1. 	;
  1. 	; Output:  IBCAB   = pointer to Annual Benefits file if added, else null
  1. 	;
  1. 	N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
  1. 	S IBCAB=""
  1. 	I $G(IBCPOL)="" G ADDBQ
  1. 	I $G(IBYR)="" S IBYR=DT
  1. 	K DD,DO,DIC,DR S DIC="^IBA(355.4,",DIC(0)="L",DLAYGO=355.4
  1. 	;
  1. 	;S X=$E(IBYR,1,3)_"0000"
  1. 	S X=IBYR D FILE^DICN I +Y<0 G ADDBQ
  1. 	S (IBCAB,DA)=+Y,DIE="^IBA(355.4,",DR=".02////"_IBCPOL
  1. 	D ^DIE K DIC,DIE,DA,DR
  1. ADDBQ	Q IBCAB
  1. 	;
  1. CHIP(IBCDFND)	; -- convert node with no hip pointer to one with hip pointer
  1. 	;   Input:  IBCDFND  = zeroth node of insurance type multiple
  1. 	;                    = ^dpt(dfn,.312,ibcdfn,0)
  1. 	;
  1. 	;  Output:  IBCPOL   = pointer to policy file
  1. 	;
  1. 	N IBCNS,IBGRP,IBGRNA,IBGRNU
  1. 	S IBCNS=+IBCDFND,IBGRNA=$P(IBCDFND,"^",15),IBGRNU=$P(IBCDFND,"^",3),IBGRP=0
  1. 	I IBGRNA'=""!(IBGRNU'="") S IBGRP=1
  1. 	S IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU)
  1. CHIPQ	Q IBCPOL
  1. 	;
  1. HIP(IBCNS,IBGRP,IBGRNA,IBGRNU)	; -- find internal entry number in policy file
  1. 	;  Input:  IBCNS  = pointer to ins co file
  1. 	;          IBGRP  = 1 if group policy, 0 if not
  1. 	;          IBGRNA = group name
  1. 	;          IBGRNU = group number
  1. 	;
  1. 	; Output:  IBCPOL = pointer to policy file
  1. 	;
  1. 	N %DT
  1. 	S IBCPOL=""
  1. 	I $G(^DIC(36,+$G(IBCNS),0))="" G HIPQ
  1. 	S IBGRP=+$G(IBGRP) ; if undefine, is not a group policy
  1. 	I 'IBGRP S IBCPOL=$$ADDH(IBCNS,IBGRP) G HIPQ
  1. 	;
  1. 	S:$G(IBGRNU)="" IBGRNU="IB ZZZZZ"
  1. 	I IBGRNU'="IB ZZZZZ" S IBCPOL=$O(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0))
  1. 	I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA G HIPQ ; match both
  1. 	;
  1. 	S:$G(IBGRNA)="" IBGRNA="IB ZZZZZ"
  1. 	S IBCPOL=$O(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0))
  1. 	I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU G HIPQ ; match both
  1. 	;
  1. 	I 'IBCPOL S IBCPOL=$$ADDH(IBCNS,IBGRP) D
  1. 	.I IBGRNA="",IBGRNU="" Q
  1. 	.S:IBGRNA="IB ZZZZZ" IBGRNA="" S:IBGRNU="IB ZZZZZ" IBGRNU=""
  1. 	.S DA=IBCPOL,DIE="^IBA(355.3,",DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";")
  1. 	.D ^DIE K DA,DR,DIC,DIE
  1. HIPQ	Q IBCPOL
  1. 	;
  1. ADDH(IBCNS,IBGRP)	; -- add entries to health insurance policy file (355.3)
  1. 	;     Input:  IBCNS  = pointer to ins co file
  1. 	;             IBGRP  = 1 if group policy, 0 if no
  1. 	;
  1. 	;    Output:  IBCPOL = pointer to policy file, if added else null
  1. 	;
  1. 	N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
  1. 	S IBCPOL=""
  1. 	I $G(IBCNS)="" G ADDBQ
  1. 	K DD,DO,DIC,DR S DIC="^IBA(355.3,",DIC(0)="L",DLAYGO=355.3
  1. 	;
  1. 	S X=IBCNS D FILE^DICN I +Y<0 G ADDHQ
  1. 	S (DA,IBCPOL)=+Y,DIE="^IBA(355.3,",DR=".02////"_+$G(IBGRP)
  1. 	I IBGRP=0,$G(DFN) S DR=DR_";.1////"_DFN
  1. 	D ^DIE K DA,DR,DIE,DIC
  1. 	I $G(IBCNTP)'="" S IBCNTP=IBCNTP+1
  1. ADDHQ	Q IBCPOL
  1. 	;
  1. DELP(DFN,INS)	; -- can an insurance policy be deleted
  1. 	; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
  1. 	; -- input  dfn: ien of patient in file 2.
  1. 	;           ins: ien of ins. co in file 36
  1. 	;
  1. 	; -- output      1 if no deletion allowed
  1. 	;                 0 if deletion allowed
  1. 	N I,X,Y S X=0
  1. 	;
  1. 	; -- do not delete if any uncancelled bills
  1. 	S J=0 F  S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J  I $P(^DGCR(399,J,"S"),"^",17)="" S X=1 Q
  1. DELPQ	Q X
  1. 	;
  1. STRIP(X,X1)	; -- strip characters from string
  1. 	;    input:  x  = string
  1. 	;            x1 = character to strip (default is ";"
  1. 	N I,X2
  1. 	S X2="" S:$G(X1)="" X1=";"
  1. 	S X1=$E(X1)
  1. 	F I=1:1 S X2=X2_$P(X,X1,I) Q:($P(X,X1,I+1,999)'[X1)
  1. 	Q X2