Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNICB

IBCNICB.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. 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) 
  1.  ;application to move buffer data in Insurance Files then cleanup
  1.  ;
  1.  ;The call to PROCESS^IBCNBAR and embedded Sub calls are updated to 
  1.  ;provide data in the RESULT parameter and suppress user I/O when 
  1.  ;function is called by ICB.
  1.  ;Input
  1.  ;  IBBUFDA  - INSURANCE BUFFER (#355.33) file internal entry number (IEN) (Required)
  1.  ;  DFN      - PATIENT (#2) file IEN (Required)
  1.  ;  IBINSDA  - INSURANCE COMPANY (#36) File IEN if not adding new entry (Optional)
  1.  ;  IBGRPDA  - GROUP INSURANCE PLAN (#355.3) File IEN if not adding new entry (Optional)
  1.  ;  IBPOLDA  - INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN if
  1.  ;             not adding new entry (Optional)
  1.  ;  IBMVINS  - Type for INSURANCE (Required)
  1.  ;     1=Merge, 2=Overwrite, 3=Replace, 4=Unsupported
  1.  ;  IBMVGRP  - Type for GROUP (Optional)
  1.  ;     1=Merge, 2=Overwrite, 3=Replace, 4=Unsupported
  1.  ;  IBMVPOL  - Type for POLICY (Optional)
  1.  ;     1=Merge, 2=Overwrite, 3=Replace, 4=Unsupported
  1.  ;  IBNEWINS - Add new INSURANCE COMPANY flag (non-zero means add)
  1.  ;  IBNEWGRP - Add new GROUP INSURANCE PLAN flag (non-zero means add)
  1.  ;  IBNEWPOL - Add new patient insurance policy (non-zero means add)
  1.  ;  IVMREPTR - IVM REASONS FOR NOT UPLOADING (#301.91) IEN (Optional)
  1.  ;
  1.  ;OUTPUT
  1.  ;  RESULT   - Returned Parameter Array with IENS of new entries and/or errors/warning.
  1.  ;     RESULT(0) = -1^error message
  1.  ;     RESULT(0) =   0 -Move worked
  1.  ;     RESULT(0) =   0 ^ warning message ^ warning message ^ 
  1.  ;                   warning message ^ warning message
  1.  ;             - Move worked but there may be zero to 4 warning messages
  1.  ;     RESULT(1) = "IBINSDA^" IEN of new Insurance Company (#36) File
  1.  ;     RESULT(1,"ERR",#) - Array with any FM errors when data updated
  1.  ;                         from file 355.33 to 36.
  1.  ;     RESULT(2) = "IBGRPDA^" IEN of new GROUP INSURANCE PLAN (#355.3) File
  1.  ;     RESULT(2,"ERR",#) - Array with any FM errors when data updated
  1.  ;                         from file 355.33 to 355.3.
  1.  ;     RESULT(3) = "IBPOLDA^" IEN of new INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN
  1.  ;     RESULT(3,"ERR",#) - Array with any FM errors when data updated
  1.  ;                         from file 355.33 to 2.312.
  1.  ;     RESULT(4) Contains the results of the call to UPDPOL^IBCNICB which
  1.  ;               is used to update a new group into an existing patient
  1.  ;               policy entry when applicable.
  1.  ;     RESULT(4) =-1^error message      
  1.  ;     RESULT(4) =0 ^ message that process was successful or not required
  1.  ;
  1.  ;IB*687/ckb - added IBCNICB
  1.  N IBCNICB,IBSUPRES,IBUFSTAT,IBX
  1.  I '$D(IBELIG) S IBELIG=0
  1.  ;Set IBSUPRES to suppress screen I/O within ACCEPT
  1.  S IBSUPRES=1,IBUFSTAT=$P($G(^IBA(355.33,$G(IBBUFDA),0)),U,4)
  1.  ;IB*687/ckb - add set of IBCNICB. It will be used to set the ICB PROCESSED BUFFER field #1.08, in the
  1.  ; INTERFACILITY UPDATE file #365.19. IBCNBAR will use IBCNICB when it calls LOC^IBCNIUF.
  1.  S IBCNICB=1
  1.  ;
  1.  S RESULT(0)="-1^INSURANCE BUFFER (#355.33) IEN required" Q:'$G(IBBUFDA)
  1.  S RESULT(0)="-1^INSURANCE BUFFER ENTRY PREVIOUSLY PROCESSED"
  1.  Q:"~A~R~"[("~"_IBUFSTAT_"~")
  1.  S RESULT(0)="-1^INSURANCE BUFFER ENTRY STATUS SHOULD BE ENTERED"
  1.  Q:IBUFSTAT'="E"
  1.  S RESULT(0)="-1^PATIENT (#2) IEN required" Q:'$G(DFN)
  1.  S IBINSDA=$G(IBINSDA),IBGRPDA=$G(IBGRPDA),IBPOLDA=$G(IBPOLDA)
  1.  S IBMVINS=$G(IBMVINS,2),IBMVGRP=$G(IBMVGRP,2),IBMVPOL=$G(IBMVPOL,2)
  1.  S IBNEWINS=$G(IBNEWINS),IBNEWGRP=$G(IBNEWGRP),IBNEWPOL=$G(IBNEWPOL)
  1.  ;
  1.  S RESULT(0)="-1^Passed INSURANCE COMPANY (#36) entry doesn't exist"
  1.  I +IBINSDA,$G(^DIC(36,IBINSDA,0))="" Q
  1.  S RESULT(0)="-1^Passed GROUP INSURANCE PLAN (#355.3) entry doesn't exist"
  1.  I +IBGRPDA,$G(^IBA(355.3,IBGRPDA,0))="" Q
  1.  ; \Beginning IB*2*549 - added the following lines.
  1.  S RESULT(0)="-1^Unable to add new INSURANCE COMPANY (#36) - See your supervisor"
  1.  I +IBNEWINS,'$D(^XUSEC("IB INSURANCE COMPANY EDIT",DUZ)) Q
  1.  S RESULT(0)="-1^Unable to add new GROUP INSURANCE PLAN (#355.3) - See your supervisor"
  1.  I +IBNEWGRP,'$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) Q
  1.  S RESULT(0)="-1^Unable to add new GROUP INSURANCE PLAN (#355.3) - Duplicate Group Plan"
  1.  ;
  1.  ; If new insurance company cont. processing
  1.  I '(+IBNEWINS),+IBNEWGRP,$$EXACTM^IBCNICB2(IBINSDA,IBBUFDA) Q
  1.  ; \End of IB*2*549
  1.  S RESULT(0)="-1^Passed Patient INSURANCE TYPE (#2.312) entry doesn't exist"
  1.  I +IBPOLDA,$G(^DPT(DFN,.312,IBPOLDA,0))="" Q
  1.  S RESULT(0)="-1^Passed GROUP INSURANCE PLAN (#355.3) entry points to different INSURANCE COMPANY (#36) entry"
  1.  I +IBGRPDA,+IBINSDA,+$G(^IBA(355.3,IBGRPDA,0))'=IBINSDA Q
  1.  S RESULT(0)="-1^Individual Policy Patient required to be Patient DFN when Group Insurance Plan is not Group Policy"
  1.  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
  1.  ;
  1.  ;If existing GROUP INSURANCE PLAN (#355.3) entry is being changed from 
  1.  ;a group plan to individual plan with other subscribers, send error 
  1.  ;message and abort update
  1.  S RESULT(0)="-1^Can't change GROUP INSURANCE PLAN from Group Plan to Individual Plan when there are subscribers"
  1.  I +IBGRPDA,$P(IBX,U,2)=1,$P($G(^IBA(355.33,+$G(IBBUFDA),40)),U,1)'=1,$$SUBS^IBCNSJ(IBINSDA,IBGRPDA)>1 Q
  1.  ;
  1.  N IBBUFABORT S IBBUFABORT=0 ;IB*737/CKB
  1.  D PROCESS^IBCNBAR
  1.  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
  1.  Q
  1.  ;
  1. REJECAPI(RESULT,IBBUFDA,IVMREPTR) ;
  1.  ;Provides API to be called by the Insurance Capture Buffer (ICB) 
  1.  ;application to reject buffer entry.
  1.  ;The REJPROC^IBCNBAR call and embedded Sub calls are updated to 
  1.  ;provide data in the RESULT parameter and suppress I/O when function 
  1.  ;is called by ICB.
  1.  ;Input:
  1.  ;   IBBUFDA  - INSURANCE BUFFER (#355.33) file internal entry number
  1.  ;              (required)
  1.  ;   IVMREPTR - IVM REASONS FOR NOT UPLOADING (#301.91) File internal
  1.  ;              internal entry number (Optional)
  1.  ;Output:
  1.  ;   RESULT   - Returned parameter variable with errors messages if
  1.  ;              problems with the reject processing. Format:
  1.  ;     REJECT = -1 ^ error message
  1.  ;     REJECT =  0                     - Reject worked
  1.  ;     REJECT =  0 ^ warning message   - Reject process worked but there
  1.  ;                                       is a warning message
  1.  ;
  1.  N IBSUPRES
  1.  ;Set IBSUPRES to suppress screen I/O within REJECT
  1.  S IBSUPRES=1
  1.  S RESULT="-1^INSURANCE BUFFER IEN required" Q:'$G(IBBUFDA)
  1.  S RESULT="-1^INSURANCE BUFFER ENTRY PREVIOUSLY PROCESSED"
  1.  Q:"~A~R~"[("~"_$$GET1^DIQ(355.33,IBBUFDA,.04,"I")_"~")
  1.  D REJPROC^IBCNBAR
  1.  Q
  1.  ;
  1. UPDTICB(RESULT,DFN,IBPOLDA,IBGRPDA,IBPOLCOM,IBPOLBIL,IBPLAN,IBELEC,IBGPCOM,IBFTF,IBFTFVAL) ;
  1.  ;Updates additional fields for ICB Interface
  1.  ;
  1.  ;Input:
  1.  ;  DFN      - PATIENT (#2) file IEN (Required)
  1.  ;  IBGRPDA  - GROUP INSURANCE PLAN (#355.3) File IEN (Optional)
  1.  ;  IBPOLDA  - INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN 
  1.  ;             (Optional)
  1.  ;  IBPOLCOM - Data to be filed into the COMMENT - SUBSCRIBER POLICY 
  1.  ;              MULTIPLE (2.312, 1.18) optional
  1.  ;  IBPOLBIL - Data to be filed into the STOP POLICY FROM BILLING  (#3.04)
  1.  ;             field of the 2.312 sub-file. (Optional)
  1.  ;             Corresponds to the Internal codes in 3.04 field of 
  1.  ;             2.312 sub-file: '0' FOR NO; '1' FOR YES;
  1.  ;  IBPLAN   - Data to be filed in PLAN FILING TIME FRAME (#.13) field 
  1.  ;             of 355.3 file (Optional)
  1.  ;  IBELEC   - Data to be file in ELECTRONIC PLAN TYPE  (#.15) field 
  1.  ;             of 355.3 file (Optional)
  1.  ;             Corresponds to the Internal Codes in .15 field of 355.3 file
  1.  ;  IBGPCOM  - Group Plan Comment array that contains the word
  1.  ;             processing data to be filed the COMMENTS (#11) word-
  1.  ;             processing field of  355.3 file. (Optional)
  1.  ;              Example:  IBGPCOM(1)="This is line 1"
  1.  ;                        IBGPCOM(2)="This is line 2"
  1.  ;  IBFTF    - Data to be filed in the PLAN STANDARD FTF (#.16) field of
  1.  ;             355.3 file (Optional)
  1.  ;             Corresponds to the Internal Entry Number of the entry in 
  1.  ;             the INSURANCE FILING TIME FRAME (#355.13) File.
  1.  ;  IBFTFVAL - Data to be filed in the PLAN STANDARD FTF VALUE (#.17)
  1.  ;             field of 355.3 file (Optional - Calling application 
  1.  ;             responsible to pass value if required for Plan Standard FTF) 
  1.  ;
  1.  ;Output:
  1.  ;  RESULT - Returned Parameter Array with results of call
  1.  ;   RESULT = 0 ^ No data to update
  1.  ;   RESULT(1) = -1^ error with Insurance Type (#2.312) file update
  1.  ;   RESULT(1) = 0                   - Insurance Type update worked
  1.  ;   RESULT(2) = -1^ error with GROUP INSURANCE PLAN (#355.3) file update
  1.  ;   RESULT(2) = 0                   - Group Insurance Plan update worked
  1.  ;
  1.  ; Update Patient Policy Comment (#1.08) and/or 
  1.  ; Stop Policy From Billing (#3.04) fields in 2.312 subfile
  1.  I $G(IBPOLCOM)]""!($G(IBPOLBIL)]"") D
  1.  . N IBIENS,IBFDA
  1.  . I $G(DFN)']"" S RESULT(1)="-1^PATIENT (#2) DFN not passed" Q
  1.  . I $G(IBPOLDA)'>0 S RESULT(1)="-1^INSURANCE TYPE (#2.312) sub-file IEN not defined" Q
  1.  . I +IBPOLDA,$G(^DPT(DFN,.312,IBPOLDA,0))="" S RESULT(0)="-1^Passed Patient INSURANCE TYPE (#2.312) entry doesn't exist" Q
  1.  . L +^DPT(DFN,.312,IBPOLDA):5 I '$T S RESULT(1)="-1^INSURANCE TYPE (#2.312) sub-file entry locked, data not updated" Q
  1.  . S IBIENS=+IBPOLDA_","_+DFN_","
  1.  . ; IB*2.0*549 Change IS THIS POLICY BILLABLE to STOP POLICY FROM BILLING
  1.  . I $G(IBPOLBIL)]"",$$EXTERNAL^DILFD(2.312,3.04,"",IBPOLBIL)']"" S RESULT(1)="-1^STOP POLICY FROM BILLING ("_IBPOLBIL_") not a valid value",IBPOLBIL=""
  1.  . S:$G(IBPOLBIL)]"" IBFDA(2.312,IBIENS,3.04)=IBPOLBIL
  1.  . I $D(IBFDA)>0 D FILE^DIE(,"IBFDA") S:$D(RESULT(1))'>0 RESULT(1)=0
  1.  . D PPCOMM(DFN,IBPOLDA,IBPOLCOM,.RESULT)
  1.  . L -^DPT(DFN,.312,IBPOLDA)
  1.  ;
  1.  ; Update Plan Filing Time Frame (#.13), Electronic Plan Type (#.15)
  1.  ; Plan Standard FTF (#.16), Plan Standard FTF Value (#.17), and/or
  1.  ; Group Plan Comments (#11) fields in 355.3 file
  1.  I $G(IBPLAN)]""!($G(IBELEC)]"")!($D(IBGPCOM)>0)!($G(IBFTF)]"")!($G(IBFTFVAL)]"") D
  1.  . N IBIENS,IBFDA
  1.  . I $G(IBGRPDA)'>0 S RESULT(2)="-1^GROUP INSURANCE PLAN (#355.3) file IEN not defined" Q
  1.  . I +IBGRPDA,$G(^IBA(355.3,IBGRPDA,0))="" S RESULT(2)="-1^Passed GROUP INSURANCE PLAN (#355.3) entry doesn't exist" Q
  1.  . L +^IBA(355.3,IBGRPDA):5 I '$T S RESULT(2)="-1^GROUP INSURANCE PLAN (#355.3) file entry locked, data not updated" Q
  1.  . S IBIENS=+IBGRPDA_","
  1.  . ; Consistency Checks for Plan Standard FTF and FTF VALUE fields
  1.  . I $G(IBELEC)]"",$$EXTERNAL^DILFD(355.3,.15,"",IBELEC)']"" S RESULT(2)="-1^ELECTRONIC PLAN TYPE ("_IBELEC_") not a valid value",IBELEC=""
  1.  . I $G(IBFTFVAL)]"",$G(IBFTF)']"" S RESULT(2)="-1^PLAN STANDARD FTF should be passed with PLAN STANDARD FTF VALUE",IBFTFVAL=""
  1.  . I $G(IBFTF)]"",$$EXTERNAL^DILFD(355.3,.16,"",IBFTF)']"" S RESULT(2)="-1^PLAN STANDARD FTF ("_IBFTF_") not a valid value",IBFTF=""
  1.  . 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=""
  1.  . ;
  1.  . S:$G(IBPLAN)]"" IBFDA(355.3,IBIENS,.13)=IBPLAN
  1.  . S:$G(IBELEC)]"" IBFDA(355.3,IBIENS,.15)=IBELEC
  1.  . S:$G(IBFTF)]"" IBFDA(355.3,IBIENS,.16)=IBFTF
  1.  . S:$G(IBFTFVAL)]"" IBFDA(355.3,IBIENS,.17)=IBFTFVAL
  1.  . I $D(IBFDA)>0 D FILE^DIE(,"IBFDA") S:$D(RESULT(2))'>0 RESULT(2)=0
  1.  . ;
  1.  . ; Update Group Plan Comments (#11) word processing field in 355.3 file
  1.  . I $O(IBGPCOM(""))>0 D WP^DIE(355.3,+IBGRPDA_",",11,,"IBGPCOM") S:$D(RESULT(2))'>0 RESULT(2)=0
  1.  . L -^IBA(355.3,IBGRPDA)
  1.  I $D(RESULT(1))'>0&($D(RESULT(2))'>0) S RESULT="0^No data to update"
  1.  Q
  1.  ;
  1. PPCOMM(DFN,IBPOLDA,IBPOLCOM,RESULT) ; ib*2*528   record patient policy comments
  1.  ; Input:
  1.  ;   DFN      = patient IEN
  1.  ;   IBPOLDA  = ien of selected INSURANCE POLICY at ^DPT("_DFN_",.312,
  1.  ;   IBPOLCOM = patient policy COMMENT data
  1.  ;
  1.  ; Output:
  1.  ;   RESULT   = Returned Parameter Array with results of call
  1.  ;
  1.  N IBDT,IBVCOM
  1.  S IBVCOM=""
  1.  ;
  1.  ; -- get the last comment made for the policy within VistA
  1.  S IBDT=$O(^DPT(DFN,.312,IBPOLDA,13,"B",""),-1)
  1.  I IBDT]"" S IBCDA=$O(^DPT(DFN,.312,IBPOLDA,13,"B",IBDT,""),-1) S IBVCOM=$G(^DPT(DFN,.312,IBPOLDA,13,IBCDA,1))
  1.  ;
  1.  ; -- no VistA comments for patient policy so go add the new ICB comment
  1.  I IBVCOM="",IBPOLCOM]"" D ADCOM(DFN,IBPOLDA,IBPOLCOM,.RESULT) Q
  1.  ;
  1.  ; -- the last comment within VistA is the same comment as the new ICB comment
  1.  I IBVCOM=IBPOLCOM Q
  1.  ;
  1.  ; -- VistA comment is different from ICB comment so add the ICB comment
  1.  D ADCOM(DFN,IBPOLDA,IBPOLCOM,.RESULT)
  1.  Q
  1.  ;
  1. ADCOM(DFN,IBPOLDA,IBPOLCOM,RESULT) ; add new entry to the COMMENT - SUBSCRIBER POLICY multiple
  1.  ; Input:
  1.  ;   DFN      = patient IEN
  1.  ;   IBPOLDA  = ien of INSURANCE POLICY at ^DPT("_DFN_",.312,
  1.  ;   IBPOLCOM = patient policy COMMENT data
  1.  ;   DUZ      = user IEN - system wide variable   
  1.  ;
  1.  ; Output:
  1.  ;   RESULT   = Returned Parameter Array with results of call
  1.  ;
  1.  ; -- lock the COMMENT - SUBSCRIBER POLICY multiple so that previous comments can't be edited
  1.  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
  1.  ;
  1.  N FDA,IENS,DIERR
  1.  ;
  1.  ; -- populate the FDA array with data
  1.  S IENS="+1,"_IBPOLDA_","_DFN_","
  1.  S FDA(2.342,IENS,.01)=$$NOW^XLFDT()
  1.  S FDA(2.342,IENS,.02)=DUZ
  1.  S FDA(2.342,IENS,.03)=IBPOLCOM
  1.  ;
  1.  ; -- update comment
  1.  D UPDATE^DIE(,"FDA",,"DIERR")
  1.  ;
  1.  ; -- check for error
  1.  I $D(DIERR) S RESULT(1)="-1^INSURANCE TYPE (#2.312,1.18) error adding comment to INSURANCE TYPE (#2.312,1.18)"
  1.  E  S RESULT(1)=0
  1.  ;
  1.  ; -- unlock comment multiple
  1.  L -^DPT(DFN,.312,IBPOLDA,13)
  1.  Q
  1.  ;
  1. 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,
  1.  ;         IBDT = date/time that comment was made
  1.  N DA,DIE,DR,IBNM
  1.  ; retrieve the latest comment made by the user
  1.  S DA=$O(^DPT(DFN,.312,IBPOLDA,13,"BB",DUZ,IBDT,""),-1)
  1.  S DIE="^DPT("_DFN_",.312,"_IBPOLDA_",13,"
  1.  S DA(2)=DFN,DA(1)=IBPOLDA
  1.  ;  retrieve the latest comment made by the user
  1.  S IBNM=$$GET1^DIQ(200,DUZ_",",.01,"E")
  1.  I $G(^DPT(DFN,.312,IBPOLDA,13,DA,1))]"" S DR=".01///"_$$NOW^XLFDT()_";.02///"_IBNM_";.03///"_IBPOLCOM
  1.  E  S DR=".01///@;.02///@"
  1.  D ^DIE
  1.  Q
  1.  ;
  1. UPDPOL(RESULT,IBBUFDA,DFN,IBINSDA,IBGRPDA,IBPOLDA) ;update a new group into 
  1.  ;an existing patient policy entry for ICB interface
  1.  ;Input
  1.  ;  IBBUFDA  - INSURANCE BUFFER (#355.33) file internal entry number (IEN) (Required)
  1.  ;  DFN      - PATIENT (#2) file IEN (Required)
  1.  ;  IBINSDA  - INSURANCE COMPANY (#36) File IEN if not adding new entry (Optional)
  1.  ;  IBGRPDA  - GROUP INSURANCE PLAN (#355.3) File IEN if not adding new entry (Required)
  1.  ;  IBPOLDA  - INSURANCE TYPE (#2.312) sub-file of PATIENT (#2) IEN if
  1.  ;             not adding new entry (Required)
  1.  ;Output:
  1.  ;  RESULT(4) - Returned Parameter Array with results of call
  1.  ;     RESULT(4) =-1^error message
  1.  ;     RESULT(4) =0 ^ message that process was successful or not require
  1.  ;
  1.  N IBPAT
  1.  I $G(IBBUFDA)'>0 S RESULT(4)="-1^INSURANCE BUFFER (#355.33) IEN required" Q
  1.  I $G(DFN)'>0 S RESULT(4)="-1^PATIENT (#2) IEN required" Q
  1.  I $G(IBPOLDA)'>0 S RESULT(4)="-1^INSURANCE TYPE (#2.312) SUB-FILE IEN required" Q
  1.  I $G(^DPT(DFN,.312,IBPOLDA,0))'>0 S RESULT(4)="-1^PATIENT INSURANCE TYPE(#2.312) entry doesn't exist" Q
  1.  I $G(IBGRPDA)'>0 S RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) IEN required" Q
  1.  ;
  1.  ; NO changes required
  1.  S IBPAT=$G(^DPT(DFN,.312,IBPOLDA,0))
  1.  I $G(IBINSDA)>0,$P(IBPAT,U,1)=IBINSDA,$P(IBPAT,U,18)=IBGRPDA S RESULT(4)="0^NO CHANGE REQUIRE" Q
  1.  I $G(IBINSDA)'>0,$P(IBPAT,U,18)=IBGRPDA S RESULT(4)="0^NO CHANGE REQUIRE" Q
  1.  ;
  1.  ;Additional error checks
  1.  I $G(^IBA(355.3,IBGRPDA,0))="" S RESULT(4)="-1^GROUP INSURANCE PLAN (#355.3) entry doesn't exist" Q
  1.  I $G(IBINSDA)>0,$G(^DIC(36,IBINSDA,0))="" S RESULT(4)="-1^INSURANCE COMPANY (#36) entry doesn't exist" Q
  1.  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
  1.  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
  1.  ;
  1.  D CLEANUP
  1.  ;
  1.  L +^DPT(DFN,.312,IBPOLDA):5 I '$T S RESULT(4)="-1^INSURANCE TYPE (#2.312) SUB-FILE ENTRY LOCKED, DATA NOT UPDATED" Q
  1.  ;
  1.  N IBXIFN,IBFIELDS,IBERR
  1.  S IBXIFN=IBPOLDA_","_DFN_","
  1.  I $G(IBINSDA) S IBFIELDS(2.312,IBXIFN,.01)=IBINSDA
  1.  S IBFIELDS(2.312,IBXIFN,.18)=IBGRPDA ;policy's group/plan always update 
  1.  Q:'$D(IBFIELDS)
  1.  ;Source
  1.  S IBFIELDS(2.312,IBXIFN,1.09)=$P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,3)
  1.  ;Source Date
  1.  S IBFIELDS(2.312,IBXIFN,1.1)=+$G(^IBA(355.33,+$G(IBBUFDA),0))
  1.  D FILE^DIE("","IBFIELDS","IBERR")
  1.  I $D(IBERR)>0 S RESULT(4)="-1^Fileman DIE error"
  1.  I $D(IBERR)'>0 S RESULT(4)="0^Data successfully updated"
  1.  L -^DPT(DFN,.312,IBPOLDA)
  1.  Q
  1.  ;
  1. CLEANUP ;This logic will delete obsolete Individual Plans, Repoint Insurance 
  1.  ;Reviews if Insurance Company changes, and Remove any Old Benefits Used.
  1.  N IBPAT,IBOLDINS,IBOLDGRP,IBIP,IBT,IBTNODE0,IBTNODE1,IBFIELDS,IBARR
  1.  S IBPAT=$G(^DPT(DFN,.312,IBPOLDA,0))
  1.  S IBOLDINS=$P(IBPAT,U,1),IBOLDGRP=$P(IBPAT,U,18)
  1.  S IBIP=$P($G(^IBA(355.3,+$P(IBPAT,U,18),0)),U,2)
  1.  ;If Old Group Insurance Plan is an Individual Plan with only one
  1.  ;subscriber for the same Patient Insurance Policy Entry, delete it
  1.  I IBIP=0,$$SUBS^IBCNSJ(IBOLDINS,IBOLDGRP,,"IBARR")'>1,($D(IBARR(DFN,IBPOLDA))>0) D DEL^IBCNSJ(IBOLDGRP)
  1.  ;If changing to a new Insurance Company
  1.  I $G(IBINSDA)>0,IBOLDINS'=IBINSDA D  Q
  1.  . ; - repoint all Insurance Reviews to new company
  1.  . I $$IR^IBCNSJ21(DFN,IBPOLDA) D
  1.  . S IBT=0
  1.  . F  S IBT=$O(^IBT(356.2,"D",DFN,IBT)) Q:'IBT  D
  1.  . . S IBTNODE0=$G(^IBT(356.2,IBT,0)),IBTNODE1=$G(^IBT(356.2,IBT,1))
  1.  . . I $P(IBTNODE1,U,5)=IBPOLDA,$P(IBTNODE0,U,8)'=IBINSDA D
  1.  . . . S IBFIELDS(356.2,IBT_",",.08)=IBINSDA
  1.  . . . D FILE^DIE("","IBFIELDS")
  1.  ;Delete Benefits Used (#355.5) corresponding to old Patient Group Plan
  1.  D DELBU
  1.  Q
  1.  ;
  1. DELBU ;Delete Benefits Used
  1.  N IBCDFN,IBPLAN,IBBU
  1.  S IBCDFN=IBPOLDA,IBPLAN=IBOLDGRP
  1.  ;Get Benefits Used
  1.  D BU^IBCNSJ21
  1.  ;If there are Benefits Used, then delete them
  1.  I $O(IBBU(0)) D
  1.  . N IBDAT
  1.  . S IBDAT=""
  1.  . F  S IBDAT=$O(IBBU(IBDAT)) Q:IBDAT=""  D DBU^IBCNSJ(IBBU(IBDAT))
  1.  Q