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

IBCNEDE3.m

Go to the documentation of this file.
  1. IBCNEDE3 ;AITC/CKB - eIV Appointment Extract ;23-OCT-2023
  1. ;;2.0;INTEGRATED BILLING;**778**;21-MAR-94;Build 28
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;IB*778/CKB - this routine is called by IBCNEDE2 which is used for the Appointment Extract
  1. ;
  1. Q ; can't be called directly
  1. ;
  1. STRIP(VALUE) ; check non-alpha numeric characters
  1. ;INPUT:
  1. ; VALUE = the string/field to check
  1. ;
  1. ;RETURN:
  1. ; STRNG = NO non-alpha numeric chars were found, STRNG equal VALUE
  1. ; = if non-alpha numeric chars were found, STRNG will be returned without non-alpha numeric chars in VALUE
  1. ;
  1. ; ASCII codes: 48-57: 0-9 / 65-90: A-Z / 97-122: a-z
  1. ;
  1. N IBI,IBY,LEN,STRNG,XX
  1. I $G(VALUE)="" S STRNG=VALUE G STRIPX
  1. S LEN=$L(VALUE)
  1. S (IBY,STRNG)=""
  1. F IBI=1:1:LEN S IBY=$E(VALUE,IBI) Q:IBY="" D
  1. . ;Remove all non-alpha numeric characters
  1. . I ($A(IBY)<48) Q
  1. . I ($A(IBY)>57&($A(IBY)<65))!($A(IBY)>90&($A(IBY)<97))!($A(IBY)>122) Q
  1. . S STRNG=STRNG_IBY
  1. STRIPX ;
  1. Q STRNG
  1. ;
  1. UPDSD(PIEN,AIEN,SVDT) ;Update service date based on Payers allowed date range - Appointment Extract
  1. ;from UPDDTS^IBCNEDE6, except past service dates and freshness days are no longer updated
  1. ;Input:
  1. ; PIEN - Payer IEN
  1. ; AIEN - Payer App IEN
  1. ;Output:
  1. ; SVDT - passed by reference, updated service date
  1. ;
  1. N DATA,FDAYS
  1. ;
  1. I ($G(PIEN)="")!($G(AIEN)="") Q
  1. ;
  1. S FDAYS=0
  1. S DATA=$G(^IBE(365.12,PIEN,1,AIEN,0))
  1. ; Quit without changing if node is not defined
  1. I DATA="" Q
  1. ; FUTURE SERVICE DAYS
  1. S FDAYS=$$GET1^DIQ(365.121,AIEN_","_PIEN_",",4.03)
  1. ; Process future service days if not edited and if not null
  1. I FDAYS'="" D
  1. . ; If zero and Service Date is greater than today, reset to TODAY
  1. . I FDAYS=0&(SVDT>DT) S SVDT=$$DT^XLFDT
  1. . ; If non-zero and Service Date is later than the allowed
  1. . ; Payer Service Date range, reset the Service Date to latest
  1. . ; allowable date for the Payer
  1. . I FDAYS,(SVDT>$$FMADD^XLFDT($$DT^XLFDT,FDAYS)) D
  1. .. S SVDT=$$FMADD^XLFDT($$DT^XLFDT,FDAYS)
  1. Q
  1. ;
  1. ALL(DFN,VAR) ;Find all insurance data on a patient for the Appointment Extract
  1. ;Logic from ALL^IBCNS1
  1. ; Input:
  1. ; DFN = patient
  1. ; VAR = variable used to store output array
  1. ;
  1. ; Output:
  1. ; var(0) = number of entries insurance multiple
  1. ; var(x,0) = ^DPT(DFN,.312,x,0)
  1. ; var(x,1) = ^DPT(DFN,.312,x,1)
  1. ; var(x,2) = ^DPT(DFN,.312,x,2)
  1. ; var(x,3) = ^DPT(DFN,.312,x,3)
  1. ; var(x,4) = ^DPT(DFN,.312,x,4)
  1. ; var(x,5) = ^DPT(DFN,.312,x,5)
  1. ; var(x,7) = ^DPT(DFN,.312,x,7)
  1. ; var(x,355.3) = ^IBA(355.3,$p(var(x,0),"^",18),0)
  1. ;
  1. N ADT,IBSP,IBIENS,X
  1. S ADT=DT
  1. S X=0 F S X=$O(^DPT(DFN,.312,X)) Q:'X I $D(^(X,0)) D
  1. . I '$$CHK(^DPT(DFN,.312,X,0),DFN,X,ADT) Q
  1. . S @VAR@(0)=$G(@VAR@(0))+1
  1. . S @VAR@(X,0)=$$ZND^IBCNS1(DFN,X)
  1. . S @VAR@(X,1)=$G(^DPT(DFN,.312,X,1))
  1. . S @VAR@(X,2)=$G(^DPT(DFN,.312,X,2))
  1. . S @VAR@(X,3)=$G(^DPT(DFN,.312,X,3))
  1. . S @VAR@(X,4)=$G(^DPT(DFN,.312,X,4))
  1. . S @VAR@(X,5)=$G(^DPT(DFN,.312,X,5))
  1. . S @VAR@(X,7)=$G(^DPT(DFN,.312,X,7))
  1. . S IBIENS=+$P($G(^DPT(DFN,.312,X,0)),"^",18)
  1. . S @VAR@(X,355.3)=$G(^IBA(355.3,IBIENS,0))
  1. . S $P(@VAR@(X,355.3),U,3)=$$GET1^DIQ(355.3,IBIENS_",",2.01)
  1. . S $P(@VAR@(X,355.3),U,4)=$$GET1^DIQ(355.3,IBIENS_",",2.02)
  1. INSCHKQ ;
  1. Q
  1. ;
  1. CHK(X,PIEN,PINS,Z) ; Check patient policy - logic from CHK^IBCNS1
  1. ;Evaluate for inclusion in the Appointment Extract
  1. ;
  1. ; -- Input:
  1. ; X = Zero node of entry in insurance multiple (#2.312)
  1. ; PIEN = patient internal entry (#2)
  1. ; PINS = insurance multiple internal entry (#2.312)
  1. ; Z = Date to check
  1. ; -- Output:
  1. ; EVAL 1 = Evaluation for inclusion
  1. ; 0 = DO NOT Evaluate
  1. ;
  1. N GRP,EFFDT,EVAL,EXPDT,INSIEN
  1. ;Initialize variables
  1. S EVAL=0
  1. S EFFDT=$$GET1^DIQ(2.312,PINS_","_PIEN_",",8,"I")
  1. S EXPDT=$$GET1^DIQ(2.312,PINS_","_PIEN_",",3,"I")
  1. S GRP=$$GET1^DIQ(2.312,PINS_","_PIEN_",",.18,"I")
  1. ;
  1. ;Insurance Company entry doesn't exist
  1. S INSIEN=+X ;insurance company internal entry (#36)
  1. I $G(^DIC(36,INSIEN,0))="" G CHKQ
  1. ;Insurance Company Inactive
  1. I $$GET1^DIQ(36,INSIEN_",",.05,"I") G CHKQ
  1. ;Group Plan is Inactive
  1. I $$GET1^DIQ(355.3,GRP_",",.11,"I") G CHKQ
  1. ;
  1. ; - DO NOT Evaluate for inclusion
  1. ;Effective Date is in the future
  1. I EFFDT>Z S EVAL=0
  1. ;Expiration Date prior to today
  1. I EXPDT<Z S EVAL=0
  1. ;Effective Date is in the future ;Expiration Date is in the future
  1. I EFFDT>Z I EXPDT>Z S EVAL=0
  1. ;
  1. ; - Evaluate for inclusion
  1. ;Effective Date is today or past ;Expiration Date is today or null or future
  1. I EFFDT=Z!(EFFDT<Z) I ((EXPDT=Z)!(EXPDT>Z)!(EXPDT="")) S EVAL=1
  1. ;BAD Effective Date ;BLANK Expiration Date
  1. I $$VALIDDT^IBCNINSU(EFFDT)<0 I EXPDT="" S EVAL=1
  1. ;BLANK Effective Date ;BLANK Expiration Date
  1. I EFFDT="" I EXPDT="" S EVAL=1
  1. ;BLANK Effective Date ;Expiration Date in the future
  1. I EFFDT="" I EXPDT>Z S EVAL=1
  1. ;BAD Effective Date ;BAD Expiration Date
  1. I $$VALIDDT^IBCNINSU(EFFDT)<0 I $$VALIDDT^IBCNINSU(EXPDT)<0 S EVAL=1
  1. ;Effective Date is today or past ;BAD Expiration Date
  1. I EFFDT=Z!(EFFDT>Z) I $$VALIDDT^IBCNINSU(EXPDT)<0 S EVAL=1
  1. CHKQ ;
  1. Q EVAL
  1. ;
  1. TQUPDSV(DFN,PAYER,SRVDT,SUBID,GRPNUM) ; Update TQ service date for entries to be transmitted
  1. ; used by the Appointment Extract - logic from TQUPDSV^IBCNEUT5
  1. ;
  1. N CSPAN,CSRVDT,DA,SPAN,STS,SVDT,TQSUBID
  1. ;
  1. I ($G(DFN)="")!($G(PAYER)="")!($G(SRVDT)="") G TQUPDSVX
  1. ;
  1. ; Loop thru all entries in the TQ file (DO NOT CHANGE to DT-1 as SVDT)
  1. S SVDT=""
  1. F S SVDT=$O(^IBCN(365.1,"AD",DFN,PAYER,SVDT)) Q:'SVDT D
  1. . S DA=0
  1. . F S DA=$O(^IBCN(365.1,"AD",DFN,PAYER,SVDT,DA)) Q:'DA!($G(TQFOUND)) D
  1. .. ;Find entries for the same patient/payer/subscriber ID/group number combo
  1. .. ; Compare SUBID against the HL7 SUBSCRIBER ID FIELD stored in the TQ file
  1. .. ;Strip/remove any non-alph char's from the Subscriber ID in the TQ file
  1. .. S TQSUBID=$$STRIP^IBCNEDE3($$GET1^DIQ(365.1,DA_",",.16))
  1. .. I SUBID'=TQSUBID Q
  1. .. ; Compare GRPNUM against the GROUP NUMBER stored in the TQ file
  1. .. I GRPNUM'=$$GET1^DIQ(365.1,DA_",",1.03) Q
  1. .. ;
  1. .. S STS=$P($G(^IBCN(365.1,DA,0)),U,4) ; Get TQ Status
  1. .. ; If record is (1)Ready to Transmit or (6)Retry - update service date
  1. .. I (STS=1)!(STS=6) D Q
  1. ... ; Initialize variables
  1. ... I STS=1 S FSCSEND=1 ; (1)Ready to Transmit, send to FSC now
  1. ... I STS=6 S FSCSEND=0 ; (6)Retry, DO NOT send to FSC now
  1. ... S TQFOUND=1 ; valid entry found in the TQ file
  1. ... S TQENT=DA ; existing IEN in the TQ (need to send to FSC)
  1. ... ; SRVDT - new service date (from the appointment)
  1. ... ; CSRVDT - current service date for the existing TQ entry
  1. ... ; DT - today
  1. ... S CSRVDT=$P($G(^IBCN(365.1,DA,0)),U,12)
  1. ... ; If current service date is TODAY, do not update
  1. ... I CSRVDT=DT Q
  1. ... ; If the new service date is TODAY, update the current service date (date in TQ entry) to TODAY
  1. ... I SRVDT=DT S CSRVDT=DT D SAVETQ^IBCNEUT2(DA,CSRVDT) Q
  1. ... ; If the current service day is in the past, update it to the new service date
  1. ... I CSRVDT<DT S CSRVDT=SRVDT D SAVETQ^IBCNEUT2(DA,CSRVDT) Q
  1. ... ; If both the current and new service dates are in the future, update the current
  1. ... ; service date to whichever date is closest to TODAY
  1. ... I (CSRVDT>DT)&(SRVDT>DT) D Q
  1. .... S CSPAN=$$FMDIFF^XLFDT(CSRVDT,DT,1),SPAN=$$FMDIFF^XLFDT(SRVDT,DT,1)
  1. .... I CSPAN<SPAN D SAVETQ^IBCNEUT2(DA,CSRVDT) Q
  1. .... I SPAN<CSPAN D SAVETQ^IBCNEUT2(DA,SRVDT) Q
  1. TQUPDSVX ;TQUPDSV exit
  1. Q
  1. ;
  1. TQCHKS(DFN,PAYER,SRVDT,SUBID,GRPNUM,FRESHNESS) ; Looks at the TQ file for an existing entry
  1. ; checks to see if a new entry can be added to the TQ - used by the Appointment Extract
  1. ;
  1. N DA,STS,SVDT,TQSUBID
  1. ;
  1. I ($G(DFN)="")!($G(PAYER)="")!($G(SRVDT)="") G TQCHKSX
  1. ;
  1. ; Loop thru ALL entries in the TQ file
  1. S SVDT=""
  1. F S SVDT=$O(^IBCN(365.1,"AD",DFN,PAYER,SVDT)) Q:'SVDT D
  1. . S DA=0
  1. . F S DA=$O(^IBCN(365.1,"AD",DFN,PAYER,SVDT,DA)) Q:'DA D
  1. .. ;Find entries for the same patient/payer/subscriber ID/group number combo
  1. .. ; Compare SUBID against the HL7 SUBSCRIBER ID FIELD stored in the TQ file
  1. .. ;Strip/remove any non-alph char's from the Subscriber ID in the TQ file
  1. .. S TQSUBID=$$STRIP^IBCNEDE3($$GET1^DIQ(365.1,DA_",",.16))
  1. .. I SUBID'=TQSUBID Q
  1. .. ; Compare GRPNUM against the GROUP NUMBER stored in the TQ file
  1. .. I GRPNUM'=$$GET1^DIQ(365.1,DA_",",1.03) Q
  1. .. S STS=$P($G(^IBCN(365.1,DA,0)),U,4) ; Get TQ Status
  1. .. ; If entry is (2)Transmitted or (3)Response Received - check freshness days
  1. .. I (STS=2)!(STS=3) D
  1. ... ; ADDTQ = 0-do not add to TQ / 1-add to TQ file
  1. ... S ADDTQ=$$ADDTQ(DFN,PAYER,SUBID,GRPNUM,SRVICEDT,FRESHNESS) ; within freshness days
  1. ... Q
  1. ;
  1. TQCHKSX ;TQCHKS exit
  1. Q
  1. ;
  1. ADDTQ(DFN,PAYER,SUBID,GRPNUM,SRVDT,FDAYS) ; Function - Returns flag (0/1)
  1. ; used by the Appointment Extract - logic from ADDTQ^IBCNEUT5
  1. ; 1 - TQ File entry can be added as the service date for the patient
  1. ; and payer >= MAX TQ service date + Freshness Days
  1. ; 0 - otherwise
  1. ;
  1. ; Input:
  1. ; DFN - Patient DFN (File #2)
  1. ; PAYER - Payer IEN (File #365.12)
  1. ; SUBID - Subscriber ID
  1. ; GRPNUM - Group Number
  1. ; SRVDT - Service Date for potential TQ entry
  1. ; FDAYS - Freshness Days param (by extract type)
  1. ;
  1. N MAXDT
  1. S ADDTQ=1
  1. ;
  1. I ($G(DFN)="")!($G(SRVDT)="")!($G(FDAYS)="")!($G(PAYER)="") S ADDTQ=0 G ADDTQX
  1. ;
  1. ; MAX TQ Service Date
  1. S MAXDT=$$TQMAXSV(DFN,PAYER,SUBID,GRPNUM)
  1. I MAXDT="" G ADDTQX
  1. ; If Service Date < Max Service Date + Freshness Days, do not add
  1. I SRVDT'>$$FMADD^XLFDT(MAXDT,FDAYS) S ADDTQ=0
  1. ;
  1. ADDTQX ; ADDTQ exit pt
  1. Q ADDTQ
  1. ;
  1. TQMAXSV(DFN,PAYER,SUBID,GRPNUM) ; Returns MAX(TQ Service Date) for Patient & Payer
  1. ;used by the Appointment Extract - logic from TQMAXSV^IBCNEUT5
  1. ; Input:
  1. ; DFN - Patient DFN (#2)
  1. ; PAYER - Payer IEN (#365.12)
  1. ; SUBID - Subscriber ID
  1. ; GRPNUM - Group Number
  1. ;
  1. ; Output:
  1. ; TQMAXSV - MAX (most recent) service date from TQ entry for Patient & Payer
  1. ;
  1. N TQMAXSV
  1. S TQMAXSV=""
  1. I ($G(DFN)="")!'$G(PAYER) G TQMAXSVX
  1. ;
  1. N IBTQS,IENS,LASTBYP,STATLIST,TQIEN,TQSUBID
  1. ; This is the list of transmission statuses that are to be ignored:
  1. ; 4=Hold (IB*506 removed this status from occurring) / 5=Communication Failure / 7=Cancelled
  1. S STATLIST=",4,5,7,"
  1. ;
  1. S LASTBYP=""
  1. F S LASTBYP=$O(^IBCN(365.1,"AD",DFN,PAYER,LASTBYP)) Q:LASTBYP="" D
  1. . S TQIEN=""
  1. . F S TQIEN=$O(^IBCN(365.1,"AD",DFN,PAYER,LASTBYP,TQIEN)) Q:TQIEN="" D
  1. .. ;Find entries for the same patient/payer/subscriber ID/group number combo
  1. .. ; Compare SUBID against the HL7 SUBSCRIBER ID FIELD stored in the TQ file
  1. .. ;Strip/remove any non-alph char's from the Subscriber ID in the TQ file
  1. .. S TQSUBID=$$STRIP^IBCNEDE3($$GET1^DIQ(365.1,TQIEN_",",.16))
  1. .. I SUBID'=TQSUBID Q
  1. .. ; Compare GRPNUM against the GROUP NUMBER stored in the TQ file
  1. .. I GRPNUM'=$$GET1^DIQ(365.1,TQIEN_",",1.03) Q
  1. .. S IBTQS=+$$GET1^DIQ(365.1,TQIEN_",",.04,"I") ; TQ STATUS
  1. .. I IBTQS,($F(STATLIST,","_IBTQS_",")) Q ; If TQ STATUS is contained in STATLIST, quit
  1. .. I LASTBYP>TQMAXSV S TQMAXSV=LASTBYP
  1. ;
  1. TQMAXSVX ;TQMAXSV exit
  1. Q TQMAXSV
  1. ;
  1. BFEXIST(DFN,INSNAME,SUBID,GRPNUM) ;Checks for the existence in the Buffer
  1. ;used by the Appointment Extract - logic from BFEXIST^IBCNEUT5
  1. ;INPUT:
  1. ; DFN - Patient DFN
  1. ; INSNAME - Insurance Company Name File 36 - Field .01
  1. ; SUBID - Subscriber ID
  1. ; GRPNUM - Group Number
  1. ;
  1. ;OUTPUT:
  1. ; 1 - if an entry exists in the Buffer with the same DFN/INSNAME/SUBID/GRPNUM
  1. ; 0 - if not found in the Buffer
  1. ;
  1. ; This tag is being used by the Appointment Extract
  1. ;
  1. N BSUBID,BUFFNAME,EXIST,IEN
  1. S EXIST=0
  1. S INSNAME=$$UP^XLFSTR(INSNAME),INSNAME=$$TRIM^XLFSTR(INSNAME)
  1. I ('DFN)!(INSNAME="") G BFEXIT
  1. ;
  1. S IEN=0
  1. F S IEN=$O(^IBA(355.33,"C",DFN,IEN)) Q:'IEN!EXIST D
  1. . ; Quit if status is NOT 'Entered'
  1. . I $P($G(^IBA(355.33,IEN,0)),U,4)'="E" Q
  1. . ; Quit if Ins Buffer Ins Co Name (trimmed) is NOT EQUAL to
  1. . ; the Ins Co Name parameter (trimmed)
  1. . S BUFFNAME=$$TRIM^XLFSTR($P($G(^IBA(355.33,IEN,20)),U))
  1. . I $$UP^XLFSTR(BUFFNAME)'=INSNAME Q
  1. . ; Does the SUBID and GRPNUM match what's stored in the Buffer
  1. . ;Strip/remove any non-alph char's from the Subscriber ID in the Buffer
  1. . S BSUBID=$$STRIP^IBCNEDE3($P($G(^IBA(355.33,IEN,90)),U,3))
  1. . I SUBID'="",BSUBID'=SUBID Q
  1. . I GRPNUM'="",($P($G(^IBA(355.33,IEN,90)),U,2))'=GRPNUM Q
  1. . ; Match found
  1. . S EXIST=1
  1. . Q
  1. BFEXIT ;BFEXIST exit
  1. Q EXIST