IBCNERTC ;AITC/HN - Covered by Health Insurance ;03-MAR-2017
;;2.0;INTEGRATED BILLING;**593**;21-MAR-94;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This program will loop through the ACHI Index of the Patient (2) file to update the
; Covered by Health Insurance (2.3192) field based on current active policies.
;
; This option is designed to run through TaskMan after midnight. It shouldn't take long since there
; should not be many entries in the ACHI index per day.
;
; UPATF should be used with care since it will process the entire Patient File
;
Q
;
EN(IBDT) ;From Taskman nightly job. Call from label TASK.
N DFN
S DFN=""
F S DFN=$O(^DPT("ACHI",IBDT,DFN)) Q:'DFN D INS(DFN,IBDT)
Q
;
INS(DFN,IBDT) ;Check insurance
N DA,DIE,IBCOV,IBIND,IBINS,IBNCOV,DR,IBINSD,IENS,EFFDT,IBIENS,DEFIND,IBIEN,IBSYM
S (IBCOV,IBNCOV)=$$GET1^DIQ(2,DFN_",","COVERED BY HEALTH INSURANCE?","I")
D ALL^IBCNS1(DFN,"IBINS",2,IBDT) S IBINSD=+$G(IBINS(0))
;
; -- initial value ="" or Unknown
I $TR(IBCOV,"U","")']"" S IBNCOV=$S('$O(^DPT(DFN,.312,0)):"U",IBINSD:"Y",1:"N")
; -- initial value = YES or NO (treat the same)
I "YN"[IBCOV S IBNCOV=$S('$O(^DPT(DFN,.312,0)):"N",IBINSD:"Y",1:"N")
;
I IBCOV'=IBNCOV S DIE="^DPT(",DR=".3192///"_IBNCOV,DA=DFN D ^DIE
;
; Create Buffer entry for those whose Effective Date = IBDT
;
S DA=0 F S DA=$O(IBINS(DA)) Q:'DA D
. S IBIEN=+IBINS(DA,0)
. S IBIENS=DA_","_DFN_","
. S EFFDT=$$GET1^DIQ(2.312,IBIENS,8,"I")
. I EFFDT'=IBDT Q
. ; Add check to see if already in buffer
. S DEFIND=$$BFEXIST(DFN,IBIEN) Q:DEFIND=1
. S IBSYM=$P($$INSERROR^IBCNEUT3("I",IBIEN),"^",1)
. D PT^IBCNEBF(DFN,DA,IBSYM,,1)
Q
;
UPATF ;Update the entire Patient File
; This should be tasked for late evening since it will take awhile to run.
N DFN,IENS
S DFN=0
F S DFN=$O(^DPT(DFN)) Q:'DFN D
. D INS(DFN,DT)
Q
;
BFEXIST(DFN,INSNAME) ; Function returns 1 if an Entered Ins Buffer File
; entry exists with the same DFN and INSNAME, otherwise it returns a 0
;
; DFN - Patient DFN
; INSNAME - Insurance Company Name File 36 - Field .01
;
NEW EXIST,IEN,EDATE
S EXIST=0
S INSNAME=$P($G(^DIC(36,IBIEN,0)),U) ;$$TRIM^XLFSTR(INSNAME) ; trimmed
I ('DFN)!(INSNAME="") G BFEXIT
;
S IEN=0
F S IEN=$O(^IBA(355.33,"C",DFN,IEN)) Q:'IEN!EXIST D
. ; Quit if status is NOT 'Entered'
. I $$GET1^DIQ(355.33,IEN_",","STATUS","I")'="E" Q
. ; Quit if Ins Buffer Ins Co Name (trimmed) is NOT EQUAL to
. ; the Ins Co Name parameter (trimmed)
. I $$TRIM^XLFSTR($$GET1^DIQ(355.33,IEN_",","INSURANCE COMPANY NAME"))'=INSNAME Q
. ; Quit if Date Enterd Matches
. S EDATE=$P($$GET1^DIQ(355.33,IEN_",","DATE ENTERED","I"),".")
. I IBDT'=EDATE Q
. ; Match found
. S EXIST=1
. Q
BFEXIT ;
Q EXIST
;
XREF ;Build the "ACHI" cross reference
N CNT,DA,DFN,FILE,DIK,X,Y
S DFN=0
F S DFN=$O(^DPT(DFN)) Q:'DFN D
. I $$GET1^DIQ(2,DFN_","_"DATE OF DEATH") Q ;Patient Deceased
. S DA(1)=DFN
. S DIK="^DPT("_DA(1)_",.312,"
. S DIK(1)="3^ACHI"
. D ENALL^DIK
. S DIK(1)="8^ACHI"
. D ENALL^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNERTC 3196 printed Nov 22, 2024@17:25:23 Page 2
IBCNERTC ;AITC/HN - Covered by Health Insurance ;03-MAR-2017
+1 ;;2.0;INTEGRATED BILLING;**593**;21-MAR-94;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This program will loop through the ACHI Index of the Patient (2) file to update the
+6 ; Covered by Health Insurance (2.3192) field based on current active policies.
+7 ;
+8 ; This option is designed to run through TaskMan after midnight. It shouldn't take long since there
+9 ; should not be many entries in the ACHI index per day.
+10 ;
+11 ; UPATF should be used with care since it will process the entire Patient File
+12 ;
+13 QUIT
+14 ;
EN(IBDT) ;From Taskman nightly job. Call from label TASK.
+1 NEW DFN
+2 SET DFN=""
+3 FOR
SET DFN=$ORDER(^DPT("ACHI",IBDT,DFN))
if 'DFN
QUIT
DO INS(DFN,IBDT)
+4 QUIT
+5 ;
INS(DFN,IBDT) ;Check insurance
+1 NEW DA,DIE,IBCOV,IBIND,IBINS,IBNCOV,DR,IBINSD,IENS,EFFDT,IBIENS,DEFIND,IBIEN,IBSYM
+2 SET (IBCOV,IBNCOV)=$$GET1^DIQ(2,DFN_",","COVERED BY HEALTH INSURANCE?","I")
+3 DO ALL^IBCNS1(DFN,"IBINS",2,IBDT)
SET IBINSD=+$GET(IBINS(0))
+4 ;
+5 ; -- initial value ="" or Unknown
+6 IF $TRANSLATE(IBCOV,"U","")']""
SET IBNCOV=$SELECT('$ORDER(^DPT(DFN,.312,0)):"U",IBINSD:"Y",1:"N")
+7 ; -- initial value = YES or NO (treat the same)
+8 IF "YN"[IBCOV
SET IBNCOV=$SELECT('$ORDER(^DPT(DFN,.312,0)):"N",IBINSD:"Y",1:"N")
+9 ;
+10 IF IBCOV'=IBNCOV
SET DIE="^DPT("
SET DR=".3192///"_IBNCOV
SET DA=DFN
DO ^DIE
+11 ;
+12 ; Create Buffer entry for those whose Effective Date = IBDT
+13 ;
+14 SET DA=0
FOR
SET DA=$ORDER(IBINS(DA))
if 'DA
QUIT
Begin DoDot:1
+15 SET IBIEN=+IBINS(DA,0)
+16 SET IBIENS=DA_","_DFN_","
+17 SET EFFDT=$$GET1^DIQ(2.312,IBIENS,8,"I")
+18 IF EFFDT'=IBDT
QUIT
+19 ; Add check to see if already in buffer
+20 SET DEFIND=$$BFEXIST(DFN,IBIEN)
if DEFIND=1
QUIT
+21 SET IBSYM=$PIECE($$INSERROR^IBCNEUT3("I",IBIEN),"^",1)
+22 DO PT^IBCNEBF(DFN,DA,IBSYM,,1)
End DoDot:1
+23 QUIT
+24 ;
UPATF ;Update the entire Patient File
+1 ; This should be tasked for late evening since it will take awhile to run.
+2 NEW DFN,IENS
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+5 DO INS(DFN,DT)
End DoDot:1
+6 QUIT
+7 ;
BFEXIST(DFN,INSNAME) ; Function returns 1 if an Entered Ins Buffer File
+1 ; entry exists with the same DFN and INSNAME, otherwise it returns a 0
+2 ;
+3 ; DFN - Patient DFN
+4 ; INSNAME - Insurance Company Name File 36 - Field .01
+5 ;
+6 NEW EXIST,IEN,EDATE
+7 SET EXIST=0
+8 ;$$TRIM^XLFSTR(INSNAME) ; trimmed
SET INSNAME=$PIECE($GET(^DIC(36,IBIEN,0)),U)
+9 IF ('DFN)!(INSNAME="")
GOTO BFEXIT
+10 ;
+11 SET IEN=0
+12 FOR
SET IEN=$ORDER(^IBA(355.33,"C",DFN,IEN))
if 'IEN!EXIST
QUIT
Begin DoDot:1
+13 ; Quit if status is NOT 'Entered'
+14 IF $$GET1^DIQ(355.33,IEN_",","STATUS","I")'="E"
QUIT
+15 ; Quit if Ins Buffer Ins Co Name (trimmed) is NOT EQUAL to
+16 ; the Ins Co Name parameter (trimmed)
+17 IF $$TRIM^XLFSTR($$GET1^DIQ(355.33,IEN_",","INSURANCE COMPANY NAME"))'=INSNAME
QUIT
+18 ; Quit if Date Enterd Matches
+19 SET EDATE=$PIECE($$GET1^DIQ(355.33,IEN_",","DATE ENTERED","I"),".")
+20 IF IBDT'=EDATE
QUIT
+21 ; Match found
+22 SET EXIST=1
+23 QUIT
End DoDot:1
BFEXIT ;
+1 QUIT EXIST
+2 ;
XREF ;Build the "ACHI" cross reference
+1 NEW CNT,DA,DFN,FILE,DIK,X,Y
+2 SET DFN=0
+3 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+4 ;Patient Deceased
IF $$GET1^DIQ(2,DFN_","_"DATE OF DEATH")
QUIT
+5 SET DA(1)=DFN
+6 SET DIK="^DPT("_DA(1)_",.312,"
+7 SET DIK(1)="3^ACHI"
+8 DO ENALL^DIK
+9 SET DIK(1)="8^ACHI"
+10 DO ENALL^DIK
End DoDot:1
+11 QUIT
