IBCNBAR ;ALB/ARH-Ins Buffer: process Accept and Reject ;15 Jan 2009
;;2.0;INTEGRATED BILLING;**82,240,345,413,416,497,528,554,595,631,687,737**;21-MAR-94;Build 19
;Per VA Directive 6402, this routine should not be modified.
;
;
ACCEPT(IBBUFDA,DFN,IBINSDA,IBGRPDA,IBPOLDA,IBMVINS,IBMVGRP,IBMVPOL,IBMVSUB,IBNEWINS,IBNEWGRP,IBNEWPOL,IBELIG,IBSEL,IBRIEN,IBSIEN,IBFNAM,IBVAL,IBHOLD,IBXHOLD) ; move buffer data into Insurance files then cleanup
; 1) data moved into insurance files, new records created if needed or edit existing ones
; 2) complete some general functions that are executed whenever insurance is entered/edited
; 3) allow user to view buffer entry and new/updated insurance records
; 4) buffer ins/group/policy data deleted
; 5) buffer entry status updated
;
N RESULT,IBSUPRES
;Set IBSUPRES to zero to not suppress I/O within Accept
S IBSUPRES=0
;
PROCESS ; process all changes selected by user, add/edit insurance files based
; on buffer data. Entry point for ACCEPAPI^IBCNICB (patch 413)
;
N IVMINSUP,IBNEW,IBCDFN,RIEN S IBCDFN=IBPOLDA S:+IBNEWPOL IBNEW=1 D BEFORE^IBCNSEVT ; insurance event driver
;
N DIR,X,Y,IBX,IBINSH,IBGRPH,IBPOLH,IBSUBH S (IBINSH,IBGRPH,IBPOLH,IBSUBH)="Updated" W:$G(IBSUPRES)'>0 " ...",!
;
;IB*737/CKB - if processing this entry would result in Effective Date (#2.312,8) being null, abort processing
I $G(IBCNICB) S IBSIEN=$S(+IBPOLDA:IBPOLDA_","_DFN_",",1:"")
S IBBUFABORT=$$EFFDTCHK(IBBUFDA,IBSIEN,+IBMVPOL) G:IBBUFABORT ACCPTQ
;
S RESULT(0)="-1^Add new INSURANCE COMPANY failed"
I +IBNEWINS S IBINSDA=+$$NEWINS^IBCNBMN(IBBUFDA) G:'IBINSDA ACCPTQ S IBINSH="Created",RESULT(1)="IBINSDA^"_IBINSDA
;
S RESULT(0)="-1^Add new GROUP INSURANCE PLAN failed"
I +IBNEWGRP S IBGRPDA=+$$NEWGRP^IBCNBMN(IBBUFDA,+IBINSDA) G:'IBGRPDA ACCPTQ S IBGRPH="Created",RESULT(2)="IBGRPDA^"_IBGRPDA
;
S RESULT(0)="-1^Add new patient insurance policy failed"
I +IBNEWPOL S IBPOLDA=+$$NEWPOL^IBCNBMN(IBBUFDA,+IBINSDA,+IBGRPDA) G:'IBPOLDA ACCPTQ S (IBPOLH,IBSUBH)="Created",RESULT(3)="IBPOLDA^"_IBPOLDA
;
;Only do this check for ICB ACCEPAPI^IBCNICB interface
S RESULT(0)="-1^Move TYPE parameter value="_IBMVINS_" is invalid"
I $G(IBSUPRES)>0,"^1^2^3^"'[("^"_IBMVINS_"^") Q
;
S RESULT(0)="-1^Move buffer data to insurance files failed"
I +IBINSDA,+IBMVINS D INS^IBCNBMI(IBBUFDA,IBINSDA,+IBMVINS,.RESULT) W:$G(IBSUPRES)'>0 !,"Insurance Company "_IBINSH_"..."
I +IBINSDA,+IBMVGRP,+IBGRPDA D
. D GRP^IBCNBMI(IBBUFDA,IBGRPDA,+IBMVGRP,.RESULT)
. ; For ICB Interface ensure INDIVIDUAL POLICY PATIENT (.1) field is
. ; appropriate for IS THIS A GROUP POLICY? (.02) field
. I $G(IBSUPRES)>0 D
. . N IBFLDS,IBISGRP,IBPAT
. . S IBISGRP=$$GET1^DIQ(355.3,IBGRPDA,.02,"I")
. . S IBPAT=$$GET1^DIQ(355.3,IBGRPDA,.1,"I")
. . ;Quit if Group Policy and .1 field isn't populated
. . I IBISGRP>0,IBPAT'>0 Q
. . ;Quit if Individual Policy and .1 field is populated.
. . I IBISGRP'>0,IBPAT>0 Q
. . ;Delete .1 field if Group Policy
. . I IBISGRP>0 S IBFLDS(355.3,IBGRPDA_",",.1)="@"
. . I IBISGRP'>0 S IBFLDS(355.3,IBGRPDA_",",.1)=DFN
. . D FILE^DIE("","IBFLDS","IBERR")
. W:$G(IBSUPRES)'>0 !,"Group/Plan "_IBGRPH_"..."
I +IBINSDA,+IBMVPOL,+IBGRPDA,+IBPOLDA D POLICY^IBCNBMI(IBBUFDA,IBPOLDA,+IBMVPOL,.RESULT) W:$G(IBSUPRES)'>0 !,"Patient Policy "_IBPOLH_"..."
; I +IBELIG S RIEN=$O(^IBCN(365,"AF",IBBUFDA,""),-1) I RIEN D GRPFILE^IBCNEHL1(DFN,IBPOLDA,RIEN,0),EBFILE^IBCNEHL1(DFN,IBPOLDA,RIEN,0) W:$G(IBSUPRES)'>0 !,"Eligibility/Benfits data Updated..."
;
S RESULT(0)="-1^Move Patient Registration data into Insurance files failed"
I +IBINSDA,+$G(IBMVSUB),+IBGRPDA,+IBPOLDA D SUB^IBCNBMI(IBBUFDA,IBPOLDA,IBRIEN,IBSEL,+IBMVSUB,.RESULT,DFN,IBFNAM,IBVAL,.IBHOLD,.IBXHOLD) W:$G(IBSUPRES)'>0 !,"Subscriber Insurance Information "_IBSUBH_"..."
;
I +IBELIG S RIEN=$O(^IBCN(365,"AF",IBBUFDA,""),-1) I RIEN D GRPFILE^IBCNEHL1(DFN,IBPOLDA,RIEN,0),EBFILE^IBCNEHL1(DFN,IBPOLDA,RIEN,0) W:$G(IBSUPRES)'>0 !,"Eligibility/Benefits data Updated..." ;IB*2.0*554 Fix spelling error
;
;Only do this update for ICB ACCEPAPI^IBCNICB interface
I $G(IBSUPRES)>0,+IBMVPOL,+IBGRPDA,+IBPOLDA,'IBNEWPOL D UPDPOL^IBCNICB(.RESULT,IBBUFDA,DFN,IBINSDA,IBGRPDA,IBPOLDA)
;
CLEANUP ; general updates and checks done whenever insurance is added/edited and clean up buffer file
N IBSOURCE S IBSOURCE=$P($G(^IBA(355.33,IBBUFDA,0)),U,3)
N RELHLD S RELHLD=0
;
;Don't do PAT^IBCNBMI for ICB ACCEPAPI^IBCNICB interface
I $G(IBSUPRES)'>0,+IBPOLDA D PAT^IBCNBMI(DFN,IBPOLDA) ; update DOB&SSN of Pat Ins from Pat file
D POL^IBCNSU41(DFN) ; update Tricare sponsor data
D COVERED^IBCNSM31(DFN) ; update 'Covered by Insurance' field (2,.3192
I +IBSOURCE=3 D IVM(1,IBBUFDA,$G(IVMREPTR),$G(IBSUPRES)) ; update/notify IVM
;Suppress Write in $$DUPCO^IBCNSOK1 if called from ICB Interface
I +IBINSDA,+IBPOLDA S IBX=$$DUPCO^IBCNSOK1(DFN,IBINSDA,IBPOLDA,$S($G(IBSUPRES)>0:0,1:1)) ; warning if duplicate policy added for patient
S RESULT(0)="0"_$S($G(IBX):"^Warning - Duplicate or inconsistent insurance data",1:"")
;
;Suppress Write in $$DUPPOL^IBCNSOK1 if called from ICB Interface
I +IBGRPDA S IBX=$$DUPPOL^IBCNSOK1(IBGRPDA,$S($G(IBSUPRES)>0:0,1:1)) ; warning if duplicate plan was added
S:IBX RESULT(0)=RESULT(0)_"^Warning - Duplicate or inconsistent policy data"
;
;Suppress Write in $$PTHLD^IBOHCR if called from ICB Interface
I +IBNEWPOL I +$$PTHLD^IBOHCR(DFN,1,$S($G(IBSUPRES)>0:0,1:1)) D
. W:$G(IBSUPRES)'>0 !!,"Patient's bills On Hold date updated due to new insurance."
. S RESULT(0)=RESULT(0)_"^Patient's bills On Hold date updated due to new insurance"
;
I $$HOLD^IBCNBLL(DFN) D
. W:$G(IBSUPRES)'>0 !!,"There are bills On Hold for this patient."
. S RESULT(0)=RESULT(0)_"^There are bills On Hold for this patient"
;
;Suppress DIR call functionality for ICB ACCEPAPI^IBCNICB interface
D:$G(IBSUPRES)'>0
. W !! S DIR(0)="FO",DIR("A")="Press 'V' to view the changes or Return to continue" D ^DIR
. I Y="V"!(Y="v") D
. . W !!
. . D INS^IBCNBCD(IBBUFDA,IBINSDA),WAIT^IBCNBUH
. . D GRP^IBCNBCD(IBBUFDA,IBGRPDA),WAIT^IBCNBUH
. . D POLICY^IBCNBCD(IBBUFDA,IBPOLDA),WAIT^IBCNBUH
. . S IBSIEN=$S(+IBPOLDA:IBPOLDA_","_DFN_",",1:0)
. . I +IBSIEN,+$G(IBSEL) D SBDISP^IBCNBCD4(IBBUFDA,DFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,IBFNAM,IBVAL,.IBHOLD,.IBXHOLD),WAIT^IBCNBUH
;
; IB*2.0*631/TAZ Add CREATION TO PROCESSING Tracking
D TRACK
;
;IB*687/TAZ - File Accepted policy in INTERFACILITY INSURANCE UPDATE File (#365.19)
;IBCNICB was set in routine IBCNICB. It will let us know if the buffer entry in file #355.33 was processed by
; the COTS ICB product. This field will be used set ICB PROCESSED BUFFER (#365.19,1.08).
D LOC^IBCNIUF(DFN,IBINSDA,IBPOLDA,,IBBUFDA,$$GET1^DIQ(355.33,IBBUFDA_",",.03,"E"),$G(IBCNICB))
;
; IB*2*595/DM if SOI is eIV, update insurance record IEN field in response file (#365/.12)
I $P(^IBA(355.33,IBBUFDA,0),U,3)=$$FIND1^DIC(355.12,,,"eIV","C") D UPDIREC^IBCNEHL3($O(^IBCN(365,"AF",IBBUFDA,"")),IBPOLDA)
; update buffer file entry so only stub remains and status is changed
D STATUS^IBCNBEE(IBBUFDA,"A",IBNEWINS,IBNEWGRP,IBNEWPOL) ; update buffer entry's status to accepted
D DELDATA^IBCNBED(IBBUFDA) ; delete buffer's insurance/patient data
;
; IB*2.0*554
I $$HOLD^IBCNBLL(DFN),'$$BUFFER^IBCNBU1(DFN) D RELHLD(DFN)
;I +DFN,RELHLD D
;. ;Suppress Write in $$PTHLD^IBOHCR if called from ICB Interface
;. I +$$PTHLD^IBOHCR(DFN,2,$S($G(IBSUPRES)>0:0,1:1)) D
;. . I $G(IBSUPRES)'>0 W !!,"Patient has no other active Insurance.",!,"All patient bills On Hold waiting for Insurance to be released." D WAIT^IBCNBUH
;. . S RESULT=$G(RESULT)_"^Patient has no other active Insurance. All patient bills On Hold waiting for Insurance to be released."
;
S IBCDFN=IBPOLDA S:+IBSOURCE=3 IVMINSUP=1 D AFTER^IBCNSEVT,^IBCNSEVT ; insurance event driver
;
ACCPTQ Q
;
REJECT(IBBUFDA) ; process a buffer entry reject
; 1) update/notify IVM
; 2) buffer ins/group/policy data deleted
; 3) buffer entry status updated
; 4) if patient has no other active insurance then release any patient bills On Hold
;
N IBSUPRES,RESULT,RELHLD
;Set IBSUPRES to 0 to not suppress I/O within REJECT
S IBSUPRES=0,RELHLD=0
;
REJPROC ;Entry point for REJECAPI^IBCNICB (Patch 413)
;
N DFN S DFN=+$G(^IBA(355.33,+IBBUFDA,60))
N RELHLD S RELHLD=0
S RESULT="-1^PATIENT IEN MISSING FROM BUFFER ENTRY" Q:'$G(DFN)
I +$P($G(^IBA(355.33,+IBBUFDA,0)),U,3)=3 D IVM(0,IBBUFDA,$G(IVMREPTR),$G(IBSUPRES))
;
; IB*2.0*631/TAZ Add CREATION TO PROCESSING Tracking
D TRACK
;
S RESULT=0
D STATUS^IBCNBEE(+IBBUFDA,"R",0,0,0),DELDATA^IBCNBED(+IBBUFDA) W:$G(IBSUPRES)'>0 " ... done."
;
; IB*2.0*554
I $$HOLD^IBCNBLL(DFN),'$$BUFFER^IBCNBU1(DFN) D RELHLD(DFN)
;I +DFN,RELHLD D
;. ;Suppress Write in $$PTHLD^IBOHCR if called from ICB Interface
;. I +$$PTHLD^IBOHCR(DFN,2,$S($G(IBSUPRES)>0:0,1:1)) D
;. . I $G(IBSUPRES)'>0 W !!,"Patient has no other active Insurance.",!,"All patient bills On Hold waiting for Insurance to be released." D WAIT^IBCNBUH
;. . S RESULT=$G(RESULT)_"^Patient has no other active Insurance. All patient bills On Hold waiting for Insurance to be released."
;
Q
;
;
IVM(AR,IBBUFDA,IVMREPTR,IBSUPRES) ; IVM must be notified whenever a buffer entry
; that originated in IVM is accepted or rejected. This lets IVM clean up
; its files since IVM also has a buffer type file of insurance uploaded
; from the IVM center.
; If rejected and Interactive Reads not suppressed, IVM then ask the
; user for a reason it was rejected
; input: AR = 1 if accepted, 0 if rejected
; IBBUFDA = Internal Entry Number to 355.33 file
; IVMREPTR = Internal Entry Number to 301.91 file (Optional)
; IBSUPRES = If equals 1, suppress writes and interactive reads
;
N DFN,IBX,IBY I $P($G(^IBA(355.33,+IBBUFDA,0)),U,3)'=3 Q
;
S DFN=+$G(^IBA(355.33,+IBBUFDA,60))
S IBX=$P($G(^IBA(355.33,+IBBUFDA,20)),U,1)_U_$P($G(^IBA(355.33,+IBBUFDA,21)),U,1)_U_$P($G(^IBA(355.33,+IBBUFDA,90)),U,2) ; IB*2.0*497 (vd)
;
S IBY=$$UPDATE^IVMLINS4(DFN,AR,IBX,$G(IVMREPTR),$G(IBSUPRES))
Q
; ;IB*2.0*554
RELHLD(DFN) ;Check if need to release copay on hold
N IBN,X3,X5,IBX,IBFR,IBAT,IBCAT,IBTALK,IBVDT
S IBTALK=$S($G(IBSUPRES)>0:0,1:1)
S IBN=0
F S IBN=$O(^IB("AH",DFN,IBN)) Q:IBN="" D
. S IBX=$G(^IB(IBN,0))
. S X5=+$P(IBX,U,5) Q:X5'=8
. S IBFR=$P(IBX,U,14)
. S X3=$P(IBX,U,3)
. S IBVDT=$S(IBFR'="":IBFR,1:DT),IBAT=$P(^IBE(350.1,X3,0),U,11)
. S IBCAT=$S(IBAT<4:"INPATIENT",IBAT=4:"OUTPATIENT",IBAT=5:"PHARMACY",IBAT=8:"OUTPATIENT",IBAT=9:"INPATIENT",1:"")
. S IBCAT=$O(^IBE(355.31,"B",IBCAT,""))
. D CHKREL(DFN,IBVDT,IBN,IBCAT)
Q
;
CHKREL(DFN,IBINDT,IBN,IBCAT) ; -- release copay
; --Input DFN = patient
; IBINDT = date to check
; IBN = ien of copay on hold
; IBCAT = category of hold
; will determine if hold should be released
;
N IBCOV,IBDD,PLAN,POLCY,TRICHP,COV,CNT,TYPNAM,X,PLAN,ANYINS,INS,CHKCOV,PLNTYP
S (IBCOV,CNT,COV,TRICHP,POLCY)=0
I IBINDT="" S IBINDT=DT
S IBINDT=IBINDT\1
D ALL^IBCNS1(DFN,"IBDD",2,IBINDT) ;All active ins policies returned in IBDD array
S ANYINS=($O(IBDD(0))'="")
I 'ANYINS D RELEASE^IBOHCR(IBN) Q
F S POLCY=$O(IBDD(POLCY)) Q:'POLCY D
. S X=IBDD(POLCY,0)
. S PLAN=$P(X,U,18) I PLAN="" Q
. S INS=$P(X,U,1)_","
. S COV=$$GET1^DIQ(36,INS,1,"I") S COV=$S(COV="N":0,1:1)
. S TYPNAM=$$GET1^DIQ(36,INS,.13,"E"),CNT=CNT+1
. S:TYPNAM["TRICARE" TRICHP=1 S:TYPNAM["CHAMPVA" TRICHP=1
. I TYPNAM'["TRICARE",TYPNAM'["CHAMPVA",COV D
. . I 'IBCOV S IBCOV=$$PLCOV^IBCNSU3(PLAN,IBINDT,IBCAT)
; remove hold if only has TRICARE OR CHAMPVA
I $G(CNT)=1,TRICHP D RELEASE^IBOHCR(IBN) Q
; remove hold if multiple coverage and TRICARE or CHAMPVA and no ibcov
I $G(CNT)>1,TRICHP I 'IBCOV D RELEASE^IBOHCR(IBN) Q
; remove hold if no TRICARE or CHAMPVA and no ibcov
I 'TRICHP,'IBCOV D RELEASE^IBOHCR(IBN)
Q
;
;IB*2.0*631/TAZ Added Tracking for CREATION TO PROCESSING TRACKING File
TRACK ;Build CREATION TO PROCESSING TRACKING File (#355.36)
N ERROR,FDA,IBMSG,RESP,SOI,TQN,WE
S WE=""
S RESP=$O(^IBCN(365,"AF",IBBUFDA,""),-1) I RESP D
. S TQN=$$GET1^DIQ(365,RESP_",",.05,"I")
. S WE=$$GET1^DIQ(365.1,TQN_",",.1,"I")
. S SOI=$$GET1^DIQ(365.1,TQN_",",3.02,"I")
I 'RESP D
. ; Get data when a user processes a buffer entry before EIV can create an HL7 for a transmission
. S TQN=$O(^IBCN(365.1,"D",IBBUFDA,""),-1)
. I TQN D Q
.. S WE=$$GET1^DIQ(365.1,TQN_",",.1,"I")
.. S SOI=$$GET1^DIQ(365.1,TQN_",",3.02,"I")
. S WE=6
. S SOI=$$GET1^DIQ(355.33,IBBUFDA_",",.03,"I")
I WE=7 Q ; Do not want to track.
S FDA(355.36,"+1,",.01)=$$NOW^XLFDT ; DATE PROCESSED
S FDA(355.36,"+1,",.02)=$S("^1^2^3^4^"[(U_WE_U):2,"^5^6^"[(U_WE_U):4,1:"") ;TYPE OF PROCESSING
S FDA(355.36,"+1,",.03)=SOI ; SOURCE OF INFORMATION
S FDA(355.36,"+1,",.04)=0 ; EIV AUTO-UPDATE (always 0 for No if it hits this code.)
S FDA(355.36,"+1,",.05)=$G(TQN) ; EIV INQUIRY
S FDA(355.36,"+1,",.06)=RESP ; EIV RESPONSE
S FDA(355.36,"+1,",.07)=$G(IBBUFDA) ; BUFFER
S FDA(355.36,"+1,",.08)=WE ; WHICH EXTRACT (SOURCE OF REQUEST)
D UPDATE^DIE("","FDA",,"ERROR")
;
I $D(ERROR) D
. D MSG003^IBCNEMS1(.IBMSG,.ERROR,TQN,RESP,$G(IBBUFDA))
. D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: Error writing to the CREATION TO PROCESSING TRACKING File (#355.36)","IBMSG(")
Q
;
EFFDTCHK(IBBUFDA,IBSIEN,IBMVPOL) ;
;IB*737/CKB - if processing this entry would result in Effective Date (#2.312,8) being null,
; abort processing by returning 1
;
;
;Can't ACCEPT the entry if the Eff Date (#355.33,60.02) is null (includes Replace scenario)
;
;Overwrite - can't ACCEPT the entry if:
; Exp Date (#355.33,60.03) is null;
; AND Exp Date (#2.312,3) is NOT null;
; AND Eff Date (#355.33,60.02) > Exp Date (#2.312,3)
;
;Merge - can't ACCEPT the entry if:
; Exp Date (#2.312,3) is NOT null;
; AND Eff Date (#2.312,8) is null;
; AND Eff Date (#355.33,60.02) > Exp Date (#2.312,3);
; AND Exp Date (#355.33,60.03) is null
;
;Individual - can't ACCEPT the entry if:
; Exp Date (#2.312,3) is NOT null;
; AND Eff Date (#355.33,60.02) > Exp Date (#2.312,3);
; AND User answered YES to Accept Eff Date (#355.33,60.02) - adds to ^TMP($J,"IB BUFFER SELECTED",60.02);
; AND (User answered NO to Accept Exp Date (#355.33,60.03) OR (#355.33,60.03) is null)
;
N ABORT,BUFEFFDT,BUFEXPDT,CHGEFFDT,CHGEXPDT,INSEFFDT,INSEXPDT
S ABORT=0
S BUFEFFDT=$$GET1^DIQ(355.33,IBBUFDA_",",60.02,"I")
S BUFEXPDT=$$GET1^DIQ(355.33,IBBUFDA_",",60.03,"I")
S INSEFFDT=$$GET1^DIQ(2.312,IBSIEN,8,"I")
S INSEXPDT=$$GET1^DIQ(2.312,IBSIEN,3,"I")
;
;Check Buffer Eff and Exp Date to ensure they are valid dates, if not abort processing
; Abort processing if Buffer Eff Date is a "" (null) date
I $$VALIDDT^IBCNINSU(BUFEFFDT)<1 S ABORT=1 G EFFDTCHKQ
; Allow the Buffer Exp Date to have a "" (null) date, this date is evaluated below
I $$VALIDDT^IBCNINSU(BUFEXPDT)<0 S ABORT=1 G EFFDTCHKQ
;
I $G(IBSIEN)="" G EFFDTCHKQ ; buffer okay, can't corrupt existing policy as it's a new policy
I INSEXPDT="" G EFFDTCHKQ ; buffer entry okay to process
;
; IBMVPOL = 1:Merge, 2:Overwrite, 3:Replace, 4:Individual
I IBMVPOL=2 I (BUFEXPDT="")&(INSEXPDT'="")&(BUFEFFDT>INSEXPDT) S ABORT=1 G EFFDTCHKQ
;
I IBMVPOL=1 I INSEFFDT=""&(BUFEFFDT>INSEXPDT)&(BUFEXPDT="") S ABORT=1 G EFFDTCHKQ
;
I IBMVPOL=4 D
. S CHGEFFDT=$D(^TMP($J,"IB BUFFER SELECTED",60.02)) ; user wants to change the Effective Date
. S CHGEXPDT=$D(^TMP($J,"IB BUFFER SELECTED",60.03)) ; user wants to change the Expiration Date
. I (BUFEFFDT>INSEXPDT)&(CHGEFFDT)&((CHGEXPDT="")!(BUFEXPDT="")) S ABORT=1
;
EFFDTCHKQ ;
Q ABORT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBAR 15985 printed Sep 23, 2025@19:50 Page 2
IBCNBAR ;ALB/ARH-Ins Buffer: process Accept and Reject ;15 Jan 2009
+1 ;;2.0;INTEGRATED BILLING;**82,240,345,413,416,497,528,554,595,631,687,737**;21-MAR-94;Build 19
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
ACCEPT(IBBUFDA,DFN,IBINSDA,IBGRPDA,IBPOLDA,IBMVINS,IBMVGRP,IBMVPOL,IBMVSUB,IBNEWINS,IBNEWGRP,IBNEWPOL,IBELIG,IBSEL,IBRIEN,IBSIEN,IBFNAM,IBVAL,IBHOLD,IBXHOLD) ; move buffer data into Insurance files then cleanup
+1 ; 1) data moved into insurance files, new records created if needed or edit existing ones
+2 ; 2) complete some general functions that are executed whenever insurance is entered/edited
+3 ; 3) allow user to view buffer entry and new/updated insurance records
+4 ; 4) buffer ins/group/policy data deleted
+5 ; 5) buffer entry status updated
+6 ;
+7 NEW RESULT,IBSUPRES
+8 ;Set IBSUPRES to zero to not suppress I/O within Accept
+9 SET IBSUPRES=0
+10 ;
PROCESS ; process all changes selected by user, add/edit insurance files based
+1 ; on buffer data. Entry point for ACCEPAPI^IBCNICB (patch 413)
+2 ;
+3 ; insurance event driver
NEW IVMINSUP,IBNEW,IBCDFN,RIEN
SET IBCDFN=IBPOLDA
if +IBNEWPOL
SET IBNEW=1
DO BEFORE^IBCNSEVT
+4 ;
+5 NEW DIR,X,Y,IBX,IBINSH,IBGRPH,IBPOLH,IBSUBH
SET (IBINSH,IBGRPH,IBPOLH,IBSUBH)="Updated"
if $GET(IBSUPRES)'>0
WRITE " ...",!
+6 ;
+7 ;IB*737/CKB - if processing this entry would result in Effective Date (#2.312,8) being null, abort processing
+8 IF $GET(IBCNICB)
SET IBSIEN=$SELECT(+IBPOLDA:IBPOLDA_","_DFN_",",1:"")
+9 SET IBBUFABORT=$$EFFDTCHK(IBBUFDA,IBSIEN,+IBMVPOL)
if IBBUFABORT
GOTO ACCPTQ
+10 ;
+11 SET RESULT(0)="-1^Add new INSURANCE COMPANY failed"
+12 IF +IBNEWINS
SET IBINSDA=+$$NEWINS^IBCNBMN(IBBUFDA)
if 'IBINSDA
GOTO ACCPTQ
SET IBINSH="Created"
SET RESULT(1)="IBINSDA^"_IBINSDA
+13 ;
+14 SET RESULT(0)="-1^Add new GROUP INSURANCE PLAN failed"
+15 IF +IBNEWGRP
SET IBGRPDA=+$$NEWGRP^IBCNBMN(IBBUFDA,+IBINSDA)
if 'IBGRPDA
GOTO ACCPTQ
SET IBGRPH="Created"
SET RESULT(2)="IBGRPDA^"_IBGRPDA
+16 ;
+17 SET RESULT(0)="-1^Add new patient insurance policy failed"
+18 IF +IBNEWPOL
SET IBPOLDA=+$$NEWPOL^IBCNBMN(IBBUFDA,+IBINSDA,+IBGRPDA)
if 'IBPOLDA
GOTO ACCPTQ
SET (IBPOLH,IBSUBH)="Created"
SET RESULT(3)="IBPOLDA^"_IBPOLDA
+19 ;
+20 ;Only do this check for ICB ACCEPAPI^IBCNICB interface
+21 SET RESULT(0)="-1^Move TYPE parameter value="_IBMVINS_" is invalid"
+22 IF $GET(IBSUPRES)>0
IF "^1^2^3^"'[("^"_IBMVINS_"^")
QUIT
+23 ;
+24 SET RESULT(0)="-1^Move buffer data to insurance files failed"
+25 IF +IBINSDA
IF +IBMVINS
DO INS^IBCNBMI(IBBUFDA,IBINSDA,+IBMVINS,.RESULT)
if $GET(IBSUPRES)'>0
WRITE !,"Insurance Company "_IBINSH_"..."
+26 IF +IBINSDA
IF +IBMVGRP
IF +IBGRPDA
Begin DoDot:1
+27 DO GRP^IBCNBMI(IBBUFDA,IBGRPDA,+IBMVGRP,.RESULT)
+28 ; For ICB Interface ensure INDIVIDUAL POLICY PATIENT (.1) field is
+29 ; appropriate for IS THIS A GROUP POLICY? (.02) field
+30 IF $GET(IBSUPRES)>0
Begin DoDot:2
+31 NEW IBFLDS,IBISGRP,IBPAT
+32 SET IBISGRP=$$GET1^DIQ(355.3,IBGRPDA,.02,"I")
+33 SET IBPAT=$$GET1^DIQ(355.3,IBGRPDA,.1,"I")
+34 ;Quit if Group Policy and .1 field isn't populated
+35 IF IBISGRP>0
IF IBPAT'>0
QUIT
+36 ;Quit if Individual Policy and .1 field is populated.
+37 IF IBISGRP'>0
IF IBPAT>0
QUIT
+38 ;Delete .1 field if Group Policy
+39 IF IBISGRP>0
SET IBFLDS(355.3,IBGRPDA_",",.1)="@"
+40 IF IBISGRP'>0
SET IBFLDS(355.3,IBGRPDA_",",.1)=DFN
+41 DO FILE^DIE("","IBFLDS","IBERR")
End DoDot:2
+42 if $GET(IBSUPRES)'>0
WRITE !,"Group/Plan "_IBGRPH_"..."
End DoDot:1
+43 IF +IBINSDA
IF +IBMVPOL
IF +IBGRPDA
IF +IBPOLDA
DO POLICY^IBCNBMI(IBBUFDA,IBPOLDA,+IBMVPOL,.RESULT)
if $GET(IBSUPRES)'>0
WRITE !,"Patient Policy "_IBPOLH_"..."
+44 ; I +IBELIG S RIEN=$O(^IBCN(365,"AF",IBBUFDA,""),-1) I RIEN D GRPFILE^IBCNEHL1(DFN,IBPOLDA,RIEN,0),EBFILE^IBCNEHL1(DFN,IBPOLDA,RIEN,0) W:$G(IBSUPRES)'>0 !,"Eligibility/Benfits data Updated..."
+45 ;
+46 SET RESULT(0)="-1^Move Patient Registration data into Insurance files failed"
+47 IF +IBINSDA
IF +$GET(IBMVSUB)
IF +IBGRPDA
IF +IBPOLDA
DO SUB^IBCNBMI(IBBUFDA,IBPOLDA,IBRIEN,IBSEL,+IBMVSUB,.RESULT,DFN,IBFNAM,IBVAL,.IBHOLD,.IBXHOLD)
if $GET(IBSUPRES)'>0
WRITE !,"Subscriber Insurance Information "_IBSUBH_"..."
+48 ;
+49 ;IB*2.0*554 Fix spelling error
IF +IBELIG
SET RIEN=$ORDER(^IBCN(365,"AF",IBBUFDA,""),-1)
IF RIEN
DO GRPFILE^IBCNEHL1(DFN,IBPOLDA,RIEN,0)
DO EBFILE^IBCNEHL1(DFN,IBPOLDA,RIEN,0)
if $GET(IBSUPRES)'>0
WRITE !,"Eligibility/Benefits data Updated..."
+50 ;
+51 ;Only do this update for ICB ACCEPAPI^IBCNICB interface
+52 IF $GET(IBSUPRES)>0
IF +IBMVPOL
IF +IBGRPDA
IF +IBPOLDA
IF 'IBNEWPOL
DO UPDPOL^IBCNICB(.RESULT,IBBUFDA,DFN,IBINSDA,IBGRPDA,IBPOLDA)
+53 ;
CLEANUP ; general updates and checks done whenever insurance is added/edited and clean up buffer file
+1 NEW IBSOURCE
SET IBSOURCE=$PIECE($GET(^IBA(355.33,IBBUFDA,0)),U,3)
+2 NEW RELHLD
SET RELHLD=0
+3 ;
+4 ;Don't do PAT^IBCNBMI for ICB ACCEPAPI^IBCNICB interface
+5 ; update DOB&SSN of Pat Ins from Pat file
IF $GET(IBSUPRES)'>0
IF +IBPOLDA
DO PAT^IBCNBMI(DFN,IBPOLDA)
+6 ; update Tricare sponsor data
DO POL^IBCNSU41(DFN)
+7 ; update 'Covered by Insurance' field (2,.3192
DO COVERED^IBCNSM31(DFN)
+8 ; update/notify IVM
IF +IBSOURCE=3
DO IVM(1,IBBUFDA,$GET(IVMREPTR),$GET(IBSUPRES))
+9 ;Suppress Write in $$DUPCO^IBCNSOK1 if called from ICB Interface
+10 ; warning if duplicate policy added for patient
IF +IBINSDA
IF +IBPOLDA
SET IBX=$$DUPCO^IBCNSOK1(DFN,IBINSDA,IBPOLDA,$SELECT($GET(IBSUPRES)>0:0,1:1))
+11 SET RESULT(0)="0"_$SELECT($GET(IBX):"^Warning - Duplicate or inconsistent insurance data",1:"")
+12 ;
+13 ;Suppress Write in $$DUPPOL^IBCNSOK1 if called from ICB Interface
+14 ; warning if duplicate plan was added
IF +IBGRPDA
SET IBX=$$DUPPOL^IBCNSOK1(IBGRPDA,$SELECT($GET(IBSUPRES)>0:0,1:1))
+15 if IBX
SET RESULT(0)=RESULT(0)_"^Warning - Duplicate or inconsistent policy data"
+16 ;
+17 ;Suppress Write in $$PTHLD^IBOHCR if called from ICB Interface
+18 IF +IBNEWPOL
IF +$$PTHLD^IBOHCR(DFN,1,$SELECT($GET(IBSUPRES)>0:0,1:1))
Begin DoDot:1
+19 if $GET(IBSUPRES)'>0
WRITE !!,"Patient's bills On Hold date updated due to new insurance."
+20 SET RESULT(0)=RESULT(0)_"^Patient's bills On Hold date updated due to new insurance"
End DoDot:1
+21 ;
+22 IF $$HOLD^IBCNBLL(DFN)
Begin DoDot:1
+23 if $GET(IBSUPRES)'>0
WRITE !!,"There are bills On Hold for this patient."
+24 SET RESULT(0)=RESULT(0)_"^There are bills On Hold for this patient"
End DoDot:1
+25 ;
+26 ;Suppress DIR call functionality for ICB ACCEPAPI^IBCNICB interface
+27 if $GET(IBSUPRES)'>0
Begin DoDot:1
+28 WRITE !!
SET DIR(0)="FO"
SET DIR("A")="Press 'V' to view the changes or Return to continue"
DO ^DIR
+29 IF Y="V"!(Y="v")
Begin DoDot:2
+30 WRITE !!
+31 DO INS^IBCNBCD(IBBUFDA,IBINSDA)
DO WAIT^IBCNBUH
+32 DO GRP^IBCNBCD(IBBUFDA,IBGRPDA)
DO WAIT^IBCNBUH
+33 DO POLICY^IBCNBCD(IBBUFDA,IBPOLDA)
DO WAIT^IBCNBUH
+34 SET IBSIEN=$SELECT(+IBPOLDA:IBPOLDA_","_DFN_",",1:0)
+35 IF +IBSIEN
IF +$GET(IBSEL)
DO SBDISP^IBCNBCD4(IBBUFDA,DFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,IBFNAM,IBVAL,.IBHOLD,.IBXHOLD)
DO WAIT^IBCNBUH
End DoDot:2
End DoDot:1
+36 ;
+37 ; IB*2.0*631/TAZ Add CREATION TO PROCESSING Tracking
+38 DO TRACK
+39 ;
+40 ;IB*687/TAZ - File Accepted policy in INTERFACILITY INSURANCE UPDATE File (#365.19)
+41 ;IBCNICB was set in routine IBCNICB. It will let us know if the buffer entry in file #355.33 was processed by
+42 ; the COTS ICB product. This field will be used set ICB PROCESSED BUFFER (#365.19,1.08).
+43 DO LOC^IBCNIUF(DFN,IBINSDA,IBPOLDA,,IBBUFDA,$$GET1^DIQ(355.33,IBBUFDA_",",.03,"E"),$GET(IBCNICB))
+44 ;
+45 ; IB*2*595/DM if SOI is eIV, update insurance record IEN field in response file (#365/.12)
+46 IF $PIECE(^IBA(355.33,IBBUFDA,0),U,3)=$$FIND1^DIC(355.12,,,"eIV","C")
DO UPDIREC^IBCNEHL3($ORDER(^IBCN(365,"AF",IBBUFDA,"")),IBPOLDA)
+47 ; update buffer file entry so only stub remains and status is changed
+48 ; update buffer entry's status to accepted
DO STATUS^IBCNBEE(IBBUFDA,"A",IBNEWINS,IBNEWGRP,IBNEWPOL)
+49 ; delete buffer's insurance/patient data
DO DELDATA^IBCNBED(IBBUFDA)
+50 ;
+51 ; IB*2.0*554
+52 IF $$HOLD^IBCNBLL(DFN)
IF '$$BUFFER^IBCNBU1(DFN)
DO RELHLD(DFN)
+53 ;I +DFN,RELHLD D
+54 ;. ;Suppress Write in $$PTHLD^IBOHCR if called from ICB Interface
+55 ;. I +$$PTHLD^IBOHCR(DFN,2,$S($G(IBSUPRES)>0:0,1:1)) D
+56 ;. . I $G(IBSUPRES)'>0 W !!,"Patient has no other active Insurance.",!,"All patient bills On Hold waiting for Insurance to be released." D WAIT^IBCNBUH
+57 ;. . S RESULT=$G(RESULT)_"^Patient has no other active Insurance. All patient bills On Hold waiting for Insurance to be released."
+58 ;
+59 ; insurance event driver
SET IBCDFN=IBPOLDA
if +IBSOURCE=3
SET IVMINSUP=1
DO AFTER^IBCNSEVT
DO ^IBCNSEVT
+60 ;
ACCPTQ QUIT
+1 ;
REJECT(IBBUFDA) ; process a buffer entry reject
+1 ; 1) update/notify IVM
+2 ; 2) buffer ins/group/policy data deleted
+3 ; 3) buffer entry status updated
+4 ; 4) if patient has no other active insurance then release any patient bills On Hold
+5 ;
+6 NEW IBSUPRES,RESULT,RELHLD
+7 ;Set IBSUPRES to 0 to not suppress I/O within REJECT
+8 SET IBSUPRES=0
SET RELHLD=0
+9 ;
REJPROC ;Entry point for REJECAPI^IBCNICB (Patch 413)
+1 ;
+2 NEW DFN
SET DFN=+$GET(^IBA(355.33,+IBBUFDA,60))
+3 NEW RELHLD
SET RELHLD=0
+4 SET RESULT="-1^PATIENT IEN MISSING FROM BUFFER ENTRY"
if '$GET(DFN)
QUIT
+5 IF +$PIECE($GET(^IBA(355.33,+IBBUFDA,0)),U,3)=3
DO IVM(0,IBBUFDA,$GET(IVMREPTR),$GET(IBSUPRES))
+6 ;
+7 ; IB*2.0*631/TAZ Add CREATION TO PROCESSING Tracking
+8 DO TRACK
+9 ;
+10 SET RESULT=0
+11 DO STATUS^IBCNBEE(+IBBUFDA,"R",0,0,0)
DO DELDATA^IBCNBED(+IBBUFDA)
if $GET(IBSUPRES)'>0
WRITE " ... done."
+12 ;
+13 ; IB*2.0*554
+14 IF $$HOLD^IBCNBLL(DFN)
IF '$$BUFFER^IBCNBU1(DFN)
DO RELHLD(DFN)
+15 ;I +DFN,RELHLD D
+16 ;. ;Suppress Write in $$PTHLD^IBOHCR if called from ICB Interface
+17 ;. I +$$PTHLD^IBOHCR(DFN,2,$S($G(IBSUPRES)>0:0,1:1)) D
+18 ;. . I $G(IBSUPRES)'>0 W !!,"Patient has no other active Insurance.",!,"All patient bills On Hold waiting for Insurance to be released." D WAIT^IBCNBUH
+19 ;. . S RESULT=$G(RESULT)_"^Patient has no other active Insurance. All patient bills On Hold waiting for Insurance to be released."
+20 ;
+21 QUIT
+22 ;
+23 ;
IVM(AR,IBBUFDA,IVMREPTR,IBSUPRES) ; IVM must be notified whenever a buffer entry
+1 ; that originated in IVM is accepted or rejected. This lets IVM clean up
+2 ; its files since IVM also has a buffer type file of insurance uploaded
+3 ; from the IVM center.
+4 ; If rejected and Interactive Reads not suppressed, IVM then ask the
+5 ; user for a reason it was rejected
+6 ; input: AR = 1 if accepted, 0 if rejected
+7 ; IBBUFDA = Internal Entry Number to 355.33 file
+8 ; IVMREPTR = Internal Entry Number to 301.91 file (Optional)
+9 ; IBSUPRES = If equals 1, suppress writes and interactive reads
+10 ;
+11 NEW DFN,IBX,IBY
IF $PIECE($GET(^IBA(355.33,+IBBUFDA,0)),U,3)'=3
QUIT
+12 ;
+13 SET DFN=+$GET(^IBA(355.33,+IBBUFDA,60))
+14 ; IB*2.0*497 (vd)
SET IBX=$PIECE($GET(^IBA(355.33,+IBBUFDA,20)),U,1)_U_$PIECE($GET(^IBA(355.33,+IBBUFDA,21)),U,1)_U_$PIECE($GET(^IBA(355.33,+IBBUFDA,90)),U,2)
+15 ;
+16 SET IBY=$$UPDATE^IVMLINS4(DFN,AR,IBX,$GET(IVMREPTR),$GET(IBSUPRES))
+17 QUIT
+18 ; ;IB*2.0*554
RELHLD(DFN) ;Check if need to release copay on hold
+1 NEW IBN,X3,X5,IBX,IBFR,IBAT,IBCAT,IBTALK,IBVDT
+2 SET IBTALK=$SELECT($GET(IBSUPRES)>0:0,1:1)
+3 SET IBN=0
+4 FOR
SET IBN=$ORDER(^IB("AH",DFN,IBN))
if IBN=""
QUIT
Begin DoDot:1
+5 SET IBX=$GET(^IB(IBN,0))
+6 SET X5=+$PIECE(IBX,U,5)
if X5'=8
QUIT
+7 SET IBFR=$PIECE(IBX,U,14)
+8 SET X3=$PIECE(IBX,U,3)
+9 SET IBVDT=$SELECT(IBFR'="":IBFR,1:DT)
SET IBAT=$PIECE(^IBE(350.1,X3,0),U,11)
+10 SET IBCAT=$SELECT(IBAT<4:"INPATIENT",IBAT=4:"OUTPATIENT",IBAT=5:"PHARMACY",IBAT=8:"OUTPATIENT",IBAT=9:"INPATIENT",1:"")
+11 SET IBCAT=$ORDER(^IBE(355.31,"B",IBCAT,""))
+12 DO CHKREL(DFN,IBVDT,IBN,IBCAT)
End DoDot:1
+13 QUIT
+14 ;
CHKREL(DFN,IBINDT,IBN,IBCAT) ; -- release copay
+1 ; --Input DFN = patient
+2 ; IBINDT = date to check
+3 ; IBN = ien of copay on hold
+4 ; IBCAT = category of hold
+5 ; will determine if hold should be released
+6 ;
+7 NEW IBCOV,IBDD,PLAN,POLCY,TRICHP,COV,CNT,TYPNAM,X,PLAN,ANYINS,INS,CHKCOV,PLNTYP
+8 SET (IBCOV,CNT,COV,TRICHP,POLCY)=0
+9 IF IBINDT=""
SET IBINDT=DT
+10 SET IBINDT=IBINDT\1
+11 ;All active ins policies returned in IBDD array
DO ALL^IBCNS1(DFN,"IBDD",2,IBINDT)
+12 SET ANYINS=($ORDER(IBDD(0))'="")
+13 IF 'ANYINS
DO RELEASE^IBOHCR(IBN)
QUIT
+14 FOR
SET POLCY=$ORDER(IBDD(POLCY))
if 'POLCY
QUIT
Begin DoDot:1
+15 SET X=IBDD(POLCY,0)
+16 SET PLAN=$PIECE(X,U,18)
IF PLAN=""
QUIT
+17 SET INS=$PIECE(X,U,1)_","
+18 SET COV=$$GET1^DIQ(36,INS,1,"I")
SET COV=$SELECT(COV="N":0,1:1)
+19 SET TYPNAM=$$GET1^DIQ(36,INS,.13,"E")
SET CNT=CNT+1
+20 if TYPNAM["TRICARE"
SET TRICHP=1
if TYPNAM["CHAMPVA"
SET TRICHP=1
+21 IF TYPNAM'["TRICARE"
IF TYPNAM'["CHAMPVA"
IF COV
Begin DoDot:2
+22 IF 'IBCOV
SET IBCOV=$$PLCOV^IBCNSU3(PLAN,IBINDT,IBCAT)
End DoDot:2
End DoDot:1
+23 ; remove hold if only has TRICARE OR CHAMPVA
+24 IF $GET(CNT)=1
IF TRICHP
DO RELEASE^IBOHCR(IBN)
QUIT
+25 ; remove hold if multiple coverage and TRICARE or CHAMPVA and no ibcov
+26 IF $GET(CNT)>1
IF TRICHP
IF 'IBCOV
DO RELEASE^IBOHCR(IBN)
QUIT
+27 ; remove hold if no TRICARE or CHAMPVA and no ibcov
+28 IF 'TRICHP
IF 'IBCOV
DO RELEASE^IBOHCR(IBN)
+29 QUIT
+30 ;
+31 ;IB*2.0*631/TAZ Added Tracking for CREATION TO PROCESSING TRACKING File
TRACK ;Build CREATION TO PROCESSING TRACKING File (#355.36)
+1 NEW ERROR,FDA,IBMSG,RESP,SOI,TQN,WE
+2 SET WE=""
+3 SET RESP=$ORDER(^IBCN(365,"AF",IBBUFDA,""),-1)
IF RESP
Begin DoDot:1
+4 SET TQN=$$GET1^DIQ(365,RESP_",",.05,"I")
+5 SET WE=$$GET1^DIQ(365.1,TQN_",",.1,"I")
+6 SET SOI=$$GET1^DIQ(365.1,TQN_",",3.02,"I")
End DoDot:1
+7 IF 'RESP
Begin DoDot:1
+8 ; Get data when a user processes a buffer entry before EIV can create an HL7 for a transmission
+9 SET TQN=$ORDER(^IBCN(365.1,"D",IBBUFDA,""),-1)
+10 IF TQN
Begin DoDot:2
+11 SET WE=$$GET1^DIQ(365.1,TQN_",",.1,"I")
+12 SET SOI=$$GET1^DIQ(365.1,TQN_",",3.02,"I")
End DoDot:2
QUIT
+13 SET WE=6
+14 SET SOI=$$GET1^DIQ(355.33,IBBUFDA_",",.03,"I")
End DoDot:1
+15 ; Do not want to track.
IF WE=7
QUIT
+16 ; DATE PROCESSED
SET FDA(355.36,"+1,",.01)=$$NOW^XLFDT
+17 ;TYPE OF PROCESSING
SET FDA(355.36,"+1,",.02)=$SELECT("^1^2^3^4^"[(U_WE_U):2,"^5^6^"[(U_WE_U):4,1:"")
+18 ; SOURCE OF INFORMATION
SET FDA(355.36,"+1,",.03)=SOI
+19 ; EIV AUTO-UPDATE (always 0 for No if it hits this code.)
SET FDA(355.36,"+1,",.04)=0
+20 ; EIV INQUIRY
SET FDA(355.36,"+1,",.05)=$GET(TQN)
+21 ; EIV RESPONSE
SET FDA(355.36,"+1,",.06)=RESP
+22 ; BUFFER
SET FDA(355.36,"+1,",.07)=$GET(IBBUFDA)
+23 ; WHICH EXTRACT (SOURCE OF REQUEST)
SET FDA(355.36,"+1,",.08)=WE
+24 DO UPDATE^DIE("","FDA",,"ERROR")
+25 ;
+26 IF $DATA(ERROR)
Begin DoDot:1
+27 DO MSG003^IBCNEMS1(.IBMSG,.ERROR,TQN,RESP,$GET(IBBUFDA))
+28 DO MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: Error writing to the CREATION TO PROCESSING TRACKING File (#355.36)","IBMSG(")
End DoDot:1
+29 QUIT
+30 ;
EFFDTCHK(IBBUFDA,IBSIEN,IBMVPOL) ;
+1 ;IB*737/CKB - if processing this entry would result in Effective Date (#2.312,8) being null,
+2 ; abort processing by returning 1
+3 ;
+4 ;
+5 ;Can't ACCEPT the entry if the Eff Date (#355.33,60.02) is null (includes Replace scenario)
+6 ;
+7 ;Overwrite - can't ACCEPT the entry if:
+8 ; Exp Date (#355.33,60.03) is null;
+9 ; AND Exp Date (#2.312,3) is NOT null;
+10 ; AND Eff Date (#355.33,60.02) > Exp Date (#2.312,3)
+11 ;
+12 ;Merge - can't ACCEPT the entry if:
+13 ; Exp Date (#2.312,3) is NOT null;
+14 ; AND Eff Date (#2.312,8) is null;
+15 ; AND Eff Date (#355.33,60.02) > Exp Date (#2.312,3);
+16 ; AND Exp Date (#355.33,60.03) is null
+17 ;
+18 ;Individual - can't ACCEPT the entry if:
+19 ; Exp Date (#2.312,3) is NOT null;
+20 ; AND Eff Date (#355.33,60.02) > Exp Date (#2.312,3);
+21 ; AND User answered YES to Accept Eff Date (#355.33,60.02) - adds to ^TMP($J,"IB BUFFER SELECTED",60.02);
+22 ; AND (User answered NO to Accept Exp Date (#355.33,60.03) OR (#355.33,60.03) is null)
+23 ;
+24 NEW ABORT,BUFEFFDT,BUFEXPDT,CHGEFFDT,CHGEXPDT,INSEFFDT,INSEXPDT
+25 SET ABORT=0
+26 SET BUFEFFDT=$$GET1^DIQ(355.33,IBBUFDA_",",60.02,"I")
+27 SET BUFEXPDT=$$GET1^DIQ(355.33,IBBUFDA_",",60.03,"I")
+28 SET INSEFFDT=$$GET1^DIQ(2.312,IBSIEN,8,"I")
+29 SET INSEXPDT=$$GET1^DIQ(2.312,IBSIEN,3,"I")
+30 ;
+31 ;Check Buffer Eff and Exp Date to ensure they are valid dates, if not abort processing
+32 ; Abort processing if Buffer Eff Date is a "" (null) date
+33 IF $$VALIDDT^IBCNINSU(BUFEFFDT)<1
SET ABORT=1
GOTO EFFDTCHKQ
+34 ; Allow the Buffer Exp Date to have a "" (null) date, this date is evaluated below
+35 IF $$VALIDDT^IBCNINSU(BUFEXPDT)<0
SET ABORT=1
GOTO EFFDTCHKQ
+36 ;
+37 ; buffer okay, can't corrupt existing policy as it's a new policy
IF $GET(IBSIEN)=""
GOTO EFFDTCHKQ
+38 ; buffer entry okay to process
IF INSEXPDT=""
GOTO EFFDTCHKQ
+39 ;
+40 ; IBMVPOL = 1:Merge, 2:Overwrite, 3:Replace, 4:Individual
+41 IF IBMVPOL=2
IF (BUFEXPDT="")&(INSEXPDT'="")&(BUFEFFDT>INSEXPDT)
SET ABORT=1
GOTO EFFDTCHKQ
+42 ;
+43 IF IBMVPOL=1
IF INSEFFDT=""&(BUFEFFDT>INSEXPDT)&(BUFEXPDT="")
SET ABORT=1
GOTO EFFDTCHKQ
+44 ;
+45 IF IBMVPOL=4
Begin DoDot:1
+46 ; user wants to change the Effective Date
SET CHGEFFDT=$DATA(^TMP($JOB,"IB BUFFER SELECTED",60.02))
+47 ; user wants to change the Expiration Date
SET CHGEXPDT=$DATA(^TMP($JOB,"IB BUFFER SELECTED",60.03))
+48 IF (BUFEFFDT>INSEXPDT)&(CHGEFFDT)&((CHGEXPDT="")!(BUFEXPDT=""))
SET ABORT=1
End DoDot:1
+49 ;
EFFDTCHKQ ;
+1 QUIT ABORT
