IBCNERTC ;AITC/HN - Covered by Health Insurance ;03-MAR-2017
;;2.0;INTEGRATED BILLING;**593,822**;21-MAR-94;Build 21
;;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
;
;
DBR ; IB*822/DTG run in background the selected insurance patients verified date check
;
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
;
; run now
S ZTDTH=$$NOW^XLFDT()
;
; Set up the other TaskManager variables
S ZTRTN="SPEC^IBCNERTC"
S ZTSAVE("IBBINSEL")=""
S ZTDESC="Daily Selected Ins Patient Verify Date Check"
S ZTIO=""
D ^%ZTLOAD ; Call TaskManager
;
DBRX ; Exit
Q
;
ER ; Unlock the eIV Nightly Task and return to log error
L -^TMP("IBCNERTCS")
I $D(ZTQUEUED) S ZTREQ="@"
D ^%ZTER
D UNWIND^%ZTER
Q
;
;
SPEC ; IB*822/DTG run re-verify for Specific Insurances
;
;
;Quit if VAMC Site is MANILA (#358) & EIV is disabled for MANILA.
I $P($$SITE^VASITE,U,3)=358,$$GET1^DIQ(350.9,"1,",51.33,"I")="N" Q
;
N $ES,$ET
S $ET="D ER^IBCNERTC"
; Check lock
L +^TMP("IBCNERTCS"):1 I '$T D G SPECX
. I '$D(ZTSK) W !!,"The Check of Selected Ins. Patients verified date is already running, please retry later." D PAUSE^VALM1
;
S IBBINSEL=$G(IBBINSEL)
I IBBINSEL="" D G SPECX:'IBBINSEL
. S IBBINSEL=+$$FIND1^DIC(200,,"MX","IB,AUTOINS FILEUPDATE") Q:IBBINSEL
. I '$D(ZTSK) W !!,"Missing the default proxy user" D PAUSE^VALM1
;
; process the selected insurance companies
;
N FDA,IBA,IBB,IBC,IBCO,IBCON,IBD,IBER,IBERT,IBFRDY,IBFRSHDY,IBI,IBINIEN,IBINST,IBLEN,IBPLAN
N IBPTDFN,IBPTINIE,IBPTRINS,IBRET,IBRETURN,IBTDT,IBUSER
;
S IBFRSHDY=$$GET1^DIQ(350.9,"1,",51.01,"I")
S IBRETURN="^TMP(""IBCNERTCA"","_$J_")",IBER="IBERT"
;
F IBI=1:1 S IBCON=$P($T(SPECLST+IBI),";;",2) Q:IBCON="" D SPECP
;
G SPECX
;
Q
;
SPECX ; Purge task record - if queued
K ^TMP("IBCNERTCA",$J)
L -^TMP("IBCNERTCS")
Q
;
SPECLST ; list of specified Insurance Companies
;;US DEPART OF LABOR MED DFEC
;;US DEPT OF LABOR MED DCMWC
;;US DEPT OF LABOR MED DEEOIC
;;US DEPART OF LABOR PHARM DFEC
;;US DEPT OF LABOR PHARM DCMWC
;;US DEPT OF LABOR PHARM DEEOIC
;;CAMP LEJEUNE (WNR)
;;IVF - WNR
;;VHA DIRECTIVE 1029 WNR
;;REGIONAL COUNSEL (02)
;;OFFICE OF REGIONAL COUNSEL
;;
;
SPECP ; process insurance name
;
N IBCHKDT,IBOK
;get insurance IENs for name from B cross
S IBTDT=$$NOW^XLFDT ; set the file time for each insurance company
S IBINIEN=0 F S IBINIEN=$O(^DIC(36,"B",IBCON,IBINIEN)) Q:'IBINIEN D
. S IBINST=+$$GET1^DIQ(36,IBINIEN_",",.05,"I") I IBINST Q ; only process active Insurance Co's with that name
. ; get the list of patients who are: 1) active ins co, (2) active plans,
. ; (3) patient is active
. K @IBRETURN,@IBER
. ;
. D INSSUB^IBCNINSU(IBINIEN,.IBRETURN,.IBER)
. S IBA=$G(@IBER) I IBA'="" Q ; error on lookup
. I '$D(@IBRETURN) Q ; no data returned
. ;
. S IBTDT=$$NOW^XLFDT ; set the file date/time for each insurance company
. ;
. ; now we have the data in IBRETURN
. ; structure is ^TMP("IBCNERTCA",$J,Ins IEN,Plan IEN, PT DFN, PT (2.312) insurance IEN)
. ; IBINIEN is already set
. K IBA
. ; IBRETURN="^TMP(""IBCNERTCA"","_$J_")"
. S IBPLAN=0 F S IBPLAN=$O(^TMP("IBCNERTCA",$J,IBINIEN,IBPLAN)) Q:'IBPLAN D
.. S IBPTDFN=0 F S IBPTDFN=$O(^TMP("IBCNERTCA",$J,IBINIEN,IBPLAN,IBPTDFN)) Q:'IBPTDFN D
... S IBPTINIE=0 F S IBPTINIE=$O(^TMP("IBCNERTCA",$J,IBINIEN,IBPLAN,IBPTDFN,IBPTINIE)) Q:'IBPTINIE D
... . ;
... . S IBA=$G(^TMP("IBCNERTCA",$J,IBINIEN,IBPLAN,IBPTDFN,IBPTINIE)),IBPTRINS=IBPTINIE_","_IBPTDFN_","
... . ; verify
... . S IBD=$$GET1^DIQ(2.312,IBPTRINS,"1.03","I") ; last verified date
... . ;
... . I +IBFRSHDY&($P(IBD,".",1)'=""&($$FMDIFF^XLFDT(DT,$P(IBD,".",1),1)<IBFRSHDY)) Q ; the verify dt difference is less than fresh days
... . ;
... . K FDA S IBTDT=$$NOW^XLFDT
... . S FDA(2.312,IBPTRINS,1.03)=IBTDT
... . S FDA(2.312,IBPTRINS,1.04)=IBBINSEL ; proxy user IB,AUTOINS FILEUPDATE
... . S FDA(2.312,IBPTRINS,1.05)=IBTDT
... . S FDA(2.312,IBPTRINS,1.06)=IBBINSEL ; proxy user IB,AUTOINS FILEUPDATE
... . D FILE^DIE("","FDA")
... . K FDA
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNERTC 7218 printed Mar 25, 2026@15:40:09 Page 2
IBCNERTC ;AITC/HN - Covered by Health Insurance ;03-MAR-2017
+1 ;;2.0;INTEGRATED BILLING;**593,822**;21-MAR-94;Build 21
+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 ;
+12 ;
DBR ; IB*822/DTG run in background the selected insurance patients verified date check
+1 ;
+2 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
+3 ;
+4 ; run now
+5 SET ZTDTH=$$NOW^XLFDT()
+6 ;
+7 ; Set up the other TaskManager variables
+8 SET ZTRTN="SPEC^IBCNERTC"
+9 SET ZTSAVE("IBBINSEL")=""
+10 SET ZTDESC="Daily Selected Ins Patient Verify Date Check"
+11 SET ZTIO=""
+12 ; Call TaskManager
DO ^%ZTLOAD
+13 ;
DBRX ; Exit
+1 QUIT
+2 ;
ER ; Unlock the eIV Nightly Task and return to log error
+1 LOCK -^TMP("IBCNERTCS")
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 DO ^%ZTER
+4 DO UNWIND^%ZTER
+5 QUIT
+6 ;
+7 ;
SPEC ; IB*822/DTG run re-verify for Specific Insurances
+1 ;
+2 ;
+3 ;Quit if VAMC Site is MANILA (#358) & EIV is disabled for MANILA.
+4 IF $PIECE($$SITE^VASITE,U,3)=358
IF $$GET1^DIQ(350.9,"1,",51.33,"I")="N"
QUIT
+5 ;
+6 NEW $ESTACK,$ETRAP
+7 SET $ETRAP="D ER^IBCNERTC"
+8 ; Check lock
+9 LOCK +^TMP("IBCNERTCS"):1
IF '$TEST
Begin DoDot:1
+10 IF '$DATA(ZTSK)
WRITE !!,"The Check of Selected Ins. Patients verified date is already running, please retry later."
DO PAUSE^VALM1
End DoDot:1
GOTO SPECX
+11 ;
+12 SET IBBINSEL=$GET(IBBINSEL)
+13 IF IBBINSEL=""
Begin DoDot:1
+14 SET IBBINSEL=+$$FIND1^DIC(200,,"MX","IB,AUTOINS FILEUPDATE")
if IBBINSEL
QUIT
+15 IF '$DATA(ZTSK)
WRITE !!,"Missing the default proxy user"
DO PAUSE^VALM1
End DoDot:1
if 'IBBINSEL
GOTO SPECX
+16 ;
+17 ; process the selected insurance companies
+18 ;
+19 NEW FDA,IBA,IBB,IBC,IBCO,IBCON,IBD,IBER,IBERT,IBFRDY,IBFRSHDY,IBI,IBINIEN,IBINST,IBLEN,IBPLAN
+20 NEW IBPTDFN,IBPTINIE,IBPTRINS,IBRET,IBRETURN,IBTDT,IBUSER
+21 ;
+22 SET IBFRSHDY=$$GET1^DIQ(350.9,"1,",51.01,"I")
+23 SET IBRETURN="^TMP(""IBCNERTCA"","_$JOB_")"
SET IBER="IBERT"
+24 ;
+25 FOR IBI=1:1
SET IBCON=$PIECE($TEXT(SPECLST+IBI),";;",2)
if IBCON=""
QUIT
DO SPECP
+26 ;
+27 GOTO SPECX
+28 ;
+29 QUIT
+30 ;
SPECX ; Purge task record - if queued
+1 KILL ^TMP("IBCNERTCA",$JOB)
+2 LOCK -^TMP("IBCNERTCS")
+3 QUIT
+4 ;
SPECLST ; list of specified Insurance Companies
+1 ;;US DEPART OF LABOR MED DFEC
+2 ;;US DEPT OF LABOR MED DCMWC
+3 ;;US DEPT OF LABOR MED DEEOIC
+4 ;;US DEPART OF LABOR PHARM DFEC
+5 ;;US DEPT OF LABOR PHARM DCMWC
+6 ;;US DEPT OF LABOR PHARM DEEOIC
+7 ;;CAMP LEJEUNE (WNR)
+8 ;;IVF - WNR
+9 ;;VHA DIRECTIVE 1029 WNR
+10 ;;REGIONAL COUNSEL (02)
+11 ;;OFFICE OF REGIONAL COUNSEL
+12 ;;
+13 ;
SPECP ; process insurance name
+1 ;
+2 NEW IBCHKDT,IBOK
+3 ;get insurance IENs for name from B cross
+4 ; set the file time for each insurance company
SET IBTDT=$$NOW^XLFDT
+5 SET IBINIEN=0
FOR
SET IBINIEN=$ORDER(^DIC(36,"B",IBCON,IBINIEN))
if 'IBINIEN
QUIT
Begin DoDot:1
+6 ; only process active Insurance Co's with that name
SET IBINST=+$$GET1^DIQ(36,IBINIEN_",",.05,"I")
IF IBINST
QUIT
+7 ; get the list of patients who are: 1) active ins co, (2) active plans,
+8 ; (3) patient is active
+9 KILL @IBRETURN,@IBER
+10 ;
+11 DO INSSUB^IBCNINSU(IBINIEN,.IBRETURN,.IBER)
+12 ; error on lookup
SET IBA=$GET(@IBER)
IF IBA'=""
QUIT
+13 ; no data returned
IF '$DATA(@IBRETURN)
QUIT
+14 ;
+15 ; set the file date/time for each insurance company
SET IBTDT=$$NOW^XLFDT
+16 ;
+17 ; now we have the data in IBRETURN
+18 ; structure is ^TMP("IBCNERTCA",$J,Ins IEN,Plan IEN, PT DFN, PT (2.312) insurance IEN)
+19 ; IBINIEN is already set
+20 KILL IBA
+21 ; IBRETURN="^TMP(""IBCNERTCA"","_$J_")"
+22 SET IBPLAN=0
FOR
SET IBPLAN=$ORDER(^TMP("IBCNERTCA",$JOB,IBINIEN,IBPLAN))
if 'IBPLAN
QUIT
Begin DoDot:2
+23 SET IBPTDFN=0
FOR
SET IBPTDFN=$ORDER(^TMP("IBCNERTCA",$JOB,IBINIEN,IBPLAN,IBPTDFN))
if 'IBPTDFN
QUIT
Begin DoDot:3
+24 SET IBPTINIE=0
FOR
SET IBPTINIE=$ORDER(^TMP("IBCNERTCA",$JOB,IBINIEN,IBPLAN,IBPTDFN,IBPTINIE))
if 'IBPTINIE
QUIT
Begin DoDot:4
+25 ;
+26 SET IBA=$GET(^TMP("IBCNERTCA",$JOB,IBINIEN,IBPLAN,IBPTDFN,IBPTINIE))
SET IBPTRINS=IBPTINIE_","_IBPTDFN_","
+27 ; verify
+28 ; last verified date
SET IBD=$$GET1^DIQ(2.312,IBPTRINS,"1.03","I")
+29 ;
+30 ; the verify dt difference is less than fresh days
IF +IBFRSHDY&($PIECE(IBD,".",1)'=""&($$FMDIFF^XLFDT(DT,$PIECE(IBD,".",1),1)<IBFRSHDY))
QUIT
+31 ;
+32 KILL FDA
SET IBTDT=$$NOW^XLFDT
+33 SET FDA(2.312,IBPTRINS,1.03)=IBTDT
+34 ; proxy user IB,AUTOINS FILEUPDATE
SET FDA(2.312,IBPTRINS,1.04)=IBBINSEL
+35 SET FDA(2.312,IBPTRINS,1.05)=IBTDT
+36 ; proxy user IB,AUTOINS FILEUPDATE
SET FDA(2.312,IBPTRINS,1.06)=IBBINSEL
+37 DO FILE^DIE("","FDA")
+38 KILL FDA
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+39 ;
+40 QUIT
+41 ;
