IBCNEUT7 ;DAOU/ALA - IIV MISC. UTILITIES ;14-OCT-2015
;;2.0;INTEGRATED BILLING;**184,549,579,582,601,732,743**;21-MAR-94;Build 18
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This program contains some general utilities or functions
; IB*2*601/DM XMITOK() Gate-keeper routine moved to IBCNETST
;
Q
;
DEATH(DFN,DOD) ;EP
; IB*2.0*549 added method
;IB*2.0*732/DTG start cleaned up and added comment
; Sets the INSURANCE EXPIRATION DATE (file 2.312, field 3) for all active
; insurances of the selected patient to be the date of death
;
; NOTE: this tag is called by a trigger on the DATE OF DEATH (file 2, field .351)
;IB*2.0*732/DTG end cleaned up and added comment
;
; Input: DFN - IEN of the patient to term insurances for
; DOD - Internal date of death (file 2, field .351) of the patient
N MTIME,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
S MTIME=$$NOW^XLFDT() ; Fileman date/time
S ZTDTH=$$FMTH^XLFDT(MTIME) ; Convert to $H format
;
; Set up the other TaskManager variables
S ZTRTN="DEATH2^IBCNEUT7"
S ZTDESC="eIV Auto Termination of Policies for deceased patients"
S ZTIO=""
S ZTSAVE("DFN")="",ZTSAVE("DOD")=""
D ^%ZTLOAD ; Call TaskManager
Q
;
DEATH2 ;EP from TaskMan
; IB*2.0*549 added method
;IB*732/DTG - start cleaned up and added comment
; NOTE: This tag is called by DEATH^IBCNEUT7
;
; Sets the INSURANCE EXPIRATION DATE (file 2.312, field 3) for all active
; insurances of the selected patient to be the date of death
;IB*732/DTG - end cleaned up and added comment
;
; IB*2.0*579 - Also sets the 'COVERED BY HEALTH INSURANCE' to 'N' (file 2, field .3192)
; if it's not already set to 'N'
; Input: DFN - IEN of the patient to term insurances for
; DOD - Internal date of death (file 2, field .351) of the patient
;IB*732/DTG - start DODX should be the Date of Death (DOD), removing DODX
;N EXPDT,DA,DEACT,DODX,FDA,HCOV,IBIEN ; IB*2.0*579 - added DEACT,HCOV
N EXPDT,DA,DEACT,FDA,HCOV,IBIEN ; IB*2.0*579 - added DEACT,HCOV
S DEACT=0 ; IB*2.0*579 - added line
;S DODX=$P($$FMADD^XLFDT(DOD,1),".",1) ; Date of Death +1
S IBIEN=0
F S IBIEN=$O(^DPT(DFN,.312,IBIEN)) Q:+IBIEN=0 D
. ;S EXPDT=$$GET1^DIQ(2.312,IBIEN_","_DFN_",",3,"I") ; Policy Expiration Date
. S EXPDT=$$GET1^DIQ(2.312,IBIEN_","_DFN_",",3,"I") ; Insurance Expiration Date
. Q:EXPDT'="" ; Policy has an expiration date
. L +^DPT(DFN,.312,IBIEN):5
. I '$T D Q ; Send email IB SUPERVISOR users
. . N EDT,MLGRP,MSG,PNM,SSN,SUBJECT,XMY
. . S SUBJECT="eIV: Policy Expiration for deceased patient"
. . S MLGRP=$$MGRP^IBCNEUT5
. . S PNM=$$GET1^DIQ(2,DFN,.01)
. . ;S EDT=$$FMTE^XLFDT(DODX,"2DZ")
. . S EDT=$$FMTE^XLFDT(DOD,"2DZ")
. . S SSN=$$GET1^DIQ(2,DFN,.09),SSN=$E(SSN,6,9)
. . S MSG(1)=PNM_" "_SSN_" was just marked as deceased. Action Needed:"
. . S MSG(2)=" Update the patient's active policies and enter and expiration date of "_EDT_"."
. . D GETPER("IB SUPERVISOR",.XMY)
. . D MSG^IBCNEUT5(MLGRP,SUBJECT,"MSG(",,.XMY)
. ;
. ; Set Policy expiration date to be date of death
. S DEACT=1 ; IB*2.0*579 - added line
. K DA,FDA
. S DA=IBIEN,DA(1)=DFN
. S FDA(2.312,DA_","_DA(1)_",",1.05)=$$NOW^XLFDT() ; Date Last Edited
. S FDA(2.312,DA_","_DA(1)_",",1.06)=.5 ; Last Edited By
. ;S FDA(2.312,DA_","_DA(1)_",",3)=DODX ; Date of Death +1
. S FDA(2.312,DA_","_DA(1)_",",3)=DOD ; Date of Death
. D FILE^DIE("","FDA")
. L -^DPT(DFN,.312,IBIEN)
;IB*732/DTG - end DODX should be the Date of Death (DOD), removing DODX
;
; IB*2.0*579 - added if statement below
; If any policies were expired and the Covered by Health Insurance flag is set to 'Y'.
; change it to 'N'
I DEACT D
. S HCOV=$$GET1^DIQ(2,DFN_",",.3192,"I")
. Q:HCOV'="Y" ; Already set to 'N'
. N IBSUPRES
. S IBSUPRES=1
. D COVERED^IBCNSM31(DFN,HCOV) ; Set the Health Coverage flag to 'N'
Q
;
GETPER(SECKEY,XMY) ;EP
; IB*2.0*549 Added method
; Returns a list of users with the specified security key
; Input: SECKEY - Security key to search for
; Output: XMY() - Array email addresses for users who have the specified key
N XUSIEN,X
S XUSIEN=0
F S XUSIEN=$O(^XUSEC(SECKEY,XUSIEN)) Q:'XUSIEN D
. ;
. ; Don't return TERMINATED or DISUSERed users
. S X=$$ACTIVE^XUSER(XUSIEN)
. I X=""!($P(X,"^",1)=0) Q
. ;
. ; Put users emails into output array
. S XMY(XUSIEN)=""
Q
;
FTFIC(IBIEN,MDCALL) ;EP
; IB*2.0*549 added function
; Returns Timely Filing Timeframe text for a specified Insurance Company
; translate fields 36,.18 and 36,.19 to agreed upon displayed text for
; Insurance company Reports
; Input: IBIEN - IEN of the insurance company to get data from
; MDCALL - 1 if being called from the Missing Data Report
; 0 otherwise. Optional, defaults to 0
; Returns: Timely Filing Timeframe text for the specified Insurance Company
; NOTE: If MDCALL=1 null Standard FTF Values and Qualifiers are
; as '###' instead of null or 'UNKNOWN' respectively
N FTF,FTFV
S:'$D(MDCALL) MDCALL=0
Q:'$D(IBIEN) ""
S FTF=$$GET1^DIQ(36,IBIEN_",",.18,"I") ; Standard FTF IEN (file 355.13)
S FTFV=$$GET1^DIQ(36,IBIEN_",",.19,"I") ; Standard FTF Value
Q $$FTFMAP(FTF,FTFV,MDCALL)
;
FTFGP(GIEN,MDCALL) ;EP
; IB*2.0*549 added function
; Returns Timely Filing Timeframe text for a specified Group Insurance Plan
; translate fields 355.3,.16 and 355.3,.17 to agreed upon displayed text for
; Insurance company Reports
; Input: GIEN - IEN of the group insurance plan to get data from
; MDCALL - 1 if being called from the Missing Data Report
; 0 otherwise. Optional, defaults to 0
; Returns: Timely Filing Timeframe text for the specified Group Insurance Plan
; NOTE: If MDCALL=1 null Standard FTF Values and Qualifiers are
; as '###' instead of null or 'UNKNOWN' respectively
N FTF,FTFV,XX,ZZ
S:'$D(MDCALL) MDCALL=0
Q:'$D(GIEN) ""
S FTF=$$GET1^DIQ(355.3,GIEN_",",.16,"I") ; Standard FTF IEN (file 355.13)
S FTFV=$$GET1^DIQ(355.3,GIEN_",",.17,"I") ; Standard FTF Value
Q $$FTFMAP(FTF,FTFV,MDCALL)
;
FTFMAP(FIEN,FTFV,MDCALL) ; Returns Timely Filing Text for the specified Standard FTF
; and Standard FTF Value
;IB*2.0*549 added function
; Input: FIEN - IEN of the Standard FTF (filer 355.13)
; MDCALL - 1 if being called from the Missing Data Report
; 0 otherwise. Optional, defaults to 0
; Output: FTFV - Standard FTF Value
; Returns: Timely Filing Timeframe text
N FTF
S:'$D(MDCALL) MDCALL=0
I MDCALL,FTFV="" S FTFV="###"
S FTF=$$GET1^DIQ(355.13,FIEN_",",.01) ; Standard FTF name
Q:FTF="" FTFV_" ("_$S(MDCALL:"###",1:"UNKNOWN")_")"
Q:FTF="DAYS" FTFV_" (DYS)"
Q:FTF="DAYS OF FOLLOWING YEAR" FTFV_" (DYS OF NEXT YR)"
Q:FTF="DAYS PLUS ONE YEAR" FTFV_" (DYS_1 YR)"
Q:FTF="END OF FOLLOWING YEAR" FTFV_" (END OF NEXT YR)"
Q:FTF="MONTH(S)" FTFV_" (MOS)"
Q:FTF="MONTHS OF FOLLOWING YEAR" FTFV_" (MOS OF NEXT YR)"
Q:FTF="NO FILING TIME FRAME LIMIT" FTFV_" (N/A)"
Q:FTF="YEAR(S)" FTFV_" (YRS)"
Q FTFV_" ("_$S(MDCALL:"###",1:"UNKNOWN")_")"
;
RSTA(REC) ; Update status in Response File from Transmission Queue to
; Communication Timeout
; Input Parameters
; REC = IEN from TQ file
; -- Removed 10/29/02 --WCH = Which Record 'P'=Previous, 'C'=Current
; -- if no Which Record passed, it will assume the current one
;
N HIEN,RIEN
S HIEN=0
; Loop thru HL7 messages associated with the IIV Inquiry
F S HIEN=$O(^IBCN(365.1,REC,2,HIEN)) Q:'HIEN D
. ; Determine IIV Response associated with the HL7 message
. S RIEN=$P($G(^IBCN(365.1,REC,2,HIEN,0)),U,3) Q:'RIEN
. ; If IIV Response status is 'Response Received', don't update it
. I $P($G(^IBCN(365,RIEN,0)),U,6)=3 Q
. ; Update IIV Response status to 'Communication Timeout'
. D RSP^IBCNEUT2(RIEN,5)
. Q
;
Q
;
TXT(TXT) ;Parse text for wrapping
; Input Parameter
; TXT = The array name
;
I '$D(@(TXT)) Q
;
K ^UTILITY($J,"W")
;
; Define length of text string; left is 1 and right is 78
S DIWF="",DIWL=1,DIWR=78
;
; Format text into scratch file
S CT=0
F S CT=$O(@(TXT)@(CT)) Q:'CT D
. S X=@TXT@(CT) D ^DIWP
;
K @(TXT)
;
; Reset formatted text back to array
S CT=0
F S CT=$O(^UTILITY($J,"W",1,CT)) Q:'CT D
. S @(TXT)@(CT)=^UTILITY($J,"W",1,CT,0)
;
K ^UTILITY($J,"W"),CT,DIWF,DIWL,DIWR,X,Z,DIW,DIWI,DIWT,DIWTC,DIWX,DN,I
Q
;
ERRN(ARRAY) ; Get the next FileMan error number from the array
; Input
; ARRAY = the array name, include "DIERR"
; Output
; IBEY = the next error number
;
; Example call
; S IERN=$$ERRN^IBCNEUT7("ERROR(""DIERR"")")
;
NEW IBEY
;
I '$D(@(ARRAY)) S @(ARRAY)=1 Q 1
;
S IBEY=$P(@(ARRAY),U,1)
S IBEY=IBEY+1,$P(@(ARRAY),U,1)=IBEY
Q IBEY
;
MBICHK(BUFFIEN) ; See if the buffer entry is an MBI request
; return 1 if the provided buffer is an MBI request; otherwise, 0
N IBINSNM
S IBINSNM=$$GET1^DIQ(355.33,BUFFIEN_",","INSURANCE COMPANY NAME")
I IBINSNM="" Q 0
Q +($$GET1^DIQ(350.9,"1,","MBI PAYER")=IBINSNM)
;
;IB*743/DTG adding a check for orphans in IIV TRANSMISSION QUEUE File (#365.1)
BGORPHAN() ; entry point to task a job to find TQ Orphans
;
N DIC,DIR,GTASKS,IBI,IBDATE,IBDIR,IBMES,IBPROD,IBRET,IBSITE,IBSITENAM,RMSG,TSK,X,Y
N ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTQUEUED,ZTREQ,ZTSK
S IBPROD=$$PROD^XUPROD(1)
S IBDATE=$$FMTE^XLFDT(DT,5)
S IBSITE=$$SITE^VASITE ; Get the site name & #
S IBSITENAM=$P(IBSITE,U,2),IBSITE=$P(IBSITE,U,3) ; piece 3 is the site #
S IBDIR="IB - eIV TQ Orphan Check"
S IBRET=""
I 'IBPROD Q "-1^"_IBDIR_" cannot run since this site is not a Production Account."
; Check to see if the task is already running.
K GTASKS
D DESC^%ZTLOAD(IBDIR,"GTASKS")
S TSK="",RMSG(0)=0
S TSK=$O(GTASKS(TSK))
I TSK Q "-1^"_IBDIR_" Task "_TSK_" has Already Been Submitted to TASKMAN."
; build task out array and task off
S ZTRTN="ORPHAN^IBCNEUT7",ZTDESC=IBDIR,ZTIO=""
; ZTDTH = TODAY AT 8:00 PM
S ZTDTH=$P($$NOW^XLFDT(),"."),ZTDTH=$$FMADD^XLFDT(ZTDTH,,20)
F IBI="IBDATE","IBSITE","IBSITENAM","IBPROD","IBDIR" S ZTSAVE(IBI)=""
K IO("Q"),ZTSK
D ^%ZTLOAD
S IBRET="" S:$D(ZTSK) IBRET=ZTSK
D HOME^%ZIS
;
I +IBRET S IBMES="1^"_IBDIR_" has been submitted to TASKMAN. Task number: "_(+IBRET)
I 'IBRET D
. S IBER=1
. S IBMES="-1^"_IBDIR_" was NOT successfully submitted to TASKMAN."
. S IBEMSG=$P(IBMES,U,2)
. D ORPHANX ;Send email message that task not successfully submitted.
Q IBMES
;
ORPHAN ; TASKMAN entry point to check TQ file for orphans
; This is designed to be tasked through TaskMan.
; Running directly will not have all the required variables.
;
N IB36514IEN,IBA,IBARY,IBCNT,IBEDT,IBER,IBFND,IBIDT,IBEMSG,IBNCK,IBND,IBNEWST,IBOK,IBOLDEST,IBTQIEN,IBWDT,IBXMY,MSG,SITE
;
;get ien for transmitted from 365.14
S IBEMSG=""
S IBER=0,IB36514IEN=$$FIND1^DIC(365.14,,,"Transmitted")
I 'IB36514IEN S IBER=1 D G ORPHANX
. S IBEMSG="Not able to find 'Transmitted' status record ID in IIV TRANSMISSION STATUS (#365.14) file"
S IBTQIEN=0,IBCNT=0,IBOK=1,IBOLDEST="99999999"
; get today-29
S IBNEWST="",IBNCK="",IBNCK=$O(^IBCN(365.1,"AC",IB36514IEN,"A"),-1)
I IBNCK D
. S IBNEWST=$$GET1^DIQ(365.1,IBNCK_",",".06","E")
. S IBNEWST=$$FMTE^XLFDT(IBNEWST,5)
S IBWDT=$$FMTH^XLFDT(DT),IBWDT=$P(IBWDT,",",1),IBWDT=IBWDT-29
K IBARY S IBARY=0
F S IBTQIEN=$O(^IBCN(365.1,"AC",IB36514IEN,IBTQIEN)) Q:'IBTQIEN D Q:'IBOK
. ; .01 - Transaction Number, .04 - Transmission Status, .05 - Buffer Entry (from 355.33)
. ; .06 - Date/Time Created, .1 - Which Extract, .11 - Query Flag
. K IBFND,IBND
. D GETS^DIQ(365.1,IBTQIEN_",",".01;.04;.05;.06;.1;.11","IE","IBFND") M IBND=IBFND(365.1,IBTQIEN_",")
. S IBA="",IBEDT=$G(IBND(.06,"E")),IBIDT=$G(IBND(.06,"I"))
. I IBIDT'="" S IBA=$$FMTH^XLFDT(IBIDT),IBA=$P(IBA,",",1)
. I IBA'=""&(IBA<+IBOLDEST) S IBOLDEST=IBA_U_IBEDT
. I IBA>IBWDT S IBOK=0 Q
. S IBARY=IBARY+1,IBARY(IBA)=IBEDT
;
ORPHANX ; build and send message to eInsurance
S SITE=IBSITENAM_" (#"_IBSITE_")"
;Send mailman message at completion.
S MSG(1)=IBDIR_" at "_SITE_" in Production"
S MSG(2)=" "
S MSG(3)=" Check of the IIV TRANSMISSION QUEUE File (#365.1) for orphan entries."
S MSG(4)=" "
S MSG(5)=" Run On: "_IBDATE
S MSG(6)=" --------------------------------------------------------------------------"
S MSG(7)=" "
S MSG(8)=" "
I IBER D
. S MSG(9)=IBEMSG
. S MSG(10)="Not able to check the IIV TRANSMISSION QUEUE File (#365.1) for orphan entries."
. S MSG(11)=" ",MSG(12)="",MSG(13)=""
I 'IBER D
.S MSG(9)=" Oldest 'Transmitted' Date: "_$S(IBOLDEST'="99999999":$P(IBOLDEST,U,2),1:"")
.S MSG(10)=" "
.S MSG(11)=" Newest 'Transmitted' Date: "_IBNEWST
.S MSG(12)=""
.S MSG(13)=" Number of 'Transmitted' Status entries 30 days or older: "_(+IBARY)
S MSG(14)=" "
;
; Only send to eInsurance Rapid Response if in Production
; 1=Production Environment, 0=Test Environment
I IBPROD S IBXMY("VHAeInsuranceRapidResponse@domain.ext")=""
D MSG^IBCNEUT5(,SITE_" Check 'TQ' orphan entries","MSG(",,.IBXMY)
;
; Tell TaskManager to delete the task's record
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEUT7 13820 printed Jun 26, 2025@03:30:28 Page 2
IBCNEUT7 ;DAOU/ALA - IIV MISC. UTILITIES ;14-OCT-2015
+1 ;;2.0;INTEGRATED BILLING;**184,549,579,582,601,732,743**;21-MAR-94;Build 18
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This program contains some general utilities or functions
+6 ; IB*2*601/DM XMITOK() Gate-keeper routine moved to IBCNETST
+7 ;
+8 QUIT
+9 ;
DEATH(DFN,DOD) ;EP
+1 ; IB*2.0*549 added method
+2 ;IB*2.0*732/DTG start cleaned up and added comment
+3 ; Sets the INSURANCE EXPIRATION DATE (file 2.312, field 3) for all active
+4 ; insurances of the selected patient to be the date of death
+5 ;
+6 ; NOTE: this tag is called by a trigger on the DATE OF DEATH (file 2, field .351)
+7 ;IB*2.0*732/DTG end cleaned up and added comment
+8 ;
+9 ; Input: DFN - IEN of the patient to term insurances for
+10 ; DOD - Internal date of death (file 2, field .351) of the patient
+11 NEW MTIME,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
+12 ; Fileman date/time
SET MTIME=$$NOW^XLFDT()
+13 ; Convert to $H format
SET ZTDTH=$$FMTH^XLFDT(MTIME)
+14 ;
+15 ; Set up the other TaskManager variables
+16 SET ZTRTN="DEATH2^IBCNEUT7"
+17 SET ZTDESC="eIV Auto Termination of Policies for deceased patients"
+18 SET ZTIO=""
+19 SET ZTSAVE("DFN")=""
SET ZTSAVE("DOD")=""
+20 ; Call TaskManager
DO ^%ZTLOAD
+21 QUIT
+22 ;
DEATH2 ;EP from TaskMan
+1 ; IB*2.0*549 added method
+2 ;IB*732/DTG - start cleaned up and added comment
+3 ; NOTE: This tag is called by DEATH^IBCNEUT7
+4 ;
+5 ; Sets the INSURANCE EXPIRATION DATE (file 2.312, field 3) for all active
+6 ; insurances of the selected patient to be the date of death
+7 ;IB*732/DTG - end cleaned up and added comment
+8 ;
+9 ; IB*2.0*579 - Also sets the 'COVERED BY HEALTH INSURANCE' to 'N' (file 2, field .3192)
+10 ; if it's not already set to 'N'
+11 ; Input: DFN - IEN of the patient to term insurances for
+12 ; DOD - Internal date of death (file 2, field .351) of the patient
+13 ;IB*732/DTG - start DODX should be the Date of Death (DOD), removing DODX
+14 ;N EXPDT,DA,DEACT,DODX,FDA,HCOV,IBIEN ; IB*2.0*579 - added DEACT,HCOV
+15 ; IB*2.0*579 - added DEACT,HCOV
NEW EXPDT,DA,DEACT,FDA,HCOV,IBIEN
+16 ; IB*2.0*579 - added line
SET DEACT=0
+17 ;S DODX=$P($$FMADD^XLFDT(DOD,1),".",1) ; Date of Death +1
+18 SET IBIEN=0
+19 FOR
SET IBIEN=$ORDER(^DPT(DFN,.312,IBIEN))
if +IBIEN=0
QUIT
Begin DoDot:1
+20 ;S EXPDT=$$GET1^DIQ(2.312,IBIEN_","_DFN_",",3,"I") ; Policy Expiration Date
+21 ; Insurance Expiration Date
SET EXPDT=$$GET1^DIQ(2.312,IBIEN_","_DFN_",",3,"I")
+22 ; Policy has an expiration date
if EXPDT'=""
QUIT
+23 LOCK +^DPT(DFN,.312,IBIEN):5
+24 ; Send email IB SUPERVISOR users
IF '$TEST
Begin DoDot:2
+25 NEW EDT,MLGRP,MSG,PNM,SSN,SUBJECT,XMY
+26 SET SUBJECT="eIV: Policy Expiration for deceased patient"
+27 SET MLGRP=$$MGRP^IBCNEUT5
+28 SET PNM=$$GET1^DIQ(2,DFN,.01)
+29 ;S EDT=$$FMTE^XLFDT(DODX,"2DZ")
+30 SET EDT=$$FMTE^XLFDT(DOD,"2DZ")
+31 SET SSN=$$GET1^DIQ(2,DFN,.09)
SET SSN=$EXTRACT(SSN,6,9)
+32 SET MSG(1)=PNM_" "_SSN_" was just marked as deceased. Action Needed:"
+33 SET MSG(2)=" Update the patient's active policies and enter and expiration date of "_EDT_"."
+34 DO GETPER("IB SUPERVISOR",.XMY)
+35 DO MSG^IBCNEUT5(MLGRP,SUBJECT,"MSG(",,.XMY)
End DoDot:2
QUIT
+36 ;
+37 ; Set Policy expiration date to be date of death
+38 ; IB*2.0*579 - added line
SET DEACT=1
+39 KILL DA,FDA
+40 SET DA=IBIEN
SET DA(1)=DFN
+41 ; Date Last Edited
SET FDA(2.312,DA_","_DA(1)_",",1.05)=$$NOW^XLFDT()
+42 ; Last Edited By
SET FDA(2.312,DA_","_DA(1)_",",1.06)=.5
+43 ;S FDA(2.312,DA_","_DA(1)_",",3)=DODX ; Date of Death +1
+44 ; Date of Death
SET FDA(2.312,DA_","_DA(1)_",",3)=DOD
+45 DO FILE^DIE("","FDA")
+46 LOCK -^DPT(DFN,.312,IBIEN)
End DoDot:1
+47 ;IB*732/DTG - end DODX should be the Date of Death (DOD), removing DODX
+48 ;
+49 ; IB*2.0*579 - added if statement below
+50 ; If any policies were expired and the Covered by Health Insurance flag is set to 'Y'.
+51 ; change it to 'N'
+52 IF DEACT
Begin DoDot:1
+53 SET HCOV=$$GET1^DIQ(2,DFN_",",.3192,"I")
+54 ; Already set to 'N'
if HCOV'="Y"
QUIT
+55 NEW IBSUPRES
+56 SET IBSUPRES=1
+57 ; Set the Health Coverage flag to 'N'
DO COVERED^IBCNSM31(DFN,HCOV)
End DoDot:1
+58 QUIT
+59 ;
GETPER(SECKEY,XMY) ;EP
+1 ; IB*2.0*549 Added method
+2 ; Returns a list of users with the specified security key
+3 ; Input: SECKEY - Security key to search for
+4 ; Output: XMY() - Array email addresses for users who have the specified key
+5 NEW XUSIEN,X
+6 SET XUSIEN=0
+7 FOR
SET XUSIEN=$ORDER(^XUSEC(SECKEY,XUSIEN))
if 'XUSIEN
QUIT
Begin DoDot:1
+8 ;
+9 ; Don't return TERMINATED or DISUSERed users
+10 SET X=$$ACTIVE^XUSER(XUSIEN)
+11 IF X=""!($PIECE(X,"^",1)=0)
QUIT
+12 ;
+13 ; Put users emails into output array
+14 SET XMY(XUSIEN)=""
End DoDot:1
+15 QUIT
+16 ;
FTFIC(IBIEN,MDCALL) ;EP
+1 ; IB*2.0*549 added function
+2 ; Returns Timely Filing Timeframe text for a specified Insurance Company
+3 ; translate fields 36,.18 and 36,.19 to agreed upon displayed text for
+4 ; Insurance company Reports
+5 ; Input: IBIEN - IEN of the insurance company to get data from
+6 ; MDCALL - 1 if being called from the Missing Data Report
+7 ; 0 otherwise. Optional, defaults to 0
+8 ; Returns: Timely Filing Timeframe text for the specified Insurance Company
+9 ; NOTE: If MDCALL=1 null Standard FTF Values and Qualifiers are
+10 ; as '###' instead of null or 'UNKNOWN' respectively
+11 NEW FTF,FTFV
+12 if '$DATA(MDCALL)
SET MDCALL=0
+13 if '$DATA(IBIEN)
QUIT ""
+14 ; Standard FTF IEN (file 355.13)
SET FTF=$$GET1^DIQ(36,IBIEN_",",.18,"I")
+15 ; Standard FTF Value
SET FTFV=$$GET1^DIQ(36,IBIEN_",",.19,"I")
+16 QUIT $$FTFMAP(FTF,FTFV,MDCALL)
+17 ;
FTFGP(GIEN,MDCALL) ;EP
+1 ; IB*2.0*549 added function
+2 ; Returns Timely Filing Timeframe text for a specified Group Insurance Plan
+3 ; translate fields 355.3,.16 and 355.3,.17 to agreed upon displayed text for
+4 ; Insurance company Reports
+5 ; Input: GIEN - IEN of the group insurance plan to get data from
+6 ; MDCALL - 1 if being called from the Missing Data Report
+7 ; 0 otherwise. Optional, defaults to 0
+8 ; Returns: Timely Filing Timeframe text for the specified Group Insurance Plan
+9 ; NOTE: If MDCALL=1 null Standard FTF Values and Qualifiers are
+10 ; as '###' instead of null or 'UNKNOWN' respectively
+11 NEW FTF,FTFV,XX,ZZ
+12 if '$DATA(MDCALL)
SET MDCALL=0
+13 if '$DATA(GIEN)
QUIT ""
+14 ; Standard FTF IEN (file 355.13)
SET FTF=$$GET1^DIQ(355.3,GIEN_",",.16,"I")
+15 ; Standard FTF Value
SET FTFV=$$GET1^DIQ(355.3,GIEN_",",.17,"I")
+16 QUIT $$FTFMAP(FTF,FTFV,MDCALL)
+17 ;
FTFMAP(FIEN,FTFV,MDCALL) ; Returns Timely Filing Text for the specified Standard FTF
+1 ; and Standard FTF Value
+2 ;IB*2.0*549 added function
+3 ; Input: FIEN - IEN of the Standard FTF (filer 355.13)
+4 ; MDCALL - 1 if being called from the Missing Data Report
+5 ; 0 otherwise. Optional, defaults to 0
+6 ; Output: FTFV - Standard FTF Value
+7 ; Returns: Timely Filing Timeframe text
+8 NEW FTF
+9 if '$DATA(MDCALL)
SET MDCALL=0
+10 IF MDCALL
IF FTFV=""
SET FTFV="###"
+11 ; Standard FTF name
SET FTF=$$GET1^DIQ(355.13,FIEN_",",.01)
+12 if FTF=""
QUIT FTFV_" ("_$SELECT(MDCALL:"###",1:"UNKNOWN")_")"
+13 if FTF="DAYS"
QUIT FTFV_" (DYS)"
+14 if FTF="DAYS OF FOLLOWING YEAR"
QUIT FTFV_" (DYS OF NEXT YR)"
+15 if FTF="DAYS PLUS ONE YEAR"
QUIT FTFV_" (DYS_1 YR)"
+16 if FTF="END OF FOLLOWING YEAR"
QUIT FTFV_" (END OF NEXT YR)"
+17 if FTF="MONTH(S)"
QUIT FTFV_" (MOS)"
+18 if FTF="MONTHS OF FOLLOWING YEAR"
QUIT FTFV_" (MOS OF NEXT YR)"
+19 if FTF="NO FILING TIME FRAME LIMIT"
QUIT FTFV_" (N/A)"
+20 if FTF="YEAR(S)"
QUIT FTFV_" (YRS)"
+21 QUIT FTFV_" ("_$SELECT(MDCALL:"###",1:"UNKNOWN")_")"
+22 ;
RSTA(REC) ; Update status in Response File from Transmission Queue to
+1 ; Communication Timeout
+2 ; Input Parameters
+3 ; REC = IEN from TQ file
+4 ; -- Removed 10/29/02 --WCH = Which Record 'P'=Previous, 'C'=Current
+5 ; -- if no Which Record passed, it will assume the current one
+6 ;
+7 NEW HIEN,RIEN
+8 SET HIEN=0
+9 ; Loop thru HL7 messages associated with the IIV Inquiry
+10 FOR
SET HIEN=$ORDER(^IBCN(365.1,REC,2,HIEN))
if 'HIEN
QUIT
Begin DoDot:1
+11 ; Determine IIV Response associated with the HL7 message
+12 SET RIEN=$PIECE($GET(^IBCN(365.1,REC,2,HIEN,0)),U,3)
if 'RIEN
QUIT
+13 ; If IIV Response status is 'Response Received', don't update it
+14 IF $PIECE($GET(^IBCN(365,RIEN,0)),U,6)=3
QUIT
+15 ; Update IIV Response status to 'Communication Timeout'
+16 DO RSP^IBCNEUT2(RIEN,5)
+17 QUIT
End DoDot:1
+18 ;
+19 QUIT
+20 ;
TXT(TXT) ;Parse text for wrapping
+1 ; Input Parameter
+2 ; TXT = The array name
+3 ;
+4 IF '$DATA(@(TXT))
QUIT
+5 ;
+6 KILL ^UTILITY($JOB,"W")
+7 ;
+8 ; Define length of text string; left is 1 and right is 78
+9 SET DIWF=""
SET DIWL=1
SET DIWR=78
+10 ;
+11 ; Format text into scratch file
+12 SET CT=0
+13 FOR
SET CT=$ORDER(@(TXT)@(CT))
if 'CT
QUIT
Begin DoDot:1
+14 SET X=@TXT@(CT)
DO ^DIWP
End DoDot:1
+15 ;
+16 KILL @(TXT)
+17 ;
+18 ; Reset formatted text back to array
+19 SET CT=0
+20 FOR
SET CT=$ORDER(^UTILITY($JOB,"W",1,CT))
if 'CT
QUIT
Begin DoDot:1
+21 SET @(TXT)@(CT)=^UTILITY($JOB,"W",1,CT,0)
End DoDot:1
+22 ;
+23 KILL ^UTILITY($JOB,"W"),CT,DIWF,DIWL,DIWR,X,Z,DIW,DIWI,DIWT,DIWTC,DIWX,DN,I
+24 QUIT
+25 ;
ERRN(ARRAY) ; Get the next FileMan error number from the array
+1 ; Input
+2 ; ARRAY = the array name, include "DIERR"
+3 ; Output
+4 ; IBEY = the next error number
+5 ;
+6 ; Example call
+7 ; S IERN=$$ERRN^IBCNEUT7("ERROR(""DIERR"")")
+8 ;
+9 NEW IBEY
+10 ;
+11 IF '$DATA(@(ARRAY))
SET @(ARRAY)=1
QUIT 1
+12 ;
+13 SET IBEY=$PIECE(@(ARRAY),U,1)
+14 SET IBEY=IBEY+1
SET $PIECE(@(ARRAY),U,1)=IBEY
+15 QUIT IBEY
+16 ;
MBICHK(BUFFIEN) ; See if the buffer entry is an MBI request
+1 ; return 1 if the provided buffer is an MBI request; otherwise, 0
+2 NEW IBINSNM
+3 SET IBINSNM=$$GET1^DIQ(355.33,BUFFIEN_",","INSURANCE COMPANY NAME")
+4 IF IBINSNM=""
QUIT 0
+5 QUIT +($$GET1^DIQ(350.9,"1,","MBI PAYER")=IBINSNM)
+6 ;
+7 ;IB*743/DTG adding a check for orphans in IIV TRANSMISSION QUEUE File (#365.1)
BGORPHAN() ; entry point to task a job to find TQ Orphans
+1 ;
+2 NEW DIC,DIR,GTASKS,IBI,IBDATE,IBDIR,IBMES,IBPROD,IBRET,IBSITE,IBSITENAM,RMSG,TSK,X,Y
+3 NEW ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTQUEUED,ZTREQ,ZTSK
+4 SET IBPROD=$$PROD^XUPROD(1)
+5 SET IBDATE=$$FMTE^XLFDT(DT,5)
+6 ; Get the site name & #
SET IBSITE=$$SITE^VASITE
+7 ; piece 3 is the site #
SET IBSITENAM=$PIECE(IBSITE,U,2)
SET IBSITE=$PIECE(IBSITE,U,3)
+8 SET IBDIR="IB - eIV TQ Orphan Check"
+9 SET IBRET=""
+10 IF 'IBPROD
QUIT "-1^"_IBDIR_" cannot run since this site is not a Production Account."
+11 ; Check to see if the task is already running.
+12 KILL GTASKS
+13 DO DESC^%ZTLOAD(IBDIR,"GTASKS")
+14 SET TSK=""
SET RMSG(0)=0
+15 SET TSK=$ORDER(GTASKS(TSK))
+16 IF TSK
QUIT "-1^"_IBDIR_" Task "_TSK_" has Already Been Submitted to TASKMAN."
+17 ; build task out array and task off
+18 SET ZTRTN="ORPHAN^IBCNEUT7"
SET ZTDESC=IBDIR
SET ZTIO=""
+19 ; ZTDTH = TODAY AT 8:00 PM
+20 SET ZTDTH=$PIECE($$NOW^XLFDT(),".")
SET ZTDTH=$$FMADD^XLFDT(ZTDTH,,20)
+21 FOR IBI="IBDATE","IBSITE","IBSITENAM","IBPROD","IBDIR"
SET ZTSAVE(IBI)=""
+22 KILL IO("Q"),ZTSK
+23 DO ^%ZTLOAD
+24 SET IBRET=""
if $DATA(ZTSK)
SET IBRET=ZTSK
+25 DO HOME^%ZIS
+26 ;
+27 IF +IBRET
SET IBMES="1^"_IBDIR_" has been submitted to TASKMAN. Task number: "_(+IBRET)
+28 IF 'IBRET
Begin DoDot:1
+29 SET IBER=1
+30 SET IBMES="-1^"_IBDIR_" was NOT successfully submitted to TASKMAN."
+31 SET IBEMSG=$PIECE(IBMES,U,2)
+32 ;Send email message that task not successfully submitted.
DO ORPHANX
End DoDot:1
+33 QUIT IBMES
+34 ;
ORPHAN ; TASKMAN entry point to check TQ file for orphans
+1 ; This is designed to be tasked through TaskMan.
+2 ; Running directly will not have all the required variables.
+3 ;
+4 NEW IB36514IEN,IBA,IBARY,IBCNT,IBEDT,IBER,IBFND,IBIDT,IBEMSG,IBNCK,IBND,IBNEWST,IBOK,IBOLDEST,IBTQIEN,IBWDT,IBXMY,MSG,SITE
+5 ;
+6 ;get ien for transmitted from 365.14
+7 SET IBEMSG=""
+8 SET IBER=0
SET IB36514IEN=$$FIND1^DIC(365.14,,,"Transmitted")
+9 IF 'IB36514IEN
SET IBER=1
Begin DoDot:1
+10 SET IBEMSG="Not able to find 'Transmitted' status record ID in IIV TRANSMISSION STATUS (#365.14) file"
End DoDot:1
GOTO ORPHANX
+11 SET IBTQIEN=0
SET IBCNT=0
SET IBOK=1
SET IBOLDEST="99999999"
+12 ; get today-29
+13 SET IBNEWST=""
SET IBNCK=""
SET IBNCK=$ORDER(^IBCN(365.1,"AC",IB36514IEN,"A"),-1)
+14 IF IBNCK
Begin DoDot:1
+15 SET IBNEWST=$$GET1^DIQ(365.1,IBNCK_",",".06","E")
+16 SET IBNEWST=$$FMTE^XLFDT(IBNEWST,5)
End DoDot:1
+17 SET IBWDT=$$FMTH^XLFDT(DT)
SET IBWDT=$PIECE(IBWDT,",",1)
SET IBWDT=IBWDT-29
+18 KILL IBARY
SET IBARY=0
+19 FOR
SET IBTQIEN=$ORDER(^IBCN(365.1,"AC",IB36514IEN,IBTQIEN))
if 'IBTQIEN
QUIT
Begin DoDot:1
+20 ; .01 - Transaction Number, .04 - Transmission Status, .05 - Buffer Entry (from 355.33)
+21 ; .06 - Date/Time Created, .1 - Which Extract, .11 - Query Flag
+22 KILL IBFND,IBND
+23 DO GETS^DIQ(365.1,IBTQIEN_",",".01;.04;.05;.06;.1;.11","IE","IBFND")
MERGE IBND=IBFND(365.1,IBTQIEN_",")
+24 SET IBA=""
SET IBEDT=$GET(IBND(.06,"E"))
SET IBIDT=$GET(IBND(.06,"I"))
+25 IF IBIDT'=""
SET IBA=$$FMTH^XLFDT(IBIDT)
SET IBA=$PIECE(IBA,",",1)
+26 IF IBA'=""&(IBA<+IBOLDEST)
SET IBOLDEST=IBA_U_IBEDT
+27 IF IBA>IBWDT
SET IBOK=0
QUIT
+28 SET IBARY=IBARY+1
SET IBARY(IBA)=IBEDT
End DoDot:1
if 'IBOK
QUIT
+29 ;
ORPHANX ; build and send message to eInsurance
+1 SET SITE=IBSITENAM_" (#"_IBSITE_")"
+2 ;Send mailman message at completion.
+3 SET MSG(1)=IBDIR_" at "_SITE_" in Production"
+4 SET MSG(2)=" "
+5 SET MSG(3)=" Check of the IIV TRANSMISSION QUEUE File (#365.1) for orphan entries."
+6 SET MSG(4)=" "
+7 SET MSG(5)=" Run On: "_IBDATE
+8 SET MSG(6)=" --------------------------------------------------------------------------"
+9 SET MSG(7)=" "
+10 SET MSG(8)=" "
+11 IF IBER
Begin DoDot:1
+12 SET MSG(9)=IBEMSG
+13 SET MSG(10)="Not able to check the IIV TRANSMISSION QUEUE File (#365.1) for orphan entries."
+14 SET MSG(11)=" "
SET MSG(12)=""
SET MSG(13)=""
End DoDot:1
+15 IF 'IBER
Begin DoDot:1
+16 SET MSG(9)=" Oldest 'Transmitted' Date: "_$SELECT(IBOLDEST'="99999999":$PIECE(IBOLDEST,U,2),1:"")
+17 SET MSG(10)=" "
+18 SET MSG(11)=" Newest 'Transmitted' Date: "_IBNEWST
+19 SET MSG(12)=""
+20 SET MSG(13)=" Number of 'Transmitted' Status entries 30 days or older: "_(+IBARY)
End DoDot:1
+21 SET MSG(14)=" "
+22 ;
+23 ; Only send to eInsurance Rapid Response if in Production
+24 ; 1=Production Environment, 0=Test Environment
+25 IF IBPROD
SET IBXMY("VHAeInsuranceRapidResponse@domain.ext")=""
+26 DO MSG^IBCNEUT5(,SITE_" Check 'TQ' orphan entries","MSG(",,.IBXMY)
+27 ;
+28 ; Tell TaskManager to delete the task's record
+29 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+30 QUIT
+31 ;
