source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB01.m@ 717

IBCEOB01        ;ALB/ESG - 835 EDI EOB MSG PROCESSING CONT ;16-JAN-2008
        ;;2.0;INTEGRATED BILLING;**377**;21-MAR-94;Build 23
        ;;Per VHA Directive 2004-038, this routine should not be modified.
        ;
        Q
        ;
        ; This routine processes the "06" record on the incoming 835 and
        ; updates the patient insurance files with the corrected name and/or
        ; subscriber ID# data.
        ;
UPD(IB0,IBEOB,IBIFN,DFN,SEQ)    ; update pat ins policy data
        ; IB0   - This is the full "06" record data
        ; IBEOB - ien# to file 361.1
        ; IBIFN - ien# to file 399
        ; DFN   - patient ien# to file 2
        ; SEQ   - payer sequence number
        ;
        NEW CORRID,IBIT,IBZ,IBZ1,IDCHG,INS,MAX,NAMECHG,NNM,NNM1,PD,POL,X,MCRSFX,MCRLEN,LN
        ;
        ; patient ID# processing
        S IDCHG=0   ; flag indicating an ID# change
        S CORRID=$P(IB0,U,6)   ; corrected patient ID#
        S CORRID=$TR(CORRID,"-","")
        I CORRID'="" D
        . I $$VALHIC^IBCNSMM(CORRID) S IDCHG=1   ; valid HIC#
        . E  D MSG^IBCEOB(IBEOB,"The corrected ID# "_CORRID_" is not a valid Medicare HIC#.  No ID# correction done.")
        . Q
        ;
        ; corrected name processing
        S NAMECHG=0   ; flag indicating a name change
        I $P(IB0,U,3)="",$P(IB0,U,4)="",$P(IB0,U,5)="" G UPD1    ; no corrected name components indicated
        ;
        D F^IBCEF("N-CURR INSURED FULL NAME","IBZ",,IBIFN)   ; get the existing name in standard format (see CI2-2.9)
        I IBZ="" D MSG^IBCEOB(IBEOB,"Unable to determine the existing subscriber name.") G UPD1
        S IBZ1=$$NAME^IBCEFG1(IBZ)   ; parse existing name into component pieces (see CI2-2.9)
        ;
        ; Determine if Medicare sent the suffix in the last name field
        S MCRSFX=""                              ; default Medicare suffix found in last name
        S LN=$P(IB0,U,3)                         ; last name
        S MCRLEN=$L(LN," ")                      ; how many " " pieces there are in the Medicare last name
        I MCRLEN>1 D
        . S MCRSFX=$$CHKSUF($P(LN," ",MCRLEN))   ; check the last piece to see if it is a common suffix
        . Q
        ;
        ; build new name components
        S NNM("FAMILY")=$S($P(IB0,U,3)'="":$P(IB0,U,3),1:$P(IBZ1,U,1))
        S NNM("GIVEN")=$S($P(IB0,U,4)'="":$P(IB0,U,4),1:$P(IBZ1,U,2))
        S NNM("MIDDLE")=$S($P(IB0,U,5)'="":$P(IB0,U,5),1:$P(IBZ1,U,3))
        S NNM("SUFFIX")=$S(MCRSFX'="":"",1:$P(IBZ1,U,5))     ; if suffix is in the Medicare last name, blank it out here
        ;
        I NNM("FAMILY")="" D MSG^IBCEOB(IBEOB,"Last name is nil.") G UPD1
        I NNM("GIVEN")="" D MSG^IBCEOB(IBEOB,"First name is nil.") G UPD1
        ;
        K MAX D FIELD^DID(2.312,17,,"FIELD LENGTH","MAX") S MAX=$G(MAX("FIELD LENGTH"))
        I 'MAX D MSG^IBCEOB(IBEOB,"Unable to determine the maximum field length for 2.312,17.") G UPD1
        S NNM1=$$NAMEFMT^XLFNAME(.NNM,"F","CL"_MAX)     ; construct the new name
        K IBIT D FIELD^DID(2.312,17,,"INPUT TRANSFORM","IBIT") S IBIT=$G(IBIT("INPUT TRANSFORM"))
        S X=NNM1 X IBIT        ; invoke the input transform on the field to see if it is valid
        I '$D(X) D MSG^IBCEOB(IBEOB,"New name '"_NNM1_"' failed the input transform for field 2.312,17.") G UPD1
        ;
        ; at this point, all name checks have passed and we have a valid, new, corrected name in NNM1
        S NAMECHG=1
        ;
UPD1    ;
        ;
        I 'NAMECHG,'IDCHG D MSG^IBCEOB(IBEOB,"No changes made.") G UPDX
        ;
        I NAMECHG D
        . N DIE,DA,DR
        . D MSG^IBCEOB(IBEOB,"Name corrected from "_IBZ_" to "_NNM1_".")
        . S DIE=361.1,DA=IBEOB,DR="6.01////^S X=NNM1" D ^DIE
        . Q
        ;
        I IDCHG D
        . N DIE,DA,DR
        . D MSG^IBCEOB(IBEOB,"ID# corrected from "_$$POLICY^IBCEF(IBIFN,2,SEQ)_" to "_CORRID_".")
        . S DIE=361.1,DA=IBEOB,DR="6.02////^S X=CORRID" D ^DIE
        . Q
        ;
        ; Loop thru patient policies looking to update all Medicare entries
        S POL=0
        F  S POL=$O(^DPT(DFN,.312,POL)) Q:'POL  D
        . S PD=$G(^DPT(DFN,.312,POL,0))   ; policy data on the 0 node
        . S INS=+PD
        . I '$$MCRWNR^IBEFUNC(INS) Q      ; quit if ins co isn't Medicare
        . I IDCHG,CORRID'=$P(PD,U,2) D UPDID(DFN,POL,CORRID)   ; ID# change
        . I NAMECHG,NNM1'=$P(PD,U,17) D UPDNM(DFN,POL,NNM1)    ; name change
        . Q
UPDX    ;
        Q
        ;
UPDID(DFN,DA,ID)        ; update the subscriber ID# field
        N DR,DIE,DIC
        S DIE="^DPT("_DFN_",.312,",DA(1)=DFN
        S DR="1///^S X=ID"
        D ^DIE
        D UPDAUD(DFN,DA)           ; audit info
        Q
        ;
UPDNM(DFN,DA,NM)        ; update the subscriber name field
        N DR,DIE,DIC
        S DIE="^DPT("_DFN_",.312,",DA(1)=DFN
        S DR="17///^S X=NM"
        D ^DIE
        D UPDAUD(DFN,DA)           ; audit info
        Q
        ;
UPDAUD(DFN,DA)  ; update the audit information for this patient insurance policy
        N DR,DIE,DIC
        D UPDATPT^IBCNSP3(DFN,DA)   ; date and time last edited and by whom
        S DIE="^DPT("_DFN_",.312,",DA(1)=DFN
        S DR="1.09///MEDICARE"      ; source of information is MEDICARE
        D ^DIE
        D UPDCLM^IBCNSP1(DFN,DA)    ; update editable claims
        Q
        ;
CHKSUF(X)       ; Return X if it looks like a suffix; otherwise, return null
        Q:"^I^II^III^IV^V^VI^VII^VIII^IX^X^JR^SR^DR^MD^ESQ^DDS^RN^"[(U_X_U) X
        Q:"^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"[(U_X_U) X
        Q ""
        ;