IBCNICB ;ALB/SBW - Update utilities for the ICB interface ;1 SEP 2009
;;2.0;INTEGRATED BILLING;**413,416,528,549,687,737**;21-MAR-94;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
ACCEPAPI(RESULT,IBBUFDA,DFN,IBINSDA,IBGRPDA,IBPOLDA,IBMVINS,IBMVGRP,IBMVPOL,IBNEWINS,IBNEWGRP,IBNEWPOL,IVMREPTR,IBELIG) ;
;Provides API to be called by the Insurance Capture Buffer (ICB)
;application to move buffer data in Insurance Files then cleanup
;
;The call to PROCESS^IBCNBAR and embedded Sub calls are updated to
;provide data in the RESULT parameter and suppress user I/O when
;function is called by ICB.
;Input
; IBBUFDA - INSURANCE BUFFER (#355.33) file internal entry number (IEN) (Required)
; DFN - PATIENT (#2) file IEN (Required)
; IBINSDA - INSURANCE COMPANY (#36) File IEN if not adding new entry (Optional)
; IBGRPDA - GROUP INSURANCE PLAN (#355.3) File IEN if not adding new entry (Optional)
; IBPOLDA - INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN if
; not adding new entry (Optional)
; IBMVINS - Type for INSURANCE (Required)
; 1=Merge, 2=Overwrite, 3=Replace, 4=Unsupported
; IBMVGRP - Type for GROUP (Optional)
; 1=Merge, 2=Overwrite, 3=Replace, 4=Unsupported
; IBMVPOL - Type for POLICY (Optional)
; 1=Merge, 2=Overwrite, 3=Replace, 4=Unsupported
; IBNEWINS - Add new INSURANCE COMPANY flag (non-zero means add)
; IBNEWGRP - Add new GROUP INSURANCE PLAN flag (non-zero means add)
; IBNEWPOL - Add new patient insurance policy (non-zero means add)
; IVMREPTR - IVM REASONS FOR NOT UPLOADING (#301.91) IEN (Optional)
;
;OUTPUT
; RESULT - Returned Parameter Array with IENS of new entries and/or errors/warning.
; RESULT(0) = -1^error message
; RESULT(0) = 0 -Move worked
; RESULT(0) = 0 ^ warning message ^ warning message ^
; warning message ^ warning message
; - Move worked but there may be zero to 4 warning messages
; RESULT(1) = "IBINSDA^" IEN of new Insurance Company (#36) File
; RESULT(1,"ERR",#) - Array with any FM errors when data updated
; from file 355.33 to 36.
; RESULT(2) = "IBGRPDA^" IEN of new GROUP INSURANCE PLAN (#355.3) File
; RESULT(2,"ERR",#) - Array with any FM errors when data updated
; from file 355.33 to 355.3.
; RESULT(3) = "IBPOLDA^" IEN of new INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN
; RESULT(3,"ERR",#) - Array with any FM errors when data updated
; from file 355.33 to 2.312.
; RESULT(4) Contains the results of the call to UPDPOL^IBCNICB which
; is used to update a new group into an existing patient
; policy entry when applicable.
; RESULT(4) =-1^error message
; RESULT(4) =0 ^ message that process was successful or not required
;
;IB*687/ckb - added IBCNICB
N IBCNICB,IBSUPRES,IBUFSTAT,IBX
I '$D(IBELIG) S IBELIG=0
;Set IBSUPRES to suppress screen I/O within ACCEPT
S IBSUPRES=1,IBUFSTAT=$P($G(^IBA(355.33,$G(IBBUFDA),0)),U,4)
;IB*687/ckb - add set of IBCNICB. It will be used to set the ICB PROCESSED BUFFER field #1.08, in the
; INTERFACILITY UPDATE file #365.19. IBCNBAR will use IBCNICB when it calls LOC^IBCNIUF.
S IBCNICB=1
;
S RESULT(0)="-1^INSURANCE BUFFER (#355.33) IEN required" Q:'$G(IBBUFDA)
S RESULT(0)="-1^INSURANCE BUFFER ENTRY PREVIOUSLY PROCESSED"
Q:"~A~R~"[("~"_IBUFSTAT_"~")
S RESULT(0)="-1^INSURANCE BUFFER ENTRY STATUS SHOULD BE ENTERED"
Q:IBUFSTAT'="E"
S RESULT(0)="-1^PATIENT (#2) IEN required" Q:'$G(DFN)
S IBINSDA=$G(IBINSDA),IBGRPDA=$G(IBGRPDA),IBPOLDA=$G(IBPOLDA)
S IBMVINS=$G(IBMVINS,2),IBMVGRP=$G(IBMVGRP,2),IBMVPOL=$G(IBMVPOL,2)
S IBNEWINS=$G(IBNEWINS),IBNEWGRP=$G(IBNEWGRP),IBNEWPOL=$G(IBNEWPOL)
;
S RESULT(0)="-1^Passed INSURANCE COMPANY (#36) entry doesn't exist"
I +IBINSDA,$G(^DIC(36,IBINSDA,0))="" Q
S RESULT(0)="-1^Passed GROUP INSURANCE PLAN (#355.3) entry doesn't exist"
I +IBGRPDA,$G(^IBA(355.3,IBGRPDA,0))="" Q
; \Beginning IB*2*549 - added the following lines.
S RESULT(0)="-1^Unable to add new INSURANCE COMPANY (#36) - See your supervisor"
I +IBNEWINS,'$D(^XUSEC("IB INSURANCE COMPANY EDIT",DUZ)) Q
S RESULT(0)="-1^Unable to add new GROUP INSURANCE PLAN (#355.3) - See your supervisor"
I +IBNEWGRP,'$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) Q
S RESULT(0)="-1^Unable to add new GROUP INSURANCE PLAN (#355.3) - Duplicate Group Plan"
;
; If new insurance company cont. processing
I '(+IBNEWINS),+IBNEWGRP,$$EXACTM^IBCNICB2(IBINSDA,IBBUFDA) Q
; \End of IB*2*549
S RESULT(0)="-1^Passed Patient INSURANCE TYPE (#2.312) entry doesn't exist"
I +IBPOLDA,$G(^DPT(DFN,.312,IBPOLDA,0))="" Q
S RESULT(0)="-1^Passed GROUP INSURANCE PLAN (#355.3) entry points to different INSURANCE COMPANY (#36) entry"
I +IBGRPDA,+IBINSDA,+$G(^IBA(355.3,IBGRPDA,0))'=IBINSDA Q
S RESULT(0)="-1^Individual Policy Patient required to be Patient DFN when Group Insurance Plan is not Group Policy"
I +IBGRPDA S IBX=$G(^IBA(355.3,IBGRPDA,0)) I $P(IBX,U,2)=0,+$P(IBX,U,10),$P(IBX,U,10)'=DFN Q
;
;If existing GROUP INSURANCE PLAN (#355.3) entry is being changed from
;a group plan to individual plan with other subscribers, send error
;message and abort update
S RESULT(0)="-1^Can't change GROUP INSURANCE PLAN from Group Plan to Individual Plan when there are subscribers"
I +IBGRPDA,$P(IBX,U,2)=1,$P($G(^IBA(355.33,+$G(IBBUFDA),40)),U,1)'=1,$$SUBS^IBCNSJ(IBINSDA,IBGRPDA)>1 Q
;
N IBBUFABORT S IBBUFABORT=0 ;IB*737/CKB
D PROCESS^IBCNBAR
I IBBUFABORT=1 S RESULT(0)="-1^Unable to process entry, if accepted it would corrupt the Effective Date of the policy" ;IB*737/CKB
Q
;
REJECAPI(RESULT,IBBUFDA,IVMREPTR) ;
;Provides API to be called by the Insurance Capture Buffer (ICB)
;application to reject buffer entry.
;The REJPROC^IBCNBAR call and embedded Sub calls are updated to
;provide data in the RESULT parameter and suppress I/O when function
;is called by ICB.
;Input:
; IBBUFDA - INSURANCE BUFFER (#355.33) file internal entry number
; (required)
; IVMREPTR - IVM REASONS FOR NOT UPLOADING (#301.91) File internal
; internal entry number (Optional)
;Output:
; RESULT - Returned parameter variable with errors messages if
; problems with the reject processing. Format:
; REJECT = -1 ^ error message
; REJECT = 0 - Reject worked
; REJECT = 0 ^ warning message - Reject process worked but there
; is a warning message
;
N IBSUPRES
;Set IBSUPRES to suppress screen I/O within REJECT
S IBSUPRES=1
S RESULT="-1^INSURANCE BUFFER IEN required" Q:'$G(IBBUFDA)
S RESULT="-1^INSURANCE BUFFER ENTRY PREVIOUSLY PROCESSED"
Q:"~A~R~"[("~"_$$GET1^DIQ(355.33,IBBUFDA,.04,"I")_"~")
D REJPROC^IBCNBAR
Q
;
UPDTICB(RESULT,DFN,IBPOLDA,IBGRPDA,IBPOLCOM,IBPOLBIL,IBPLAN,IBELEC,IBGPCOM,IBFTF,IBFTFVAL) ;
;Updates additional fields for ICB Interface
;
;Input:
; DFN - PATIENT (#2) file IEN (Required)
; IBGRPDA - GROUP INSURANCE PLAN (#355.3) File IEN (Optional)
; IBPOLDA - INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN
; (Optional)
; IBPOLCOM - Data to be filed into the COMMENT - SUBSCRIBER POLICY
; MULTIPLE (2.312, 1.18) optional
; IBPOLBIL - Data to be filed into the STOP POLICY FROM BILLING (#3.04)
; field of the 2.312 sub-file. (Optional)
; Corresponds to the Internal codes in 3.04 field of
; 2.312 sub-file: '0' FOR NO; '1' FOR YES;
; IBPLAN - Data to be filed in PLAN FILING TIME FRAME (#.13) field
; of 355.3 file (Optional)
; IBELEC - Data to be file in ELECTRONIC PLAN TYPE (#.15) field
; of 355.3 file (Optional)
; Corresponds to the Internal Codes in .15 field of 355.3 file
; IBGPCOM - Group Plan Comment array that contains the word
; processing data to be filed the COMMENTS (#11) word-
; processing field of 355.3 file. (Optional)
; Example: IBGPCOM(1)="This is line 1"
; IBGPCOM(2)="This is line 2"
; IBFTF - Data to be filed in the PLAN STANDARD FTF (#.16) field of
; 355.3 file (Optional)
; Corresponds to the Internal Entry Number of the entry in
; the INSURANCE FILING TIME FRAME (#355.13) File.
; IBFTFVAL - Data to be filed in the PLAN STANDARD FTF VALUE (#.17)
; field of 355.3 file (Optional - Calling application
; responsible to pass value if required for Plan Standard FTF)
;
;Output:
; RESULT - Returned Parameter Array with results of call
; RESULT = 0 ^ No data to update
; RESULT(1) = -1^ error with Insurance Type (#2.312) file update
; RESULT(1) = 0 - Insurance Type update worked
; RESULT(2) = -1^ error with GROUP INSURANCE PLAN (#355.3) file update
; RESULT(2) = 0 - Group Insurance Plan update worked
;
; Update Patient Policy Comment (#1.08) and/or
; Stop Policy From Billing (#3.04) fields in 2.312 subfile
I $G(IBPOLCOM)]""!($G(IBPOLBIL)]"") D
. N IBIENS,IBFDA
. I $G(DFN)']"" S RESULT(1)="-1^PATIENT (#2) DFN not passed" Q
. I $G(IBPOLDA)'>0 S RESULT(1)="-1^INSURANCE TYPE (#2.312) sub-file IEN not defined" Q
. I +IBPOLDA,$G(^DPT(DFN,.312,IBPOLDA,0))="" S RESULT(0)="-1^Passed Patient INSURANCE TYPE (#2.312) entry doesn't exist" Q
. L +^DPT(DFN,.312,IBPOLDA):5 I '$T S RESULT(1)="-1^INSURANCE TYPE (#2.312) sub-file entry locked, data not updated" Q
. S IBIENS=+IBPOLDA_","_+DFN_","
. ; IB*2.0*549 Change IS THIS POLICY BILLABLE to STOP POLICY FROM BILLING
. I $G(IBPOLBIL)]"",$$EXTERNAL^DILFD(2.312,3.04,"",IBPOLBIL)']"" S RESULT(1)="-1^STOP POLICY FROM BILLING ("_IBPOLBIL_") not a valid value",IBPOLBIL=""
. S:$G(IBPOLBIL)]"" IBFDA(2.312,IBIENS,3.04)=IBPOLBIL
. I $D(IBFDA)>0 D FILE^DIE(,"IBFDA") S:$D(RESULT(1))'>0 RESULT(1)=0
. D PPCOMM(DFN,IBPOLDA,IBPOLCOM,.RESULT)
. L -^DPT(DFN,.312,IBPOLDA)
;
; Update Plan Filing Time Frame (#.13), Electronic Plan Type (#.15)
; Plan Standard FTF (#.16), Plan Standard FTF Value (#.17), and/or
; Group Plan Comments (#11) fields in 355.3 file
I $G(IBPLAN)]""!($G(IBELEC)]"")!($D(IBGPCOM)>0)!($G(IBFTF)]"")!($G(IBFTFVAL)]"") D
. N IBIENS,IBFDA
. I $G(IBGRPDA)'>0 S RESULT(2)="-1^GROUP INSURANCE PLAN (#355.3) file IEN not defined" Q
. I +IBGRPDA,$G(^IBA(355.3,IBGRPDA,0))="" S RESULT(2)="-1^Passed GROUP INSURANCE PLAN (#355.3) entry doesn't exist" Q
. L +^IBA(355.3,IBGRPDA):5 I '$T S RESULT(2)="-1^GROUP INSURANCE PLAN (#355.3) file entry locked, data not updated" Q
. S IBIENS=+IBGRPDA_","
. ; Consistency Checks for Plan Standard FTF and FTF VALUE fields
. I $G(IBELEC)]"",$$EXTERNAL^DILFD(355.3,.15,"",IBELEC)']"" S RESULT(2)="-1^ELECTRONIC PLAN TYPE ("_IBELEC_") not a valid value",IBELEC=""
. I $G(IBFTFVAL)]"",$G(IBFTF)']"" S RESULT(2)="-1^PLAN STANDARD FTF should be passed with PLAN STANDARD FTF VALUE",IBFTFVAL=""
. I $G(IBFTF)]"",$$EXTERNAL^DILFD(355.3,.16,"",IBFTF)']"" S RESULT(2)="-1^PLAN STANDARD FTF ("_IBFTF_") not a valid value",IBFTF=""
. I $G(IBFTF)]"",$$GET1^DIQ(355.13,+IBFTF_",",.02,"I")=1,$G(IBFTFVAL)'>0 S RESULT(2)="-1^Valid PLAN STANDARD FTF VALUE not passed for "_$$GET1^DIQ(355.13,+IBFTF,.01,"E"),IBFTF="",IBFTFVAL=""
. ;
. S:$G(IBPLAN)]"" IBFDA(355.3,IBIENS,.13)=IBPLAN
. S:$G(IBELEC)]"" IBFDA(355.3,IBIENS,.15)=IBELEC
. S:$G(IBFTF)]"" IBFDA(355.3,IBIENS,.16)=IBFTF
. S:$G(IBFTFVAL)]"" IBFDA(355.3,IBIENS,.17)=IBFTFVAL
. I $D(IBFDA)>0 D FILE^DIE(,"IBFDA") S:$D(RESULT(2))'>0 RESULT(2)=0
. ;
. ; Update Group Plan Comments (#11) word processing field in 355.3 file
. I $O(IBGPCOM(""))>0 D WP^DIE(355.3,+IBGRPDA_",",11,,"IBGPCOM") S:$D(RESULT(2))'>0 RESULT(2)=0
. L -^IBA(355.3,IBGRPDA)
I $D(RESULT(1))'>0&($D(RESULT(2))'>0) S RESULT="0^No data to update"
Q
;
PPCOMM(DFN,IBPOLDA,IBPOLCOM,RESULT) ; ib*2*528 record patient policy comments
; Input:
; DFN = patient IEN
; IBPOLDA = ien of selected INSURANCE POLICY at ^DPT("_DFN_",.312,
; IBPOLCOM = patient policy COMMENT data
;
; Output:
; RESULT = Returned Parameter Array with results of call
;
N IBDT,IBVCOM
S IBVCOM=""
;
; -- get the last comment made for the policy within VistA
S IBDT=$O(^DPT(DFN,.312,IBPOLDA,13,"B",""),-1)
I IBDT]"" S IBCDA=$O(^DPT(DFN,.312,IBPOLDA,13,"B",IBDT,""),-1) S IBVCOM=$G(^DPT(DFN,.312,IBPOLDA,13,IBCDA,1))
;
; -- no VistA comments for patient policy so go add the new ICB comment
I IBVCOM="",IBPOLCOM]"" D ADCOM(DFN,IBPOLDA,IBPOLCOM,.RESULT) Q
;
; -- the last comment within VistA is the same comment as the new ICB comment
I IBVCOM=IBPOLCOM Q
;
; -- VistA comment is different from ICB comment so add the ICB comment
D ADCOM(DFN,IBPOLDA,IBPOLCOM,.RESULT)
Q
;
ADCOM(DFN,IBPOLDA,IBPOLCOM,RESULT) ; add new entry to the COMMENT - SUBSCRIBER POLICY multiple
; Input:
; DFN = patient IEN
; IBPOLDA = ien of INSURANCE POLICY at ^DPT("_DFN_",.312,
; IBPOLCOM = patient policy COMMENT data
; DUZ = user IEN - system wide variable
;
; Output:
; RESULT = Returned Parameter Array with results of call
;
; -- lock the COMMENT - SUBSCRIBER POLICY multiple so that previous comments can't be edited
L +^DPT(DFN,.312,IBPOLDA,13):5 I '$T S RESULT(1)="-1^INSURANCE TYPE (#2.312,1.18) sub-file entry locked, data not updated" Q
;
N FDA,IENS,DIERR
;
; -- populate the FDA array with data
S IENS="+1,"_IBPOLDA_","_DFN_","
S FDA(2.342,IENS,.01)=$$NOW^XLFDT()
S FDA(2.342,IENS,.02)=DUZ
S FDA(2.342,IENS,.03)=IBPOLCOM
;
; -- update comment
D UPDATE^DIE(,"FDA",,"DIERR")
;
; -- check for error
I $D(DIERR) S RESULT(1)="-1^INSURANCE TYPE (#2.312,1.18) error adding comment to INSURANCE TYPE (#2.312,1.18)"
E S RESULT(1)=0
;
; -- unlock comment multiple
L -^DPT(DFN,.312,IBPOLDA,13)
Q
;
EDCOM(IBPOLDA,IBPOLCOM,IBDT) ; edit the existing entry at 2.312,1.18 multiple
; input - IBPOLDA = ien of INSURANCE POLICY at ^DPT("_DFN_",.312,
; IBDT = date/time that comment was made
N DA,DIE,DR,IBNM
; retrieve the latest comment made by the user
S DA=$O(^DPT(DFN,.312,IBPOLDA,13,"BB",DUZ,IBDT,""),-1)
S DIE="^DPT("_DFN_",.312,"_IBPOLDA_",13,"
S DA(2)=DFN,DA(1)=IBPOLDA
; retrieve the latest comment made by the user
S IBNM=$$GET1^DIQ(200,DUZ_",",.01,"E")
I $G(^DPT(DFN,.312,IBPOLDA,13,DA,1))]"" S DR=".01///"_$$NOW^XLFDT()_";.02///"_IBNM_";.03///"_IBPOLCOM
E S DR=".01///@;.02///@"
D ^DIE
Q
;
UPDPOL(RESULT,IBBUFDA,DFN,IBINSDA,IBGRPDA,IBPOLDA) ;update a new group into
;an existing patient policy entry for ICB interface
;Input
; IBBUFDA - INSURANCE BUFFER (#355.33) file internal entry number (IEN) (Required)
; DFN - PATIENT (#2) file IEN (Required)
; IBINSDA - INSURANCE COMPANY (#36) File IEN if not adding new entry (Optional)
; IBGRPDA - GROUP INSURANCE PLAN (#355.3) File IEN if not adding new entry (Required)
; IBPOLDA - INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN if
; not adding new entry (Required)
;Output:
; RESULT(4) - Returned Parameter Array with results of call
; RESULT(4) =-1^error message
; RESULT(4) =0 ^ message that process was successful or not require
;
N IBPAT
I $G(IBBUFDA)'>0 S RESULT(4)="-1^INSURANCE BUFFER (#355.33) IEN required" Q
I $G(DFN)'>0 S RESULT(4)="-1^PATIENT (#2) IEN required" Q
I $G(IBPOLDA)'>0 S RESULT(4)="-1^INSURANCE TYPE (#2.312) SUB-FILE IEN required" Q
I $G(^DPT(DFN,.312,IBPOLDA,0))'>0 S RESULT(4)="-1^PATIENT INSURANCE TYPE(#2.312) entry doesn't exist" Q
I $G(IBGRPDA)'>0 S RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) IEN required" Q
;
; NO changes required
S IBPAT=$G(^DPT(DFN,.312,IBPOLDA,0))
I $G(IBINSDA)>0,$P(IBPAT,U,1)=IBINSDA,$P(IBPAT,U,18)=IBGRPDA S RESULT(4)="0^NO CHANGE REQUIRE" Q
I $G(IBINSDA)'>0,$P(IBPAT,U,18)=IBGRPDA S RESULT(4)="0^NO CHANGE REQUIRE" Q
;
;Additional error checks
I $G(^IBA(355.3,IBGRPDA,0))="" S RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) entry doesn't exist" Q
I $G(IBINSDA)>0,$G(^DIC(36,IBINSDA,0))="" S RESULT(4)="-1^INSURANCE COMPANY (#36) entry doesn't exist" Q
I $G(IBINSDA)>0,$P($G(^IBA(355.3,IBGRPDA,0)),U,1)'=IBINSDA S RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) entry points to different INSURANCE COMPANY (#36) entry" Q
I $G(IBINSDA)'>0,$P($G(^IBA(355.3,IBGRPDA,0)),U,1)'=$P(IBPAT,U,1) S RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) entry points to different INSURANCE COMPANY (#36) entry" Q
;
D CLEANUP
;
L +^DPT(DFN,.312,IBPOLDA):5 I '$T S RESULT(4)="-1^INSURANCE TYPE (#2.312) SUB-FILE ENTRY LOCKED, DATA NOT UPDATED" Q
;
N IBXIFN,IBFIELDS,IBERR
S IBXIFN=IBPOLDA_","_DFN_","
I $G(IBINSDA) S IBFIELDS(2.312,IBXIFN,.01)=IBINSDA
S IBFIELDS(2.312,IBXIFN,.18)=IBGRPDA ;policy's group/plan always update
Q:'$D(IBFIELDS)
;Source
S IBFIELDS(2.312,IBXIFN,1.09)=$P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,3)
;Source Date
S IBFIELDS(2.312,IBXIFN,1.1)=+$G(^IBA(355.33,+$G(IBBUFDA),0))
D FILE^DIE("","IBFIELDS","IBERR")
I $D(IBERR)>0 S RESULT(4)="-1^Fileman DIE error"
I $D(IBERR)'>0 S RESULT(4)="0^Data successfully updated"
L -^DPT(DFN,.312,IBPOLDA)
Q
;
CLEANUP ;This logic will delete obsolete Individual Plans, Repoint Insurance
;Reviews if Insurance Company changes, and Remove any Old Benefits Used.
N IBPAT,IBOLDINS,IBOLDGRP,IBIP,IBT,IBTNODE0,IBTNODE1,IBFIELDS,IBARR
S IBPAT=$G(^DPT(DFN,.312,IBPOLDA,0))
S IBOLDINS=$P(IBPAT,U,1),IBOLDGRP=$P(IBPAT,U,18)
S IBIP=$P($G(^IBA(355.3,+$P(IBPAT,U,18),0)),U,2)
;If Old Group Insurance Plan is an Individual Plan with only one
;subscriber for the same Patient Insurance Policy Entry, delete it
I IBIP=0,$$SUBS^IBCNSJ(IBOLDINS,IBOLDGRP,,"IBARR")'>1,($D(IBARR(DFN,IBPOLDA))>0) D DEL^IBCNSJ(IBOLDGRP)
;If changing to a new Insurance Company
I $G(IBINSDA)>0,IBOLDINS'=IBINSDA D Q
. ; - repoint all Insurance Reviews to new company
. I $$IR^IBCNSJ21(DFN,IBPOLDA) D
. S IBT=0
. F S IBT=$O(^IBT(356.2,"D",DFN,IBT)) Q:'IBT D
. . S IBTNODE0=$G(^IBT(356.2,IBT,0)),IBTNODE1=$G(^IBT(356.2,IBT,1))
. . I $P(IBTNODE1,U,5)=IBPOLDA,$P(IBTNODE0,U,8)'=IBINSDA D
. . . S IBFIELDS(356.2,IBT_",",.08)=IBINSDA
. . . D FILE^DIE("","IBFIELDS")
;Delete Benefits Used (#355.5) corresponding to old Patient Group Plan
D DELBU
Q
;
DELBU ;Delete Benefits Used
N IBCDFN,IBPLAN,IBBU
S IBCDFN=IBPOLDA,IBPLAN=IBOLDGRP
;Get Benefits Used
D BU^IBCNSJ21
;If there are Benefits Used, then delete them
I $O(IBBU(0)) D
. N IBDAT
. S IBDAT=""
. F S IBDAT=$O(IBBU(IBDAT)) Q:IBDAT="" D DBU^IBCNSJ(IBBU(IBDAT))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNICB 18954 printed Dec 13, 2024@02:15:51 Page 2
IBCNICB ;ALB/SBW - Update utilities for the ICB interface ;1 SEP 2009
+1 ;;2.0;INTEGRATED BILLING;**413,416,528,549,687,737**;21-MAR-94;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
ACCEPAPI(RESULT,IBBUFDA,DFN,IBINSDA,IBGRPDA,IBPOLDA,IBMVINS,IBMVGRP,IBMVPOL,IBNEWINS,IBNEWGRP,IBNEWPOL,IVMREPTR,IBELIG) ;
+1 ;Provides API to be called by the Insurance Capture Buffer (ICB)
+2 ;application to move buffer data in Insurance Files then cleanup
+3 ;
+4 ;The call to PROCESS^IBCNBAR and embedded Sub calls are updated to
+5 ;provide data in the RESULT parameter and suppress user I/O when
+6 ;function is called by ICB.
+7 ;Input
+8 ; IBBUFDA - INSURANCE BUFFER (#355.33) file internal entry number (IEN) (Required)
+9 ; DFN - PATIENT (#2) file IEN (Required)
+10 ; IBINSDA - INSURANCE COMPANY (#36) File IEN if not adding new entry (Optional)
+11 ; IBGRPDA - GROUP INSURANCE PLAN (#355.3) File IEN if not adding new entry (Optional)
+12 ; IBPOLDA - INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN if
+13 ; not adding new entry (Optional)
+14 ; IBMVINS - Type for INSURANCE (Required)
+15 ; 1=Merge, 2=Overwrite, 3=Replace, 4=Unsupported
+16 ; IBMVGRP - Type for GROUP (Optional)
+17 ; 1=Merge, 2=Overwrite, 3=Replace, 4=Unsupported
+18 ; IBMVPOL - Type for POLICY (Optional)
+19 ; 1=Merge, 2=Overwrite, 3=Replace, 4=Unsupported
+20 ; IBNEWINS - Add new INSURANCE COMPANY flag (non-zero means add)
+21 ; IBNEWGRP - Add new GROUP INSURANCE PLAN flag (non-zero means add)
+22 ; IBNEWPOL - Add new patient insurance policy (non-zero means add)
+23 ; IVMREPTR - IVM REASONS FOR NOT UPLOADING (#301.91) IEN (Optional)
+24 ;
+25 ;OUTPUT
+26 ; RESULT - Returned Parameter Array with IENS of new entries and/or errors/warning.
+27 ; RESULT(0) = -1^error message
+28 ; RESULT(0) = 0 -Move worked
+29 ; RESULT(0) = 0 ^ warning message ^ warning message ^
+30 ; warning message ^ warning message
+31 ; - Move worked but there may be zero to 4 warning messages
+32 ; RESULT(1) = "IBINSDA^" IEN of new Insurance Company (#36) File
+33 ; RESULT(1,"ERR",#) - Array with any FM errors when data updated
+34 ; from file 355.33 to 36.
+35 ; RESULT(2) = "IBGRPDA^" IEN of new GROUP INSURANCE PLAN (#355.3) File
+36 ; RESULT(2,"ERR",#) - Array with any FM errors when data updated
+37 ; from file 355.33 to 355.3.
+38 ; RESULT(3) = "IBPOLDA^" IEN of new INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN
+39 ; RESULT(3,"ERR",#) - Array with any FM errors when data updated
+40 ; from file 355.33 to 2.312.
+41 ; RESULT(4) Contains the results of the call to UPDPOL^IBCNICB which
+42 ; is used to update a new group into an existing patient
+43 ; policy entry when applicable.
+44 ; RESULT(4) =-1^error message
+45 ; RESULT(4) =0 ^ message that process was successful or not required
+46 ;
+47 ;IB*687/ckb - added IBCNICB
+48 NEW IBCNICB,IBSUPRES,IBUFSTAT,IBX
+49 IF '$DATA(IBELIG)
SET IBELIG=0
+50 ;Set IBSUPRES to suppress screen I/O within ACCEPT
+51 SET IBSUPRES=1
SET IBUFSTAT=$PIECE($GET(^IBA(355.33,$GET(IBBUFDA),0)),U,4)
+52 ;IB*687/ckb - add set of IBCNICB. It will be used to set the ICB PROCESSED BUFFER field #1.08, in the
+53 ; INTERFACILITY UPDATE file #365.19. IBCNBAR will use IBCNICB when it calls LOC^IBCNIUF.
+54 SET IBCNICB=1
+55 ;
+56 SET RESULT(0)="-1^INSURANCE BUFFER (#355.33) IEN required"
if '$GET(IBBUFDA)
QUIT
+57 SET RESULT(0)="-1^INSURANCE BUFFER ENTRY PREVIOUSLY PROCESSED"
+58 if "~A~R~"[("~"_IBUFSTAT_"~")
QUIT
+59 SET RESULT(0)="-1^INSURANCE BUFFER ENTRY STATUS SHOULD BE ENTERED"
+60 if IBUFSTAT'="E"
QUIT
+61 SET RESULT(0)="-1^PATIENT (#2) IEN required"
if '$GET(DFN)
QUIT
+62 SET IBINSDA=$GET(IBINSDA)
SET IBGRPDA=$GET(IBGRPDA)
SET IBPOLDA=$GET(IBPOLDA)
+63 SET IBMVINS=$GET(IBMVINS,2)
SET IBMVGRP=$GET(IBMVGRP,2)
SET IBMVPOL=$GET(IBMVPOL,2)
+64 SET IBNEWINS=$GET(IBNEWINS)
SET IBNEWGRP=$GET(IBNEWGRP)
SET IBNEWPOL=$GET(IBNEWPOL)
+65 ;
+66 SET RESULT(0)="-1^Passed INSURANCE COMPANY (#36) entry doesn't exist"
+67 IF +IBINSDA
IF $GET(^DIC(36,IBINSDA,0))=""
QUIT
+68 SET RESULT(0)="-1^Passed GROUP INSURANCE PLAN (#355.3) entry doesn't exist"
+69 IF +IBGRPDA
IF $GET(^IBA(355.3,IBGRPDA,0))=""
QUIT
+70 ; \Beginning IB*2*549 - added the following lines.
+71 SET RESULT(0)="-1^Unable to add new INSURANCE COMPANY (#36) - See your supervisor"
+72 IF +IBNEWINS
IF '$DATA(^XUSEC("IB INSURANCE COMPANY EDIT",DUZ))
QUIT
+73 SET RESULT(0)="-1^Unable to add new GROUP INSURANCE PLAN (#355.3) - See your supervisor"
+74 IF +IBNEWGRP
IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
QUIT
+75 SET RESULT(0)="-1^Unable to add new GROUP INSURANCE PLAN (#355.3) - Duplicate Group Plan"
+76 ;
+77 ; If new insurance company cont. processing
+78 IF '(+IBNEWINS)
IF +IBNEWGRP
IF $$EXACTM^IBCNICB2(IBINSDA,IBBUFDA)
QUIT
+79 ; \End of IB*2*549
+80 SET RESULT(0)="-1^Passed Patient INSURANCE TYPE (#2.312) entry doesn't exist"
+81 IF +IBPOLDA
IF $GET(^DPT(DFN,.312,IBPOLDA,0))=""
QUIT
+82 SET RESULT(0)="-1^Passed GROUP INSURANCE PLAN (#355.3) entry points to different INSURANCE COMPANY (#36) entry"
+83 IF +IBGRPDA
IF +IBINSDA
IF +$GET(^IBA(355.3,IBGRPDA,0))'=IBINSDA
QUIT
+84 SET RESULT(0)="-1^Individual Policy Patient required to be Patient DFN when Group Insurance Plan is not Group Policy"
+85 IF +IBGRPDA
SET IBX=$GET(^IBA(355.3,IBGRPDA,0))
IF $PIECE(IBX,U,2)=0
IF +$PIECE(IBX,U,10)
IF $PIECE(IBX,U,10)'=DFN
QUIT
+86 ;
+87 ;If existing GROUP INSURANCE PLAN (#355.3) entry is being changed from
+88 ;a group plan to individual plan with other subscribers, send error
+89 ;message and abort update
+90 SET RESULT(0)="-1^Can't change GROUP INSURANCE PLAN from Group Plan to Individual Plan when there are subscribers"
+91 IF +IBGRPDA
IF $PIECE(IBX,U,2)=1
IF $PIECE($GET(^IBA(355.33,+$GET(IBBUFDA),40)),U,1)'=1
IF $$SUBS^IBCNSJ(IBINSDA,IBGRPDA)>1
QUIT
+92 ;
+93 ;IB*737/CKB
NEW IBBUFABORT
SET IBBUFABORT=0
+94 DO PROCESS^IBCNBAR
+95 ;IB*737/CKB
IF IBBUFABORT=1
SET RESULT(0)="-1^Unable to process entry, if accepted it would corrupt the Effective Date of the policy"
+96 QUIT
+97 ;
REJECAPI(RESULT,IBBUFDA,IVMREPTR) ;
+1 ;Provides API to be called by the Insurance Capture Buffer (ICB)
+2 ;application to reject buffer entry.
+3 ;The REJPROC^IBCNBAR call and embedded Sub calls are updated to
+4 ;provide data in the RESULT parameter and suppress I/O when function
+5 ;is called by ICB.
+6 ;Input:
+7 ; IBBUFDA - INSURANCE BUFFER (#355.33) file internal entry number
+8 ; (required)
+9 ; IVMREPTR - IVM REASONS FOR NOT UPLOADING (#301.91) File internal
+10 ; internal entry number (Optional)
+11 ;Output:
+12 ; RESULT - Returned parameter variable with errors messages if
+13 ; problems with the reject processing. Format:
+14 ; REJECT = -1 ^ error message
+15 ; REJECT = 0 - Reject worked
+16 ; REJECT = 0 ^ warning message - Reject process worked but there
+17 ; is a warning message
+18 ;
+19 NEW IBSUPRES
+20 ;Set IBSUPRES to suppress screen I/O within REJECT
+21 SET IBSUPRES=1
+22 SET RESULT="-1^INSURANCE BUFFER IEN required"
if '$GET(IBBUFDA)
QUIT
+23 SET RESULT="-1^INSURANCE BUFFER ENTRY PREVIOUSLY PROCESSED"
+24 if "~A~R~"[("~"_$$GET1^DIQ(355.33,IBBUFDA,.04,"I")_"~")
QUIT
+25 DO REJPROC^IBCNBAR
+26 QUIT
+27 ;
UPDTICB(RESULT,DFN,IBPOLDA,IBGRPDA,IBPOLCOM,IBPOLBIL,IBPLAN,IBELEC,IBGPCOM,IBFTF,IBFTFVAL) ;
+1 ;Updates additional fields for ICB Interface
+2 ;
+3 ;Input:
+4 ; DFN - PATIENT (#2) file IEN (Required)
+5 ; IBGRPDA - GROUP INSURANCE PLAN (#355.3) File IEN (Optional)
+6 ; IBPOLDA - INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN
+7 ; (Optional)
+8 ; IBPOLCOM - Data to be filed into the COMMENT - SUBSCRIBER POLICY
+9 ; MULTIPLE (2.312, 1.18) optional
+10 ; IBPOLBIL - Data to be filed into the STOP POLICY FROM BILLING (#3.04)
+11 ; field of the 2.312 sub-file. (Optional)
+12 ; Corresponds to the Internal codes in 3.04 field of
+13 ; 2.312 sub-file: '0' FOR NO; '1' FOR YES;
+14 ; IBPLAN - Data to be filed in PLAN FILING TIME FRAME (#.13) field
+15 ; of 355.3 file (Optional)
+16 ; IBELEC - Data to be file in ELECTRONIC PLAN TYPE (#.15) field
+17 ; of 355.3 file (Optional)
+18 ; Corresponds to the Internal Codes in .15 field of 355.3 file
+19 ; IBGPCOM - Group Plan Comment array that contains the word
+20 ; processing data to be filed the COMMENTS (#11) word-
+21 ; processing field of 355.3 file. (Optional)
+22 ; Example: IBGPCOM(1)="This is line 1"
+23 ; IBGPCOM(2)="This is line 2"
+24 ; IBFTF - Data to be filed in the PLAN STANDARD FTF (#.16) field of
+25 ; 355.3 file (Optional)
+26 ; Corresponds to the Internal Entry Number of the entry in
+27 ; the INSURANCE FILING TIME FRAME (#355.13) File.
+28 ; IBFTFVAL - Data to be filed in the PLAN STANDARD FTF VALUE (#.17)
+29 ; field of 355.3 file (Optional - Calling application
+30 ; responsible to pass value if required for Plan Standard FTF)
+31 ;
+32 ;Output:
+33 ; RESULT - Returned Parameter Array with results of call
+34 ; RESULT = 0 ^ No data to update
+35 ; RESULT(1) = -1^ error with Insurance Type (#2.312) file update
+36 ; RESULT(1) = 0 - Insurance Type update worked
+37 ; RESULT(2) = -1^ error with GROUP INSURANCE PLAN (#355.3) file update
+38 ; RESULT(2) = 0 - Group Insurance Plan update worked
+39 ;
+40 ; Update Patient Policy Comment (#1.08) and/or
+41 ; Stop Policy From Billing (#3.04) fields in 2.312 subfile
+42 IF $GET(IBPOLCOM)]""!($GET(IBPOLBIL)]"")
Begin DoDot:1
+43 NEW IBIENS,IBFDA
+44 IF $GET(DFN)']""
SET RESULT(1)="-1^PATIENT (#2) DFN not passed"
QUIT
+45 IF $GET(IBPOLDA)'>0
SET RESULT(1)="-1^INSURANCE TYPE (#2.312) sub-file IEN not defined"
QUIT
+46 IF +IBPOLDA
IF $GET(^DPT(DFN,.312,IBPOLDA,0))=""
SET RESULT(0)="-1^Passed Patient INSURANCE TYPE (#2.312) entry doesn't exist"
QUIT
+47 LOCK +^DPT(DFN,.312,IBPOLDA):5
IF '$TEST
SET RESULT(1)="-1^INSURANCE TYPE (#2.312) sub-file entry locked, data not updated"
QUIT
+48 SET IBIENS=+IBPOLDA_","_+DFN_","
+49 ; IB*2.0*549 Change IS THIS POLICY BILLABLE to STOP POLICY FROM BILLING
+50 IF $GET(IBPOLBIL)]""
IF $$EXTERNAL^DILFD(2.312,3.04,"",IBPOLBIL)']""
SET RESULT(1)="-1^STOP POLICY FROM BILLING ("_IBPOLBIL_") not a valid value"
SET IBPOLBIL=""
+51 if $GET(IBPOLBIL)]""
SET IBFDA(2.312,IBIENS,3.04)=IBPOLBIL
+52 IF $DATA(IBFDA)>0
DO FILE^DIE(,"IBFDA")
if $DATA(RESULT(1))'>0
SET RESULT(1)=0
+53 DO PPCOMM(DFN,IBPOLDA,IBPOLCOM,.RESULT)
+54 LOCK -^DPT(DFN,.312,IBPOLDA)
End DoDot:1
+55 ;
+56 ; Update Plan Filing Time Frame (#.13), Electronic Plan Type (#.15)
+57 ; Plan Standard FTF (#.16), Plan Standard FTF Value (#.17), and/or
+58 ; Group Plan Comments (#11) fields in 355.3 file
+59 IF $GET(IBPLAN)]""!($GET(IBELEC)]"")!($DATA(IBGPCOM)>0)!($GET(IBFTF)]"")!($GET(IBFTFVAL)]"")
Begin DoDot:1
+60 NEW IBIENS,IBFDA
+61 IF $GET(IBGRPDA)'>0
SET RESULT(2)="-1^GROUP INSURANCE PLAN (#355.3) file IEN not defined"
QUIT
+62 IF +IBGRPDA
IF $GET(^IBA(355.3,IBGRPDA,0))=""
SET RESULT(2)="-1^Passed GROUP INSURANCE PLAN (#355.3) entry doesn't exist"
QUIT
+63 LOCK +^IBA(355.3,IBGRPDA):5
IF '$TEST
SET RESULT(2)="-1^GROUP INSURANCE PLAN (#355.3) file entry locked, data not updated"
QUIT
+64 SET IBIENS=+IBGRPDA_","
+65 ; Consistency Checks for Plan Standard FTF and FTF VALUE fields
+66 IF $GET(IBELEC)]""
IF $$EXTERNAL^DILFD(355.3,.15,"",IBELEC)']""
SET RESULT(2)="-1^ELECTRONIC PLAN TYPE ("_IBELEC_") not a valid value"
SET IBELEC=""
+67 IF $GET(IBFTFVAL)]""
IF $GET(IBFTF)']""
SET RESULT(2)="-1^PLAN STANDARD FTF should be passed with PLAN STANDARD FTF VALUE"
SET IBFTFVAL=""
+68 IF $GET(IBFTF)]""
IF $$EXTERNAL^DILFD(355.3,.16,"",IBFTF)']""
SET RESULT(2)="-1^PLAN STANDARD FTF ("_IBFTF_") not a valid value"
SET IBFTF=""
+69 IF $GET(IBFTF)]""
IF $$GET1^DIQ(355.13,+IBFTF_",",.02,"I")=1
IF $GET(IBFTFVAL)'>0
SET RESULT(2)="-1^Valid PLAN STANDARD FTF VALUE not passed for "_$$GET1^DIQ(355.13,+IBFTF,.01,"E")
SET IBFTF=""
SET IBFTFVAL=""
+70 ;
+71 if $GET(IBPLAN)]""
SET IBFDA(355.3,IBIENS,.13)=IBPLAN
+72 if $GET(IBELEC)]""
SET IBFDA(355.3,IBIENS,.15)=IBELEC
+73 if $GET(IBFTF)]""
SET IBFDA(355.3,IBIENS,.16)=IBFTF
+74 if $GET(IBFTFVAL)]""
SET IBFDA(355.3,IBIENS,.17)=IBFTFVAL
+75 IF $DATA(IBFDA)>0
DO FILE^DIE(,"IBFDA")
if $DATA(RESULT(2))'>0
SET RESULT(2)=0
+76 ;
+77 ; Update Group Plan Comments (#11) word processing field in 355.3 file
+78 IF $ORDER(IBGPCOM(""))>0
DO WP^DIE(355.3,+IBGRPDA_",",11,,"IBGPCOM")
if $DATA(RESULT(2))'>0
SET RESULT(2)=0
+79 LOCK -^IBA(355.3,IBGRPDA)
End DoDot:1
+80 IF $DATA(RESULT(1))'>0&($DATA(RESULT(2))'>0)
SET RESULT="0^No data to update"
+81 QUIT
+82 ;
PPCOMM(DFN,IBPOLDA,IBPOLCOM,RESULT) ; ib*2*528 record patient policy comments
+1 ; Input:
+2 ; DFN = patient IEN
+3 ; IBPOLDA = ien of selected INSURANCE POLICY at ^DPT("_DFN_",.312,
+4 ; IBPOLCOM = patient policy COMMENT data
+5 ;
+6 ; Output:
+7 ; RESULT = Returned Parameter Array with results of call
+8 ;
+9 NEW IBDT,IBVCOM
+10 SET IBVCOM=""
+11 ;
+12 ; -- get the last comment made for the policy within VistA
+13 SET IBDT=$ORDER(^DPT(DFN,.312,IBPOLDA,13,"B",""),-1)
+14 IF IBDT]""
SET IBCDA=$ORDER(^DPT(DFN,.312,IBPOLDA,13,"B",IBDT,""),-1)
SET IBVCOM=$GET(^DPT(DFN,.312,IBPOLDA,13,IBCDA,1))
+15 ;
+16 ; -- no VistA comments for patient policy so go add the new ICB comment
+17 IF IBVCOM=""
IF IBPOLCOM]""
DO ADCOM(DFN,IBPOLDA,IBPOLCOM,.RESULT)
QUIT
+18 ;
+19 ; -- the last comment within VistA is the same comment as the new ICB comment
+20 IF IBVCOM=IBPOLCOM
QUIT
+21 ;
+22 ; -- VistA comment is different from ICB comment so add the ICB comment
+23 DO ADCOM(DFN,IBPOLDA,IBPOLCOM,.RESULT)
+24 QUIT
+25 ;
ADCOM(DFN,IBPOLDA,IBPOLCOM,RESULT) ; add new entry to the COMMENT - SUBSCRIBER POLICY multiple
+1 ; Input:
+2 ; DFN = patient IEN
+3 ; IBPOLDA = ien of INSURANCE POLICY at ^DPT("_DFN_",.312,
+4 ; IBPOLCOM = patient policy COMMENT data
+5 ; DUZ = user IEN - system wide variable
+6 ;
+7 ; Output:
+8 ; RESULT = Returned Parameter Array with results of call
+9 ;
+10 ; -- lock the COMMENT - SUBSCRIBER POLICY multiple so that previous comments can't be edited
+11 LOCK +^DPT(DFN,.312,IBPOLDA,13):5
IF '$TEST
SET RESULT(1)="-1^INSURANCE TYPE (#2.312,1.18) sub-file entry locked, data not updated"
QUIT
+12 ;
+13 NEW FDA,IENS,DIERR
+14 ;
+15 ; -- populate the FDA array with data
+16 SET IENS="+1,"_IBPOLDA_","_DFN_","
+17 SET FDA(2.342,IENS,.01)=$$NOW^XLFDT()
+18 SET FDA(2.342,IENS,.02)=DUZ
+19 SET FDA(2.342,IENS,.03)=IBPOLCOM
+20 ;
+21 ; -- update comment
+22 DO UPDATE^DIE(,"FDA",,"DIERR")
+23 ;
+24 ; -- check for error
+25 IF $DATA(DIERR)
SET RESULT(1)="-1^INSURANCE TYPE (#2.312,1.18) error adding comment to INSURANCE TYPE (#2.312,1.18)"
+26 IF '$TEST
SET RESULT(1)=0
+27 ;
+28 ; -- unlock comment multiple
+29 LOCK -^DPT(DFN,.312,IBPOLDA,13)
+30 QUIT
+31 ;
EDCOM(IBPOLDA,IBPOLCOM,IBDT) ; edit the existing entry at 2.312,1.18 multiple
+1 ; input - IBPOLDA = ien of INSURANCE POLICY at ^DPT("_DFN_",.312,
+2 ; IBDT = date/time that comment was made
+3 NEW DA,DIE,DR,IBNM
+4 ; retrieve the latest comment made by the user
+5 SET DA=$ORDER(^DPT(DFN,.312,IBPOLDA,13,"BB",DUZ,IBDT,""),-1)
+6 SET DIE="^DPT("_DFN_",.312,"_IBPOLDA_",13,"
+7 SET DA(2)=DFN
SET DA(1)=IBPOLDA
+8 ; retrieve the latest comment made by the user
+9 SET IBNM=$$GET1^DIQ(200,DUZ_",",.01,"E")
+10 IF $GET(^DPT(DFN,.312,IBPOLDA,13,DA,1))]""
SET DR=".01///"_$$NOW^XLFDT()_";.02///"_IBNM_";.03///"_IBPOLCOM
+11 IF '$TEST
SET DR=".01///@;.02///@"
+12 DO ^DIE
+13 QUIT
+14 ;
UPDPOL(RESULT,IBBUFDA,DFN,IBINSDA,IBGRPDA,IBPOLDA) ;update a new group into
+1 ;an existing patient policy entry for ICB interface
+2 ;Input
+3 ; IBBUFDA - INSURANCE BUFFER (#355.33) file internal entry number (IEN) (Required)
+4 ; DFN - PATIENT (#2) file IEN (Required)
+5 ; IBINSDA - INSURANCE COMPANY (#36) File IEN if not adding new entry (Optional)
+6 ; IBGRPDA - GROUP INSURANCE PLAN (#355.3) File IEN if not adding new entry (Required)
+7 ; IBPOLDA - INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN if
+8 ; not adding new entry (Required)
+9 ;Output:
+10 ; RESULT(4) - Returned Parameter Array with results of call
+11 ; RESULT(4) =-1^error message
+12 ; RESULT(4) =0 ^ message that process was successful or not require
+13 ;
+14 NEW IBPAT
+15 IF $GET(IBBUFDA)'>0
SET RESULT(4)="-1^INSURANCE BUFFER (#355.33) IEN required"
QUIT
+16 IF $GET(DFN)'>0
SET RESULT(4)="-1^PATIENT (#2) IEN required"
QUIT
+17 IF $GET(IBPOLDA)'>0
SET RESULT(4)="-1^INSURANCE TYPE (#2.312) SUB-FILE IEN required"
QUIT
+18 IF $GET(^DPT(DFN,.312,IBPOLDA,0))'>0
SET RESULT(4)="-1^PATIENT INSURANCE TYPE(#2.312) entry doesn't exist"
QUIT
+19 IF $GET(IBGRPDA)'>0
SET RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) IEN required"
QUIT
+20 ;
+21 ; NO changes required
+22 SET IBPAT=$GET(^DPT(DFN,.312,IBPOLDA,0))
+23 IF $GET(IBINSDA)>0
IF $PIECE(IBPAT,U,1)=IBINSDA
IF $PIECE(IBPAT,U,18)=IBGRPDA
SET RESULT(4)="0^NO CHANGE REQUIRE"
QUIT
+24 IF $GET(IBINSDA)'>0
IF $PIECE(IBPAT,U,18)=IBGRPDA
SET RESULT(4)="0^NO CHANGE REQUIRE"
QUIT
+25 ;
+26 ;Additional error checks
+27 IF $GET(^IBA(355.3,IBGRPDA,0))=""
SET RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) entry doesn't exist"
QUIT
+28 IF $GET(IBINSDA)>0
IF $GET(^DIC(36,IBINSDA,0))=""
SET RESULT(4)="-1^INSURANCE COMPANY (#36) entry doesn't exist"
QUIT
+29 IF $GET(IBINSDA)>0
IF $PIECE($GET(^IBA(355.3,IBGRPDA,0)),U,1)'=IBINSDA
SET RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) entry points to different INSURANCE COMPANY (#36) entry"
QUIT
+30 IF $GET(IBINSDA)'>0
IF $PIECE($GET(^IBA(355.3,IBGRPDA,0)),U,1)'=$PIECE(IBPAT,U,1)
SET RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) entry points to different INSURANCE COMPANY (#36) entry"
QUIT
+31 ;
+32 DO CLEANUP
+33 ;
+34 LOCK +^DPT(DFN,.312,IBPOLDA):5
IF '$TEST
SET RESULT(4)="-1^INSURANCE TYPE (#2.312) SUB-FILE ENTRY LOCKED, DATA NOT UPDATED"
QUIT
+35 ;
+36 NEW IBXIFN,IBFIELDS,IBERR
+37 SET IBXIFN=IBPOLDA_","_DFN_","
+38 IF $GET(IBINSDA)
SET IBFIELDS(2.312,IBXIFN,.01)=IBINSDA
+39 ;policy's group/plan always update
SET IBFIELDS(2.312,IBXIFN,.18)=IBGRPDA
+40 if '$DATA(IBFIELDS)
QUIT
+41 ;Source
+42 SET IBFIELDS(2.312,IBXIFN,1.09)=$PIECE($GET(^IBA(355.33,+$GET(IBBUFDA),0)),U,3)
+43 ;Source Date
+44 SET IBFIELDS(2.312,IBXIFN,1.1)=+$GET(^IBA(355.33,+$GET(IBBUFDA),0))
+45 DO FILE^DIE("","IBFIELDS","IBERR")
+46 IF $DATA(IBERR)>0
SET RESULT(4)="-1^Fileman DIE error"
+47 IF $DATA(IBERR)'>0
SET RESULT(4)="0^Data successfully updated"
+48 LOCK -^DPT(DFN,.312,IBPOLDA)
+49 QUIT
+50 ;
CLEANUP ;This logic will delete obsolete Individual Plans, Repoint Insurance
+1 ;Reviews if Insurance Company changes, and Remove any Old Benefits Used.
+2 NEW IBPAT,IBOLDINS,IBOLDGRP,IBIP,IBT,IBTNODE0,IBTNODE1,IBFIELDS,IBARR
+3 SET IBPAT=$GET(^DPT(DFN,.312,IBPOLDA,0))
+4 SET IBOLDINS=$PIECE(IBPAT,U,1)
SET IBOLDGRP=$PIECE(IBPAT,U,18)
+5 SET IBIP=$PIECE($GET(^IBA(355.3,+$PIECE(IBPAT,U,18),0)),U,2)
+6 ;If Old Group Insurance Plan is an Individual Plan with only one
+7 ;subscriber for the same Patient Insurance Policy Entry, delete it
+8 IF IBIP=0
IF $$SUBS^IBCNSJ(IBOLDINS,IBOLDGRP,,"IBARR")'>1
IF ($DATA(IBARR(DFN,IBPOLDA))>0)
DO DEL^IBCNSJ(IBOLDGRP)
+9 ;If changing to a new Insurance Company
+10 IF $GET(IBINSDA)>0
IF IBOLDINS'=IBINSDA
Begin DoDot:1
+11 ; - repoint all Insurance Reviews to new company
+12 IF $$IR^IBCNSJ21(DFN,IBPOLDA)
Begin DoDot:2
End DoDot:2
+13 SET IBT=0
+14 FOR
SET IBT=$ORDER(^IBT(356.2,"D",DFN,IBT))
if 'IBT
QUIT
Begin DoDot:2
+15 SET IBTNODE0=$GET(^IBT(356.2,IBT,0))
SET IBTNODE1=$GET(^IBT(356.2,IBT,1))
+16 IF $PIECE(IBTNODE1,U,5)=IBPOLDA
IF $PIECE(IBTNODE0,U,8)'=IBINSDA
Begin DoDot:3
+17 SET IBFIELDS(356.2,IBT_",",.08)=IBINSDA
+18 DO FILE^DIE("","IBFIELDS")
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+19 ;Delete Benefits Used (#355.5) corresponding to old Patient Group Plan
+20 DO DELBU
+21 QUIT
+22 ;
DELBU ;Delete Benefits Used
+1 NEW IBCDFN,IBPLAN,IBBU
+2 SET IBCDFN=IBPOLDA
SET IBPLAN=IBOLDGRP
+3 ;Get Benefits Used
+4 DO BU^IBCNSJ21
+5 ;If there are Benefits Used, then delete them
+6 IF $ORDER(IBBU(0))
Begin DoDot:1
+7 NEW IBDAT
+8 SET IBDAT=""
+9 FOR
SET IBDAT=$ORDER(IBBU(IBDAT))
if IBDAT=""
QUIT
DO DBU^IBCNSJ(IBBU(IBDAT))
End DoDot:1
+10 QUIT
