IBCNBMN ;ALB/ARH-Ins Buffer: add new insurance file entrys ; 4/22/03 10:00am
;;2.0;INTEGRATED BILLING;**82,211,519**;21-MAR-94;Build 56
;;Per VA Directive 6402, this routine should not be modified.
;
;
NEWINS(IBBUFDA) ; add new insurance carrier entry in Insurance Company (#36) file
;
N DIC,DA,DIE,DR,X,Y,DLAYGO,IBINSDA,IB20,IBINSNM,IBREIMB S IBINSDA=0,IB20=$G(^IBA(355.33,+$G(IBBUFDA),20))
S IBINSNM=$P(IB20,U,1) I IBINSNM="" G NIQ
;
S IBREIMB=$P(IB20,U,5) I IBREIMB'="" S DIC("DR")="1///"_IBREIMB ; will reimburse?
K DD,DO S DIC="^DIC(36,",DIC(0)="L",X=IBINSNM,DLAYGO=36 D FILE^DICN I +Y>0 S IBINSDA=+Y
;
NIQ Q IBINSDA
;
NEWGRP(IBBUFDA,IBINSDA) ; add a new group/plan to the Group Insurance Plan (#355.3) file, also add standard fields
;
N DIC,DA,DR,DIE,X,Y,DLAYGO,IBGRPDA,IB40,IBFIELDS,IBERR,IBXIFN S IBGRPDA=0,IB40=$G(^IBA(355.33,+$G(IBBUFDA),40))
I '$D(^DIC(36,+$G(IBINSDA),0)) G NGQ
I $P(IB40,U,1)=0,'$G(^IBA(355.33,+$G(IBBUFDA),60)) G NGQ
;
K DA,DO S DIC="^IBA(355.3,",DIC(0)="L",X=IBINSDA,DLAYGO=355.3 D FILE^DICN I +Y'>0 G NGQ
S IBGRPDA=+Y,IBXIFN=IBGRPDA_","
;
S IBFIELDS(355.3,IBXIFN,.02)=$P(IB40,U,1) ; group plan?
I $P(IB40,U,1)=0 S IBFIELDS(355.3,IBXIFN,.1)=+$G(^IBA(355.33,+$G(IBBUFDA),60)) ; individual plan patient
D FILE^DIE("","IBFIELDS","IBERR")
;
; IB*2.0*519: If new group added, check to see if we already have a NIF ID for this insurance company.
; if no NIF and we have not yet requested one, send an HL7
I '$$NIF^IBCNHUT1(+$G(IBINSDA)),'$D(^IBCNH(367.1,"INS",+$G(IBINSDA))) D SEND^IBCNHHLO(+$G(IBINSDA))
;
NGQ Q IBGRPDA
;
NEWPOL(IBBUFDA,IBINSDA,IBGRPDA) ; add a new patient policy to the Patient's Insurance Policys (2.312), also add standard fields
;
N DIC,DA,DR,DIE,X,Y,IBPOLDA,IBFIELDS,IBERR,DFN,IBGRP,IBXIFN S IBPOLDA=0
I '$D(^DIC(36,+$G(IBINSDA),0)) G NPQ
S IBGRP=$G(^IBA(355.3,+$G(IBGRPDA),0)) I +IBGRP'=IBINSDA G NPQ
S DFN=+$G(^IBA(355.33,+$G(IBBUFDA),60)) I 'DFN G NPQ
I $P(IBGRP,U,10)'="",$P(IBGRP,U,10)'=DFN G NPQ
;
; IB*2*211
L +^DPT(DFN,.312):5 I '$T D LOCKED^IBTRCD1 G NPQ
I $G(^DPT(DFN,.312,0))="" S ^DPT(DFN,.312,0)="^2.312PAI^^"
;
K DA,DO S DIC="^DPT("_DFN_",.312,",DIC(0)="L",X=IBINSDA,DA(1)=DFN D FILE^DICN I +Y'>0 G NPQ
S IBPOLDA=+Y,IBXIFN=IBPOLDA_","_DFN_","
;
S IBFIELDS(2.312,IBXIFN,.18)=IBGRPDA ; policy's group/plan
S IBFIELDS(2.312,IBXIFN,1.09)=$P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,3) ; source
S IBFIELDS(2.312,IBXIFN,1.1)=+$G(^IBA(355.33,+$G(IBBUFDA),0)) ; source date
D FILE^DIE("","IBFIELDS","IBERR")
L -^DPT(DFN,.312)
;
NPQ Q IBPOLDA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBMN 2745 printed Dec 13, 2024@02:14:10 Page 2
IBCNBMN ;ALB/ARH-Ins Buffer: add new insurance file entrys ; 4/22/03 10:00am
+1 ;;2.0;INTEGRATED BILLING;**82,211,519**;21-MAR-94;Build 56
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
NEWINS(IBBUFDA) ; add new insurance carrier entry in Insurance Company (#36) file
+1 ;
+2 NEW DIC,DA,DIE,DR,X,Y,DLAYGO,IBINSDA,IB20,IBINSNM,IBREIMB
SET IBINSDA=0
SET IB20=$GET(^IBA(355.33,+$GET(IBBUFDA),20))
+3 SET IBINSNM=$PIECE(IB20,U,1)
IF IBINSNM=""
GOTO NIQ
+4 ;
+5 ; will reimburse?
SET IBREIMB=$PIECE(IB20,U,5)
IF IBREIMB'=""
SET DIC("DR")="1///"_IBREIMB
+6 KILL DD,DO
SET DIC="^DIC(36,"
SET DIC(0)="L"
SET X=IBINSNM
SET DLAYGO=36
DO FILE^DICN
IF +Y>0
SET IBINSDA=+Y
+7 ;
NIQ QUIT IBINSDA
+1 ;
NEWGRP(IBBUFDA,IBINSDA) ; add a new group/plan to the Group Insurance Plan (#355.3) file, also add standard fields
+1 ;
+2 NEW DIC,DA,DR,DIE,X,Y,DLAYGO,IBGRPDA,IB40,IBFIELDS,IBERR,IBXIFN
SET IBGRPDA=0
SET IB40=$GET(^IBA(355.33,+$GET(IBBUFDA),40))
+3 IF '$DATA(^DIC(36,+$GET(IBINSDA),0))
GOTO NGQ
+4 IF $PIECE(IB40,U,1)=0
IF '$GET(^IBA(355.33,+$GET(IBBUFDA),60))
GOTO NGQ
+5 ;
+6 KILL DA,DO
SET DIC="^IBA(355.3,"
SET DIC(0)="L"
SET X=IBINSDA
SET DLAYGO=355.3
DO FILE^DICN
IF +Y'>0
GOTO NGQ
+7 SET IBGRPDA=+Y
SET IBXIFN=IBGRPDA_","
+8 ;
+9 ; group plan?
SET IBFIELDS(355.3,IBXIFN,.02)=$PIECE(IB40,U,1)
+10 ; individual plan patient
IF $PIECE(IB40,U,1)=0
SET IBFIELDS(355.3,IBXIFN,.1)=+$GET(^IBA(355.33,+$GET(IBBUFDA),60))
+11 DO FILE^DIE("","IBFIELDS","IBERR")
+12 ;
+13 ; IB*2.0*519: If new group added, check to see if we already have a NIF ID for this insurance company.
+14 ; if no NIF and we have not yet requested one, send an HL7
+15 IF '$$NIF^IBCNHUT1(+$GET(IBINSDA))
IF '$DATA(^IBCNH(367.1,"INS",+$GET(IBINSDA)))
DO SEND^IBCNHHLO(+$GET(IBINSDA))
+16 ;
NGQ QUIT IBGRPDA
+1 ;
NEWPOL(IBBUFDA,IBINSDA,IBGRPDA) ; add a new patient policy to the Patient's Insurance Policys (2.312), also add standard fields
+1 ;
+2 NEW DIC,DA,DR,DIE,X,Y,IBPOLDA,IBFIELDS,IBERR,DFN,IBGRP,IBXIFN
SET IBPOLDA=0
+3 IF '$DATA(^DIC(36,+$GET(IBINSDA),0))
GOTO NPQ
+4 SET IBGRP=$GET(^IBA(355.3,+$GET(IBGRPDA),0))
IF +IBGRP'=IBINSDA
GOTO NPQ
+5 SET DFN=+$GET(^IBA(355.33,+$GET(IBBUFDA),60))
IF 'DFN
GOTO NPQ
+6 IF $PIECE(IBGRP,U,10)'=""
IF $PIECE(IBGRP,U,10)'=DFN
GOTO NPQ
+7 ;
+8 ; IB*2*211
+9 LOCK +^DPT(DFN,.312):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO NPQ
+10 IF $GET(^DPT(DFN,.312,0))=""
SET ^DPT(DFN,.312,0)="^2.312PAI^^"
+11 ;
+12 KILL DA,DO
SET DIC="^DPT("_DFN_",.312,"
SET DIC(0)="L"
SET X=IBINSDA
SET DA(1)=DFN
DO FILE^DICN
IF +Y'>0
GOTO NPQ
+13 SET IBPOLDA=+Y
SET IBXIFN=IBPOLDA_","_DFN_","
+14 ;
+15 ; policy's group/plan
SET IBFIELDS(2.312,IBXIFN,.18)=IBGRPDA
+16 ; source
SET IBFIELDS(2.312,IBXIFN,1.09)=$PIECE($GET(^IBA(355.33,+$GET(IBBUFDA),0)),U,3)
+17 ; source date
SET IBFIELDS(2.312,IBXIFN,1.1)=+$GET(^IBA(355.33,+$GET(IBBUFDA),0))
+18 DO FILE^DIE("","IBFIELDS","IBERR")
+19 LOCK -^DPT(DFN,.312)
+20 ;
NPQ QUIT IBPOLDA
