- 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 Feb 18, 2025@23:40:51 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