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

IBCNEHL5.m

Go to the documentation of this file. 
  1. IBCNEHL5 ;DALOI/KML - HL7 Process Incoming RPI Msgs (cont.) ; 1-APRIL-2013
  1.  ;;2.0;INTEGRATED BILLING;**497,549,702,743,752**;21-MAR-94;Build 20
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;**Program Description**
  1.  Q  ; No direct calls
  1.  ;
  1. GZRF(ERROR,IBSEG,RIEN) ; Process Group level ZRF Reference identification segment (x12 loops 2100C and 2100D)
  1.  ;
  1.  ; Input:
  1.  ; IBSEG,RIEN
  1.  ;
  1.  ; Output:
  1.  ; ERROR
  1.  ;
  1.  N IENSTR,RSUPDT,QUAL,VALUE
  1.  S IENSTR="+1,"_RIEN_","
  1.  S RSUPDT(365.09,IENSTR,.01)=+$O(^IBCN(365,RIEN,9,"B",""),-1)+1  ; node 9 sequence #
  1.  ; Reference id & qualifier
  1.  S QUAL=$P($G(IBSEG(3)),HLCMP),VALUE=$G(IBSEG(4))
  1.  I VALUE'="",QUAL'="" S RSUPDT(365.09,IENSTR,.02)=VALUE,RSUPDT(365.09,IENSTR,.03)=QUAL
  1.  S RSUPDT(365.09,IENSTR,.04)=$G(IBSEG(5)) ; Description
  1.  D CODECHK^IBCNEHLU(.RSUPDT)  ;check for new coded values
  1.  D UPDATE^DIE("E","RSUPDT",,"ERROR")
  1.  Q
  1.  ;
  1. ZMP(ERROR,IBSEG,RIEN) ; Process Military Personnel Information that comes from X12 271 MPI segment of the 2100C and 2100D loops 
  1.  ;
  1.  ; Input:
  1.  ; IBSEG,RIEN
  1.  ;
  1.  ; Output:
  1.  ; ERROR
  1.  ;
  1.  N IENSTR,RSUPDT,QUAL,VALUE
  1.  S IENSTR=RIEN_","
  1.  S RSUPDT(365,IENSTR,12.01)=$G(IBSEG(3))  ; information status code
  1.  S RSUPDT(365,IENSTR,12.02)=$G(IBSEG(4))  ; employment status code
  1.  S RSUPDT(365,IENSTR,12.03)=$G(IBSEG(5))  ; government service affiliation code
  1.  S RSUPDT(365,IENSTR,12.04)=$G(IBSEG(6))  ; description
  1.  S RSUPDT(365,IENSTR,12.05)=$G(IBSEG(7))  ; Military service rank code
  1.  ;Date time period format qualifier and Date time period
  1.  S QUAL=$P($G(IBSEG(8)),HLCMP),VALUE=$G(IBSEG(9))
  1.  I VALUE'="",QUAL'="" S RSUPDT(365,IENSTR,12.06)=QUAL,RSUPDT(365,IENSTR,12.07)=VALUE
  1.  D CODECHK^IBCNEHLU(.RSUPDT)  ;check for new coded values
  1.  D UPDATE^DIE("E","RSUPDT",,"ERROR")
  1.  Q
  1.  ;
  1. ROL(ERROR,IBSEG,RIEN) ; process group level Provider Information in the X12 271 PRV segment of X12 loops: 2100B, 2100C, 2100D
  1.  ;
  1.  ; Input:
  1.  ; IBSEG,RIEN
  1.  ;
  1.  ; Output:
  1.  ; ERROR
  1.  ;
  1.  N IENSTR,RSUPDT,QUAL,VALUE
  1.  S IENSTR="+1,"_RIEN_","
  1.  S RSUPDT(365.04,IENSTR,.01)=+$O(^IBCN(365,RIEN,10,"B",""),-1)+1  ; node 10 sequence #
  1.  S RSUPDT(365.04,IENSTR,.02)=$P($G(IBSEG(4)),HLCMP)   ; provider code
  1.  S RSUPDT(365.04,IENSTR,.03)=$P($G(IBSEG(5)),HLCMP)   ; reference ID
  1.  D CODECHK^IBCNEHLU(.RSUPDT)  ;check for new coded values
  1.  D UPDATE^DIE("E","RSUPDT",,"ERROR")
  1.  Q
  1.  ;
  1. DG1(ERROR,IBSEG,RIEN) ; process DIAGNOSIS codes in the X12 271 HI segment of X12 loops: 2100C, 2100D
  1.  ;
  1.  ; Input:
  1.  ; IBSEG,RIEN
  1.  ;
  1.  ; Output:
  1.  ; ERROR
  1.  ;
  1.  N IENSTR,RSUPDT,DCODE
  1.  S IENSTR="+1,"_RIEN_","
  1.  S RSUPDT(365.01,IENSTR,.01)=+$O(^IBCN(365,RIEN,11,"B",""),-1)+1  ; node 11 sequence #
  1.  S DCODE=$P($G(IBSEG(4)),HLCMP)
  1.  S RSUPDT(365.01,IENSTR,.02)=$E(DCODE,1,3)_"."_$E(DCODE,4,99)  ; diagnosis code
  1.  S RSUPDT(365.01,IENSTR,.03)=$P($G(IBSEG(4)),HLCMP,3)          ; diagnosis code qualifier
  1.  S RSUPDT(365.01,IENSTR,.04)=$S($P($G(IBSEG(16)),HLCMP)=1:"P",1:"S")  ; primary or secondary diagnosis code
  1.  I $D(RSUPDT) D UPDATE^DIE("E","RSUPDT",,"ERROR")
  1.  Q
  1.  ;
  1. EBFILE(DFN,IEN312,RIEN,AFLG) ;EP
  1.  ; File eligibility/benefit data from file 365 into file 2.312
  1.  ; IB*2.0*549 moved method from IBCNEHL1 because of routine size limitations
  1.  ; Input:   DFN     - Internal Patient IEN
  1.  ;          IEN312  - Insurance multiple #
  1.  ;          RIEN    - file 365 ien
  1.  ;          AFLG    - 1 if called from autoupdate
  1.  ;                    0 if called from ins. buffer process entry
  1.  ; Returns: "" on success, ERFLG on failure. Also called from ACCEPT^IBCNBAR
  1.  ;          for manual processing of ins. buffer entry.
  1.  ;
  1.  ;
  1.  N DA,DIK,DATA,DATA1,EBIENS,ERFLG,ERROR,GIEN,GSKIP,IENROOT,IENS,IENSTR,TYPE,TYPE1,Z,Z1,Z2
  1.  ; delete existing EB data
  1.  S DIK="^DPT("_DFN_",.312,"_IEN312_",6,",DA(2)=DFN,DA(1)=IEN312
  1.  S DA=0 F  S DA=$O(^DPT(DFN,.312,IEN312,6,DA)) Q:DA=""!(DA?1.A)  D ^DIK
  1.  ;
  1.  ; /IB*2.0*506 Beginning
  1.  ; File the new Requested Service Date field (file #2.312,8.01) from the file #365,1.1 field,
  1.  ; if the Service Date is not present, then use the Eligibility Date which would be from the file #365,1.11 field
  1.  ; ALSO, file the new Requested Service Type field (file #2.312,8.02) from the file #365.02,.04 field.
  1.  N DIE,DR,NODE0,RSRVDT,RSTYPE,TQIEN
  1.  S TQIEN=$P($G(^IBCN(365,RIEN,0)),U,5),NODE0=$G(^IBCN(365.1,TQIEN,0))
  1.  S RSTYPE=$P(NODE0,U,20),RSRVDT=$P($G(^IBCN(365,RIEN,1)),U,10)
  1.  I RSRVDT="" S RSRVDT=$P(NODE0,U,12)
  1.  S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IEN312
  1.  ;
  1.  ; IB*2.0*549 - File the pointer to the IIV RESPONSE (file 365)
  1.  D UPDT365(RIEN,IEN312_","_DFN_",")
  1.  ;IB*752/DW-TAZ use //// for field 8.02 since /// changes the IEN of the code found in file #365.1
  1.  ;       to an IEN of another code since it treats it as an external value (corrupts data) 
  1.  S DR="8.01///"_RSRVDT_";8.02////"_RSTYPE_";8.03///"_RIEN
  1.  D ^DIE
  1.  ; /IB*2.0*506 End
  1.  ;
  1.  ; file new EB data
  1.  S IENSTR=IEN312_","_DFN_","
  1.  S GIEN=+$P($G(^DPT(DFN,.312,IEN312,0)),U,18)
  1.  S Z="" F  S Z=$O(^IBCN(365,RIEN,2,"B",Z)) Q:Z=""!$G(ERFLG)  D
  1.  .S EBIENS=$O(^IBCN(365,RIEN,2,"B",Z,""))_","_RIEN_","
  1.  .; if filing Medicare Part A/B data, make sure we only file the correct EB group
  1.  .S GSKIP=0 I GIEN>0 D
  1.  ..S TYPE=$$GET1^DIQ(365.02,EBIENS,.05)
  1.  ..S TYPE1=$P($G(^IBA(355.3,GIEN,0)),U,14)
  1.  ..I TYPE="MA",TYPE1="B" S GSKIP=1
  1.  ..I TYPE="MB",TYPE1="A" S GSKIP=1
  1.  ..Q
  1.  .I GSKIP Q  ; wrong Medicare Part A/B EB group - skip it
  1.  .D GETS^DIQ(365.02,EBIENS,"**",,"DATA","ERROR") I $D(ERROR) D:AFLG WARN^IBCNEHL3 Q
  1.  .; make sure we have data to file
  1.  .I '$D(DATA(365.02)) Q
  1.  .S IENS="+1,"_IENSTR,Z1=$O(DATA(365.02,"")) M DATA1(2.322,IENS)=DATA(365.02,Z1)
  1.  .D UPDATE^DIE("E","DATA1","IENROOT","ERROR") I $D(ERROR) D:AFLG WARN^IBCNEHL3 Q
  1.  .S IENS="+1,"_IENROOT(1)_","_IENSTR K DATA1,IENROOT
  1.  .S Z2="" F  S Z2=$O(DATA(365.26,Z2)) Q:Z2=""!$G(ERFLG)  D
  1.  ..M DATA1(2.3226,IENS)=DATA(365.26,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
  1.  ..Q
  1.  .S Z2="" F  S Z2=$O(DATA(365.27,Z2)) Q:Z2=""!$G(ERFLG)  D
  1.  ..M DATA1(2.3227,IENS)=DATA(365.27,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
  1.  ..Q
  1.  .S Z2="" F  S Z2=$O(DATA(365.28,Z2)) Q:Z2=""!$G(ERFLG)  D
  1.  ..M DATA1(2.3228,IENS)=DATA(365.28,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
  1.  ..Q
  1.  .S Z2="" F  S Z2=$O(DATA(365.29,Z2)) Q:Z2=""!$G(ERFLG)  D
  1.  ..M DATA1(2.3229,IENS)=DATA(365.29,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
  1.  ..Q
  1.  .S Z2="" F  S Z2=$O(DATA(365.291,Z2)) Q:Z2=""!$G(ERFLG)  D
  1.  ..M DATA1(2.32291,IENS)=DATA(365.291,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
  1.  ..Q
  1.  .S Z2="" F  S Z2=$O(DATA(365.292,Z2)) Q:Z2=""!$G(ERFLG)  D
  1.  ..M DATA1(2.32292,IENS)=DATA(365.292,Z2) D UPDATE^DIE("E","DATA1",,"ERROR") K DATA1 I $D(ERROR) D:AFLG WARN^IBCNEHL3
  1.  ..Q
  1.  .K DATA
  1.  .Q
  1.  Q $G(ERFLG)
  1.  ;
  1. UPDT365(RIEN,IEN312)    ; Sets the DO NOT PURGE flag in file 365
  1.  ; Input:   RIEN        - IEN of the entry in file 365 to be set
  1.  ;          IEN312      - IENS of the Insurance multiple entry
  1.  ; IB*2.0*549 added method
  1.  N DA,DIE,DR,XX
  1.  S XX=$$GET1^DIQ(2.312,IEN312,8.03,"I")     ; Get current file 365 pointer
  1.  I XX'="" D                                 ; Remove the DO NOT PURGE flag
  1.  . S DIE=365,DA=XX
  1.  . S DR=".11///0"
  1.  . D ^DIE
  1.  ;
  1.  ; Set the DO NOT PURGE Flag
  1.  S DIE=365,DA=RIEN
  1.  S DR=".11///1"
  1.  D ^DIE
  1.  Q
  1.  ;
  1.  ; IB*702/DTG - moved AUTOFIL from IBCNEHL1 for SAC space size.
  1. AUTOFIL(DFN,IEN312,ISSUB) ;Finish processing the response message - file directly into patient insurance
  1.  ;
  1.  N BUFF,DATA,ERROR,IENS,MIL,OKAY,PREL,RDATA0,RDATA1,RDATA5,RDATA13,RSTYPE,TQN,TSTAMP,XX  ;IB*2*497 (vd)
  1.  N IBARR,IBIFN ;IB*702/DTG need for auto eiv user name
  1.  ;
  1.  S TSTAMP=$$NOW^XLFDT(),IENS=IEN312_","_DFN_","
  1.  S RDATA0=$G(^IBCN(365,RIEN,0)),RDATA1=$G(^IBCN(365,RIEN,1)),RDATA5=$G(^IBCN(365,RIEN,5))
  1.  S RDATA13=$G(^IBCN(365,RIEN,13))     ;IB*2*497 (vd)
  1.  S TQN=$P(RDATA0,U,5),RSTYPE=$P(RDATA0,U,10)
  1.  ;\Beginning IB*2*549 - Modified the following lines
  1.  S XX=$$GET1^DIQ(2.312,IENS,7.01,"I")
  1.  I ISSUB,XX="" S DATA(2.312,IENS,7.01)=$P(RDATA13,U)  ;Name
  1.  S XX=$$GET1^DIQ(2.312,IENS,3.01,"I")
  1.  I XX="" S DATA(2.312,IENS,3.01)=$P(RDATA1,U,2)       ;DOB
  1.  S XX=$$GET1^DIQ(2.312,IENS,3.05,"I")
  1.  I XX="" S DATA(2.312,IENS,3.05)=$P(RDATA1,U,3)       ;SSN
  1.  S XX=$$GET1^DIQ(2.312,IENS,6,"I")
  1.  I ISSUB,XX="" S DATA(2.312,IENS,6)=$P(RDATA1,U,8)    ;Whose insurance
  1.  ;pt. relationship (365,8.01) IB*2*497 code from 365,8.01 needs evaluation & possible conversion
  1.  S PREL=$$GET1^DIQ(365,RIEN,8.01)
  1.  S XX=$$GET1^DIQ(2.312,IENS,4.03,"I")
  1.  I ISSUB,XX="",PREL'="" D
  1.  . S DATA(2.312,IENS,4.03)=$$PREL^IBCNEHLU(2.312,4.03,PREL)
  1.  ;\End of IB*2*549 changes.
  1.  ;
  1.  ;Moved the setting of fields 1.03 through 1.06 plus 1.09
  1.  ; persist the original Source of Information
  1.  ;note: external values are used to populate DATA
  1.  I $$GET1^DIQ(2.312,IENS,1.09,"I")="" D
  1.  . S XX=$$GET1^DIQ(365.1,TQN_",1,",3.02)
  1.  . I XX="" S XX="eIV"
  1.  . S DATA(2.312,IENS,1.09)=XX
  1.  ;
  1.  ;Set Subscriber address Fields if none of the fields are currently defined
  1.  ;\Beginning IB*2*549 - Modified the following lines
  1.  S XX=$$GET1^DIQ(2.312,IENS,3.06,"I")      ;Current Ins Street Line 1
  1.  I XX="" D
  1.  . S XX=$$GET1^DIQ(2.312,IENS,3.07,"I")    ;Current Ins Street Line 2
  1.  . Q:XX'=""
  1.  . S XX=$$GET1^DIQ(2.312,IENS,3.08,"I")    ;Current Ins City
  1.  . Q:XX'=""
  1.  . S XX=$$GET1^DIQ(2.312,IENS,3.09,"I")    ;Current Ins State
  1.  . Q:XX'=""
  1.  . S XX=$$GET1^DIQ(2.312,IENS,3.1,"I")     ;Current Ins Zip
  1.  . Q:XX'=""
  1.  . S XX=$$GET1^DIQ(2.312,IENS,3.13,"I")    ;Current Ins Country
  1.  . Q:XX'=""
  1.  . S XX=$$GET1^DIQ(2.312,IENS,3.14,"I")    ;Current Ins Country Subdivision
  1.  . Q:XX'=""
  1.  . S DATA(2.312,IENS,3.06)=$P(RDATA5,U)    ;Street line 1
  1.  . S DATA(2.312,IENS,3.07)=$P(RDATA5,U,2)  ;Street line 2
  1.  . S DATA(2.312,IENS,3.08)=$P(RDATA5,U,3)  ;City
  1.  . S DATA(2.312,IENS,3.09)=$P(RDATA5,U,4)  ;State
  1.  . S DATA(2.312,IENS,3.1)=$P(RDATA5,U,5)   ;Zip
  1.  . S DATA(2.312,IENS,3.13)=$P(RDATA5,U,6)  ;Country
  1.  . S DATA(2.312,IENS,3.14)=$P(RDATA5,U,7)  ;Country subdivision
  1.  ;\End of IB*2*549 changes.
  1.  ;
  1.  L +^DPT(DFN,.312,IEN312):15 I '$T D LCKERR^IBCNEHL3 D FIL^IBCNEHL1 Q
  1.  I $D(DATA) D FILE^DIE("ET","DATA","ERROR") ; make sure DATA has data  
  1.  I $D(ERROR) D WARN^IBCNEHL3 K ERROR D FIL^IBCNEHL1 G AUTOFILX
  1.  K DATA
  1.  S DATA(2.312,IENS,1.03)=TSTAMP                ;Date last verified
  1.  S DATA(2.312,IENS,1.04)=IBEIVUSR    ;Last verified by ;IB*702/DTG - use variable for user name (auto update user)
  1.  S DATA(2.312,IENS,1.05)=TSTAMP                ;Date last edited
  1.  S DATA(2.312,IENS,1.06)=IBEIVUSR    ;Last edited by   ;IB*702/DTG - use variable for user name (auto update user)
  1.  D FILE^DIE("ET","DATA","ERROR")
  1.  I $D(ERROR) D WARN^IBCNEHL3 G AUTOFILX
  1.  ; set the insurance record IEN in the IIV Response file
  1.  ;to track which policy was updated based on the response
  1.  D UPDIREC^IBCNEHL3(RIEN,IEN312)
  1.  ; set the EIV AUTO-UPDATE in the response file to signal auto-update
  1.  K DATA
  1.  S DATA(365,RIEN_",",.13)="YES"
  1.  D FILE^DIE("ET","DATA")
  1.  ;
  1.  ;IB*2*497 file data at 2.312, 9, 10 & 11 subfiles; if error is produced update buffer entry & then quit processing
  1.  S ERFLG=$$GRPFILE^IBCNEHL1(DFN,IEN312,RIEN,1)
  1.  I $G(ERFLG) G AUTOFILX
  1.  ;
  1.  ;file new EB data
  1.  S ERFLG=$$EBFILE^IBCNEHL1(DFN,IEN312,RIEN,1)
  1.  I $G(ERFLG) G AUTOFILX  ;bail out if something went wrong during filing of EB data
  1.  ;
  1.  ;update insurance record ien in transmission queue
  1.  D UPDIREC^IBCNEHL3(RIEN,IEN312)
  1.  ;
  1.  ;For an original response, set the Transmission Queue Status to 'Response Received' &
  1.  ;update remaining retries to comm failure (5)
  1.  ;IB*743/CKB - called earlier when saving the MSA segment 
  1.  ;I $G(RSTYPE)="O" D SST^IBCNEUT2(TQN,3),RSTA^IBCNEUT7(TQN)
  1.  ;
  1.  ;File Auto Updated policy in INTERFACILITY INSURANCE UPDATE File (#365.19)
  1.  ; IBCNBAR added a field the param list when calling LOC^IBCNIUF. For consistency we added a 'null'.
  1.  D LOC^IBCNIUF(DFN,$$GET1^DIQ(2.312,IEN312_","_DFN_",",.01,"I"),IEN312,$$GET1^DIQ(365,RIEN_",",.13,"I"),"",$$GET1^DIQ(365.1,TQN_",",3.02,"E"),"")
  1.  ;
  1.  ;Get the buffer entry from the IIV RESPONSE File (#365)
  1.  S BUFF=+$P($G(^IBCN(365,RIEN,0)),U,4)
  1.  ;
  1.  ;IB*743/TAZ - If there is a Buffer entry associated with the Response and it is already processed,
  1.  ;  DO NOT touch/update files #355.33 or #355.36
  1.  I BUFF,$$GET1^DIQ(355.33,BUFF,.04,"I")'="E" G AUTOFILX
  1.  ;
  1.  ;Update the buffer status to ACCEPTED, then call DELDATA^IBCNBED so only the stub remains                                                    
  1.  I BUFF D
  1.  . D STATUS^IBCNBEE(BUFF,"A",0,0,0) ;update status to accepted
  1.  . ;IB*702/DTG - save auto update user to buffer
  1.  . S IBIFN=BUFF_"," K IBARR
  1.  . S IBARR(355.33,IBIFN,.06)=$G(IBEIVUSR)
  1.  . D FILE^DIE("E","IBARR")          ;file with the 'E' allows for external input, name vs ien
  1.  . D DELDATA^IBCNBED(BUFF)          ;delete buffer's insurance/patient data
  1.  . ;
  1.  ; File data to #355.36 file.
  1.  N BUFF,ERROR,FDA,WE
  1.  S WE=$$GET1^DIQ(365.1,TQN_",",.1,"I")
  1.  S BUFF=$$GET1^DIQ(365,RIEN_",",.04,"I")
  1.  S FDA(355.36,"+1,",.01)=$$NOW^XLFDT    ;Date Processed
  1.  S FDA(355.36,"+1,",.02)=$S("^5^6^"[(U_WE_U):3,"^1^2^"[(U_WE_U):1,1:"")   ;"WE" Should never be 4 or 7 at this point
  1.  S FDA(355.36,"+1,",.03)=$$GET1^DIQ(365.1,TQN_",",3.02,"I")   ;Source of Information
  1.  S FDA(355.36,"+1,",.04)=$$GET1^DIQ(365,RIEN_",",.13,"I")     ;EIV Auto-Update
  1.  S FDA(355.36,"+1,",.05)=TQN            ;EIV Inquiry
  1.  S FDA(355.36,"+1,",.06)=RIEN           ;EIV Response
  1.  S FDA(355.36,"+1,",.07)=BUFF           ;Buffer
  1.  S FDA(355.36,"+1,",.08)=WE             ;Source of Request (Which Extract)
  1.  D UPDATE^DIE("","FDA",,"ERROR")
  1.  I $D(ERROR) D
  1.  . D MSG003^IBCNEMS1(.IBMSG,.ERROR,TQN,RIEN,BUFF)
  1.  . D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: Error writing to the CREATION TO PROCESSING TRACKING File (#355.36)","IBMSG(")
  1.  ;
  1. AUTOFILX ;
  1.  L -^DPT(DFN,.312,IEN312)
  1.  Q