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