- IBCNEUT5 ;DAOU/ALA - eIV MISC. UTILITIES ; 20-JUN-2002
- ;;2.0;INTEGRATED BILLING;**184,284,271,416,621,602,668,702**;21-MAR-94;Build 53
- ;;Per VHA Directive 6402, this routine should not be modified.
- ;
- ;**Program Description**
- ; This program contains some general utilities or functions
- ;
- Q
- ;
- MSG(MGRP,XMSUB,XMTEXT,FROMFLAG,XMY) ; Send a MailMan Message
- ;
- ; Input Parameters
- ; MGRP = Mailgroup Name (optional)
- ; XMSUB = Subject Line (required)
- ; XMTEXT = Message Text Array Name in open format: "MSG(" (required)
- ; FROMFLAG = Flag indicating from whom the message is sent (optional)
- ; false/undefined: from the specific, non-human eIV user
- ; true: from the actual user (DUZ)
- ; XMY = recipients array; pass by reference (optional)
- ; The possible recipients are the sender, the Mail Group in the
- ; first parameter, and anybody else already defined in the XMY
- ; array when this parameter is used.
- ;
- ; New MailMan variables and also some FileMan variables. The FileMan
- ; variables are used and not cleaned up when sending to external
- ; internet addresses.
- NEW DIFROM,XMDUZ,XMDUN,XMZ,XMMG,XMSTRIP,XMROU,XMYBLOB
- NEW D0,D1,D2,DG,DIC,DICR,DISYS,DIW
- NEW TMPSUB,TMPTEXT,TMPY,XX
- ;
- I $G(FROMFLAG),$G(DUZ) S XMDUZ=DUZ
- E S XMDUZ="eIV INTERFACE (IB)"
- I $G(MGRP)'="" S XMY("G."_MGRP)=""
- ; If no recipients are defined, send to postmaster
- I '$D(XMY) S XMY(.5)=""
- I $G(DUZ) S XMY(DUZ)=""
- ; Store off subject, array reference and array of recipients
- S TMPSUB=XMSUB,TMPTEXT=XMTEXT
- M TMPY=XMY
- D ^XMD
- ;
- ; Error logic
- ; If there's an error message and the message was not originally sent
- ; to the postmaster, then send a message to the postmaster with this
- ; error message.
- ;
- I $D(XMMG),'$D(TMPY(.5)) D
- . S XMY(.5)=""
- . S XMTEXT=TMPTEXT,XMSUB="MailMan Error"
- . ; Add XMMG error message as the first line of the message
- . S XX=999999
- . F S XX=$O(@(XMTEXT_"XX)"),-1) Q:'XX S @(XMTEXT_"XX+3)")=@(XMTEXT_"XX)")
- . S @(XMTEXT_"1)")=" MailMan Error: "_XMMG
- . S @(XMTEXT_"2)")="Original Subject: "_TMPSUB
- . S @(XMTEXT_"3)")="------Original Message------"
- . D ^XMD
- . Q
- Q
- ;
- ;
- BFEXIST(DFN,INSNAME) ; Function returns 1 if an Entered Ins Buffer File
- ; entry exists with the same DFN and INSNAME, otherwise it returns a 0
- ;
- ; DFN - Patient DFN
- ; INSNAME - Insurance Company Name File 36 - Field .01
- ;
- NEW BUFFNAME,EXIST,IEN ; IB*2.0*602
- S EXIST=0
- S INSNAME=$$UP^XLFSTR(INSNAME),INSNAME=$$TRIM^XLFSTR(INSNAME) ; trimmed *IB*2.0*602
- 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)
- . ; IB*2.0*602 in case the input template for that field changes in the future (TRIM & UP)
- . S BUFFNAME=$$TRIM^XLFSTR($P($G(^IBA(355.33,IEN,20)),U))
- . I $$UP^XLFSTR(BUFFNAME)'=INSNAME Q
- . ; Match found
- . S EXIST=1
- . Q
- BFEXIT ;
- Q EXIST
- ;
- ;
- MGRP() ; Get the Mail Group for the eIV Interface - IB Site Parameters (51.04)
- Q $$GET1^DIQ(350.9,"1,",51.04,"E")
- ;
- ;
- PYRAPP(APP,PAYERIEN) ; Get the Payer Application multiple IEN
- ; based on the payer application name and payer ien.
- ;
- NEW MIEN,APPIEN,DISYS
- S MIEN=""
- S APPIEN=$$FIND1^DIC(365.13,,"X",APP,"B")
- I 'APPIEN G PYRAPPX
- I '$G(PAYERIEN) G PYRAPPX
- S MIEN=$O(^IBE(365.12,PAYERIEN,1,"B",APPIEN,""))
- PYRAPPX ;
- Q MIEN
- ;
- ;
- ACTAPP(IEN) ; Active payer applications
- ;IB*668/TAZ - Changed Active to Enabled. Changed location of DEACTIVATED?
- ; This function will return 1 if any of the payer applications for
- ; this payer (being passed in by the payer IEN) are NOT deactivated.
- ; This should not be confused with the other payer application fields
- ; such as national enabled or local enabled The deactivated field is
- ; the .07 field at the payer level.
- ;
- ; This function is invoked by the FileMan data dictionary as a screen
- ; for the Payer field (#3.1) in the Insurance company file (#36).
- ;
- ;IB*2.0*668/TAZ - The utility will now call the new PYRDEACT utility. The
- ; logic in the new utility returns 1 if the Payer is deactivated
- ; and 0 if is activated. This is the opposite of this utility;
- ; therefore we need to flip the logic and check for NOT Deactivated.
- Q '$$PYRDEACT^IBCNINSU(IEN)
- ;
- ;NEW APPIEN,ACTAPP,APPDATA
- ;S APPIEN=0,ACTAPP="",IEN=+$G(IEN)
- ;F S APPIEN=$O(^IBE(365.12,IEN,1,APPIEN)) Q:'APPIEN D Q:ACTAPP
- ;. S APPDATA=$G(^IBE(365.12,IEN,1,APPIEN,0))
- ;. I $P(APPDATA,U,11) Q
- ;. I $P(APPDATA,U,12) Q
- ;. S ACTAPP=1
- ;. Q
- ;Q ACTAPP
- ;
- ADDTQ(DFN,PAYER,SRVDT,FDAYS,EICDEXT) ; Function - Returns flag (0/1)
- ; 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)
- ; SRVDT - Service dt for potential TQ entry
- ; FDAYS - Freshness Days param (by extract type)
- ; EICDEXT - 1 OR 0 (Is this from the EICD extract?) ;IB*2.0*621 - Renamed parameter to EICD extract
- ;
- N ADDTQ,MAXDT
- ;
- S ADDTQ=1
- I ($G(DFN)="")!($G(SRVDT)="")!($G(FDAYS)="") S ADDTQ=0 G ADDTQX
- I ($G(EICDEXT)="")!($G(PAYER)="") S ADDTQ=0 G ADDTQX
- ;
- ; MAX TQ Service Date
- S MAXDT=$$TQMAXSV(DFN,$G(PAYER),$G(EICDEXT))
- 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
- ;
- TQUPDSV(DFN,PAYER,SRVDT) ; Update service dates & freshness dates for TQ
- ; entries awaiting transmission
- ;
- N SVDT,STS,ERACT,CSRVDT,CSPAN,SPAN,DA,HL7IEN,RIEN
- ;
- I ($G(DFN)="")!($G(PAYER)="")!($G(SRVDT)="") G TQUPDSVX
- ;
- ; Loop thru all inquiries to be transmitted to update the service date
- ; Statuses: Ready to Transmit(1), Hold(4) and Retry(6)
- 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
- .. ; TQ Status
- .. S STS=$P($G(^IBCN(365.1,DA,0)),U,4)
- .. ; Check to see if record is still scheduled to be transmitted.
- .. ; If so, update the service date if the new service date and current
- .. ; service date are both in the past or future and the new service
- .. ; date is closer to Today. Also, if the current service date is in
- .. ; the future and the new service date is in the past, update with the
- .. ; new service date.
- .. ; If not Ready to Transmit(1), Hold(4) and Retry(6), quit
- .. I STS'=1,STS'=4,STS'=6 Q
- .. ; If Hold and last Response returned Error Action - Please resubmit
- .. ; Original Transaction (P) - do not update
- .. I STS=4 S ERACT="" D I ERACT="P" Q
- .. . ; Last msg sent
- .. . S HL7IEN=$O(^IBCN(365.1,DA,2," "),-1) Q:'HL7IEN
- .. . ; Assoc eIV Response IEN
- .. . S RIEN=$P($G(^IBCN(365.1,DA,2,HL7IEN,0)),U,3) Q:'RIEN
- .. . ; Error Action IEN (365.018)
- .. . S ERACT=$P($G(^IBCN(365,RIEN,1)),U,15) Q:'ERACT
- .. . S ERACT=$P($G(^IBE(365.018,ERACT,0)),U,1)
- .. ;
- .. ; Current service date for TQ entry
- .. S CSRVDT=$P($G(^IBCN(365.1,DA,0)),U,12)
- .. ; If current service date is today (DT), do not update
- .. I CSRVDT=DT Q
- .. ; If new service date is in the future and current service date is in
- .. ; the past, do not update
- .. I SRVDT>DT,CSRVDT<DT Q
- .. ; If new service date is today, update
- .. I SRVDT=DT D SAVETQ^IBCNEUT2(DA,SRVDT),SAVFRSH(DA,+$$FMDIFF^XLFDT(SRVDT,CSRVDT,1)) Q
- .. ; If both current and new service dates are in the past or future,
- .. ; only update, when new service date is closer to today (DT).
- .. I ((CSRVDT<DT)&(SRVDT<DT))!((CSRVDT>DT)&(SRVDT>DT)) D Q
- .. . S CSPAN=$$FMDIFF^XLFDT(CSRVDT,DT,1),SPAN=$$FMDIFF^XLFDT(SRVDT,DT,1)
- .. . I CSPAN<0 S CSPAN=-CSPAN
- .. . I SPAN<0 S SPAN=-SPAN
- .. . I SPAN<CSPAN D SAVETQ^IBCNEUT2(DA,SRVDT),SAVFRSH(DA,+$$FMDIFF^XLFDT(SRVDT,CSRVDT,1))
- .. ; If new service date is in the past and current service date is in
- .. ; the future, update
- .. I SRVDT<CSRVDT D SAVETQ^IBCNEUT2(DA,SRVDT),SAVFRSH(DA,+$$FMDIFF^XLFDT(SRVDT,CSRVDT,1)) Q
- .. Q
- TQUPDSVX ; TQUPDSV exit pt
- Q
- ;
- TQMAXSV(DFN,PAYER,EICDEXT) ; Returns MAX(TQ Service Date) for Patient & Payer
- ; Input:
- ; DFN - Patient DFN (2)
- ; PAYER - Payer IEN (365.12)
- ; EICDEXT - 1 OR 0 (Is this from the EICD extract?)
- ;
- ; Output:
- ; TQMAXSV - MAX (most recent) service date from TQ entry for Patient &
- ; Payer
- ;
- ; IB*621 reworked this function to ignore TQ entries with statuses of
- ; "Response Received" for EICD for which the Response indicated a "Clearinghouse Timeout"
- N TQMAXSV
- S TQMAXSV=""
- ;IB*668/TAZ - Added check for PAYER and quit if null
- I $G(DFN)=""!'$G(PAYER) G TQMAXSVX
- ;
- N ERTXT,IBSKIP,IBTQS,IENS,LASTBYP,STATLIST,TQIEN
- ; This is the list of statuses that are to be ignored for EICD extract only
- ; 3=Response Received
- S STATLIST=",3,"
- ;
- 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
- .. S IBSKIP=0
- .. I EICDEXT D Q:IBSKIP
- .. . S IBTQS=+$$GET1^DIQ(365.1,TQIEN_",",.04,"I") ; TQ Transmission Status
- .. . I IBTQS,'($F(STATLIST,","_IBTQS_",")) Q
- .. . S IENS="1,"_TQIEN_",",RIEN=$$GET1^DIQ(365.16,IENS,.03,"I")
- .. . S ERTXT=$$GET1^DIQ(365,RIEN_",",4.01) I $$UP^XLFSTR(ERTXT)["TIMEOUT" S IBSKIP=1 ; keep looking
- .. I LASTBYP>TQMAXSV S TQMAXSV=LASTBYP
- ;
- TQMAXSVX ; TQMAXSV exit pt
- Q TQMAXSV
- ;
- SAVFRSH(TQIEN,DTDIFF) ; Update TQ freshness date based on service date diff
- ;
- N DIE,DA,FDT,DR,D,D0,DI,DIC,DQ,X
- I $G(TQIEN)="" Q
- S FDT=$P($G(^IBCN(365.1,TQIEN,0)),U,17)
- ; Note - will only update if FDT > 0.
- S FDT=$$FMADD^XLFDT(FDT,+DTDIFF)
- S DIE="^IBCN(365.1,",DA=TQIEN,DR=".17////"_FDT
- D ^DIE
- Q
- ;
- EPAT(MSG) ; Check for qualified patient for EICD Identification
- ;INPUT:
- ; MSG - Error Message used in IBCNEQU1
- ;
- N OK
- S OK=0
- I +$$GET1^DIQ(2,DFN_",",.6,"I") G EPATX ;Test Patient?
- I (+$$GET1^DIQ(2,DFN_",",2001,"I")>FRESHDT) S:$D(MSG) MSG=2 G EPATX ;Too soon
- I +$$GET1^DIQ(2,DFN_",",.351,"I") G EPATX ;Patient Deceased
- I $$GET1^DIQ(2,DFN_",",.115)="" G EPATX ;State cannot be null
- I $$GET1^DIQ(2,DFN_",",.116)="" G EPATX ;Zip Code cannot be null
- ;
- S OK=1
- EPATX ; Exit
- Q OK
- ;
- EPAYR() ; Check EICD Payer
- ;IB*702/TAZ Moved Payer checks from IBCNEDE4 to EPAYR^IBCNEUT5 (this is a new tag)
- N IENS,OK,PAYER,PIEN
- S OK=0
- ;
- S PIEN=+$$GET1^DIQ(350.9,"1,",51.31,"I") ; EICD PAYER
- I 'PIEN G EPAYRX
- ;
- D PAYER^IBCNINSU(PIEN,"EIV",,"I",.PAYER)
- S IENS=$O(PAYER(365.121,"")) I IENS']"" G EPAYRX ; No EIV Data for this Payer
- I '$G(PAYER(365.121,IENS,.02,"I")) G EPAYRX ; Not "NATIONALLY ENABLED"
- I '$G(PAYER(365.121,IENS,.03,"I")) G EPAYRX ; Not "LOCALLY ENABLED"
- ;
- S OK=PIEN
- ;
- EPAYRX ; Exit
- Q OK
- ;
- EACTPOL() ; Check for active policy for EICD Identification
- N EINS,IBACTV,IBEFF,IBEXP,IBIDX,IBINCO,IBINSNM,IBPLAN,IBTOP,IBTOPIEN,IBWK1,IBWK2
- ;
- ; gather the non-active insurance company names
- ; we will strip all blanks from the names, so dashes ('-') are treated properly for a compare
- F IBIDX=2:1 S IBINCO=$P($T(NAINSCO+IBIDX),";;",2) Q:IBINCO="" S IBINSNM($TR(IBINCO," ",""))=""
- ;
- ; gather the non-active type of plan iens
- F IBIDX=2:1 S IBPLAN=$P($T(NATPLANS+IBIDX),";;",2) Q:IBPLAN="" D
- . S IBTOP=+$$FIND1^DIC(355.1,,"BQX",IBPLAN) Q:'IBTOP
- . S IBTOPIEN(IBTOP)=""
- ;
- ; skip any patient with "active" insurance
- S IBACTV=0
- S IBIDX=0 ; check policies for "active" insurance
- F S IBIDX=$O(^DPT(DFN,.312,IBIDX)) Q:'IBIDX D I IBACTV Q
- . S EINS=IBIDX_","_DFN_","
- . S IBEFF=+$$GET1^DIQ(2.312,EINS,8,"I") I 'IBEFF Q ; No effective date
- . S IBEXP=+$$GET1^DIQ(2.312,EINS,3,"I") I IBEXP,(IBEXP<(DT)) Q ; expired
- . ;
- . ; Check for Non-active Insurance companies
- . S INSNM=$TR($$GET1^DIQ(2.312,EINS,.01,"E")," ","") ; insurance company name
- . I INSNM="" Q ; bad pointer to INSURANCE COMPANY File (#36)
- . I $D(IBINSNM(INSNM)) Q
- . ;
- . ; Check for Non-active Type of Plan
- . S IBPLAN=$$GET1^DIQ(2.312,EINS,.18,"I") ; group plan ien
- . S IBTOP=$$GET1^DIQ(355.3,IBPLAN_",",.09,"I") ; type of plan ien
- . I IBTOP'="",$D(IBTOPIEN(IBTOP)) Q
- . ;
- . ; Insurance is considered active at this point
- . S IBACTV=1 Q ; active
- EACTPOLX ; Exit
- Q IBACTV
- ;
- NAINSCO ; Non-active Insurance companies
- ;
- ;;MEDICARE (WNR)
- ;;VACAA-WNR
- ;;CAMP LEJEUNE - WNR
- ;;IVF - WNR
- ;;VHA DIRECTIVE 1029 WNR
- ;
- NATPLANS ; Non-active Type of Plans
- ;
- ;;ACCIDENT AND HEALTH INSURANCE
- ;;AUTOMOBILE
- ;;AVIATION TRIP INSURANCE
- ;;CATASTROPHIC INSURANCE
- ;;CHAMPVA
- ;;COINSURANCE
- ;;DENTAL INSURANCE
- ;;DUAL COVERAGE
- ;;INCOME PROTECTION (INDEMNITY)
- ;;KEY-MAN HEALTH INSURANCE
- ;;LABS, PROCEDURES, X-RAY, ETC. (ONLY)
- ;;MEDI-CAL
- ;;MEDICAID
- ;;MEDICARE (M)
- ;;MEDICARE/MEDICAID (MEDI-CAL)
- ;;MENTAL HEALTH
- ;;NO-FAULT INSURANCE
- ;;PRESCRIPTION
- ;;QUALIFIED IMPAIRMENT INSURANCE
- ;;SPECIAL CLASS INSURANCE
- ;;SPECIAL RISK INSURANCE
- ;;SPECIFIED DISEASE INSURANCE
- ;;Substance abuse only
- ;;TORT FEASOR
- ;;TRICARE
- ;;TRICARE SUPPLEMENTAL
- ;;VA SPECIAL CLASS
- ;;VISION
- ;;WORKERS' COMPENSATION INSURANCE
- ;
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEUT5 13547 printed Jan 18, 2025@03:16:46 Page 2
- IBCNEUT5 ;DAOU/ALA - eIV MISC. UTILITIES ; 20-JUN-2002
- +1 ;;2.0;INTEGRATED BILLING;**184,284,271,416,621,602,668,702**;21-MAR-94;Build 53
- +2 ;;Per VHA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;**Program Description**
- +5 ; This program contains some general utilities or functions
- +6 ;
- +7 QUIT
- +8 ;
- MSG(MGRP,XMSUB,XMTEXT,FROMFLAG,XMY) ; Send a MailMan Message
- +1 ;
- +2 ; Input Parameters
- +3 ; MGRP = Mailgroup Name (optional)
- +4 ; XMSUB = Subject Line (required)
- +5 ; XMTEXT = Message Text Array Name in open format: "MSG(" (required)
- +6 ; FROMFLAG = Flag indicating from whom the message is sent (optional)
- +7 ; false/undefined: from the specific, non-human eIV user
- +8 ; true: from the actual user (DUZ)
- +9 ; XMY = recipients array; pass by reference (optional)
- +10 ; The possible recipients are the sender, the Mail Group in the
- +11 ; first parameter, and anybody else already defined in the XMY
- +12 ; array when this parameter is used.
- +13 ;
- +14 ; New MailMan variables and also some FileMan variables. The FileMan
- +15 ; variables are used and not cleaned up when sending to external
- +16 ; internet addresses.
- +17 NEW DIFROM,XMDUZ,XMDUN,XMZ,XMMG,XMSTRIP,XMROU,XMYBLOB
- +18 NEW D0,D1,D2,DG,DIC,DICR,DISYS,DIW
- +19 NEW TMPSUB,TMPTEXT,TMPY,XX
- +20 ;
- +21 IF $GET(FROMFLAG)
- IF $GET(DUZ)
- SET XMDUZ=DUZ
- +22 IF '$TEST
- SET XMDUZ="eIV INTERFACE (IB)"
- +23 IF $GET(MGRP)'=""
- SET XMY("G."_MGRP)=""
- +24 ; If no recipients are defined, send to postmaster
- +25 IF '$DATA(XMY)
- SET XMY(.5)=""
- +26 IF $GET(DUZ)
- SET XMY(DUZ)=""
- +27 ; Store off subject, array reference and array of recipients
- +28 SET TMPSUB=XMSUB
- SET TMPTEXT=XMTEXT
- +29 MERGE TMPY=XMY
- +30 DO ^XMD
- +31 ;
- +32 ; Error logic
- +33 ; If there's an error message and the message was not originally sent
- +34 ; to the postmaster, then send a message to the postmaster with this
- +35 ; error message.
- +36 ;
- +37 IF $DATA(XMMG)
- IF '$DATA(TMPY(.5))
- Begin DoDot:1
- +38 SET XMY(.5)=""
- +39 SET XMTEXT=TMPTEXT
- SET XMSUB="MailMan Error"
- +40 ; Add XMMG error message as the first line of the message
- +41 SET XX=999999
- +42 FOR
- SET XX=$ORDER(@(XMTEXT_"XX)"),-1)
- if 'XX
- QUIT
- SET @(XMTEXT_"XX+3)")=@(XMTEXT_"XX)")
- +43 SET @(XMTEXT_"1)")=" MailMan Error: "_XMMG
- +44 SET @(XMTEXT_"2)")="Original Subject: "_TMPSUB
- +45 SET @(XMTEXT_"3)")="------Original Message------"
- +46 DO ^XMD
- +47 QUIT
- End DoDot:1
- +48 QUIT
- +49 ;
- +50 ;
- BFEXIST(DFN,INSNAME) ; Function returns 1 if an Entered Ins Buffer File
- +1 ; entry exists with the same DFN and INSNAME, otherwise it returns a 0
- +2 ;
- +3 ; DFN - Patient DFN
- +4 ; INSNAME - Insurance Company Name File 36 - Field .01
- +5 ;
- +6 ; IB*2.0*602
- NEW BUFFNAME,EXIST,IEN
- +7 SET EXIST=0
- +8 ; trimmed *IB*2.0*602
- SET INSNAME=$$UP^XLFSTR(INSNAME)
- SET INSNAME=$$TRIM^XLFSTR(INSNAME)
- +9 IF ('DFN)!(INSNAME="")
- GOTO BFEXIT
- +10 ;
- +11 SET IEN=0
- +12 FOR
- SET IEN=$ORDER(^IBA(355.33,"C",DFN,IEN))
- if 'IEN!EXIST
- QUIT
- Begin DoDot:1
- +13 ; Quit if status is NOT 'Entered'
- +14 IF $PIECE($GET(^IBA(355.33,IEN,0)),U,4)'="E"
- QUIT
- +15 ; Quit if Ins Buffer Ins Co Name (trimmed) is NOT EQUAL to
- +16 ; the Ins Co Name parameter (trimmed)
- +17 ; IB*2.0*602 in case the input template for that field changes in the future (TRIM & UP)
- +18 SET BUFFNAME=$$TRIM^XLFSTR($PIECE($GET(^IBA(355.33,IEN,20)),U))
- +19 IF $$UP^XLFSTR(BUFFNAME)'=INSNAME
- QUIT
- +20 ; Match found
- +21 SET EXIST=1
- +22 QUIT
- End DoDot:1
- BFEXIT ;
- +1 QUIT EXIST
- +2 ;
- +3 ;
- MGRP() ; Get the Mail Group for the eIV Interface - IB Site Parameters (51.04)
- +1 QUIT $$GET1^DIQ(350.9,"1,",51.04,"E")
- +2 ;
- +3 ;
- PYRAPP(APP,PAYERIEN) ; Get the Payer Application multiple IEN
- +1 ; based on the payer application name and payer ien.
- +2 ;
- +3 NEW MIEN,APPIEN,DISYS
- +4 SET MIEN=""
- +5 SET APPIEN=$$FIND1^DIC(365.13,,"X",APP,"B")
- +6 IF 'APPIEN
- GOTO PYRAPPX
- +7 IF '$GET(PAYERIEN)
- GOTO PYRAPPX
- +8 SET MIEN=$ORDER(^IBE(365.12,PAYERIEN,1,"B",APPIEN,""))
- PYRAPPX ;
- +1 QUIT MIEN
- +2 ;
- +3 ;
- ACTAPP(IEN) ; Active payer applications
- +1 ;IB*668/TAZ - Changed Active to Enabled. Changed location of DEACTIVATED?
- +2 ; This function will return 1 if any of the payer applications for
- +3 ; this payer (being passed in by the payer IEN) are NOT deactivated.
- +4 ; This should not be confused with the other payer application fields
- +5 ; such as national enabled or local enabled The deactivated field is
- +6 ; the .07 field at the payer level.
- +7 ;
- +8 ; This function is invoked by the FileMan data dictionary as a screen
- +9 ; for the Payer field (#3.1) in the Insurance company file (#36).
- +10 ;
- +11 ;IB*2.0*668/TAZ - The utility will now call the new PYRDEACT utility. The
- +12 ; logic in the new utility returns 1 if the Payer is deactivated
- +13 ; and 0 if is activated. This is the opposite of this utility;
- +14 ; therefore we need to flip the logic and check for NOT Deactivated.
- +15 QUIT '$$PYRDEACT^IBCNINSU(IEN)
- +16 ;
- +17 ;NEW APPIEN,ACTAPP,APPDATA
- +18 ;S APPIEN=0,ACTAPP="",IEN=+$G(IEN)
- +19 ;F S APPIEN=$O(^IBE(365.12,IEN,1,APPIEN)) Q:'APPIEN D Q:ACTAPP
- +20 ;. S APPDATA=$G(^IBE(365.12,IEN,1,APPIEN,0))
- +21 ;. I $P(APPDATA,U,11) Q
- +22 ;. I $P(APPDATA,U,12) Q
- +23 ;. S ACTAPP=1
- +24 ;. Q
- +25 ;Q ACTAPP
- +26 ;
- ADDTQ(DFN,PAYER,SRVDT,FDAYS,EICDEXT) ; Function - Returns flag (0/1)
- +1 ; 1 - TQ File entry can be added as the service date for the patient
- +2 ; and payer >= MAX TQ service date + Freshness Days
- +3 ; 0 - otherwise
- +4 ;
- +5 ; Input:
- +6 ; DFN - Patient DFN (File #2)
- +7 ; PAYER - Payer IEN (File #365.12)
- +8 ; SRVDT - Service dt for potential TQ entry
- +9 ; FDAYS - Freshness Days param (by extract type)
- +10 ; EICDEXT - 1 OR 0 (Is this from the EICD extract?) ;IB*2.0*621 - Renamed parameter to EICD extract
- +11 ;
- +12 NEW ADDTQ,MAXDT
- +13 ;
- +14 SET ADDTQ=1
- +15 IF ($GET(DFN)="")!($GET(SRVDT)="")!($GET(FDAYS)="")
- SET ADDTQ=0
- GOTO ADDTQX
- +16 IF ($GET(EICDEXT)="")!($GET(PAYER)="")
- SET ADDTQ=0
- GOTO ADDTQX
- +17 ;
- +18 ; MAX TQ Service Date
- +19 SET MAXDT=$$TQMAXSV(DFN,$GET(PAYER),$GET(EICDEXT))
- +20 IF MAXDT=""
- GOTO ADDTQX
- +21 ; If Service Date < Max Service Date + Freshness Days, do not add
- +22 IF SRVDT'>$$FMADD^XLFDT(MAXDT,FDAYS)
- SET ADDTQ=0
- +23 ;
- ADDTQX ; ADDTQ exit pt
- +1 QUIT ADDTQ
- +2 ;
- TQUPDSV(DFN,PAYER,SRVDT) ; Update service dates & freshness dates for TQ
- +1 ; entries awaiting transmission
- +2 ;
- +3 NEW SVDT,STS,ERACT,CSRVDT,CSPAN,SPAN,DA,HL7IEN,RIEN
- +4 ;
- +5 IF ($GET(DFN)="")!($GET(PAYER)="")!($GET(SRVDT)="")
- GOTO TQUPDSVX
- +6 ;
- +7 ; Loop thru all inquiries to be transmitted to update the service date
- +8 ; Statuses: Ready to Transmit(1), Hold(4) and Retry(6)
- +9 SET SVDT=""
- +10 FOR
- SET SVDT=$ORDER(^IBCN(365.1,"AD",DFN,PAYER,SVDT))
- if 'SVDT
- QUIT
- Begin DoDot:1
- +11 SET DA=0
- +12 FOR
- SET DA=$ORDER(^IBCN(365.1,"AD",DFN,PAYER,SVDT,DA))
- if 'DA
- QUIT
- Begin DoDot:2
- +13 ; TQ Status
- +14 SET STS=$PIECE($GET(^IBCN(365.1,DA,0)),U,4)
- +15 ; Check to see if record is still scheduled to be transmitted.
- +16 ; If so, update the service date if the new service date and current
- +17 ; service date are both in the past or future and the new service
- +18 ; date is closer to Today. Also, if the current service date is in
- +19 ; the future and the new service date is in the past, update with the
- +20 ; new service date.
- +21 ; If not Ready to Transmit(1), Hold(4) and Retry(6), quit
- +22 IF STS'=1
- IF STS'=4
- IF STS'=6
- QUIT
- +23 ; If Hold and last Response returned Error Action - Please resubmit
- +24 ; Original Transaction (P) - do not update
- +25 IF STS=4
- SET ERACT=""
- Begin DoDot:3
- +26 ; Last msg sent
- +27 SET HL7IEN=$ORDER(^IBCN(365.1,DA,2," "),-1)
- if 'HL7IEN
- QUIT
- +28 ; Assoc eIV Response IEN
- +29 SET RIEN=$PIECE($GET(^IBCN(365.1,DA,2,HL7IEN,0)),U,3)
- if 'RIEN
- QUIT
- +30 ; Error Action IEN (365.018)
- +31 SET ERACT=$PIECE($GET(^IBCN(365,RIEN,1)),U,15)
- if 'ERACT
- QUIT
- +32 SET ERACT=$PIECE($GET(^IBE(365.018,ERACT,0)),U,1)
- End DoDot:3
- IF ERACT="P"
- QUIT
- +33 ;
- +34 ; Current service date for TQ entry
- +35 SET CSRVDT=$PIECE($GET(^IBCN(365.1,DA,0)),U,12)
- +36 ; If current service date is today (DT), do not update
- +37 IF CSRVDT=DT
- QUIT
- +38 ; If new service date is in the future and current service date is in
- +39 ; the past, do not update
- +40 IF SRVDT>DT
- IF CSRVDT<DT
- QUIT
- +41 ; If new service date is today, update
- +42 IF SRVDT=DT
- DO SAVETQ^IBCNEUT2(DA,SRVDT)
- DO SAVFRSH(DA,+$$FMDIFF^XLFDT(SRVDT,CSRVDT,1))
- QUIT
- +43 ; If both current and new service dates are in the past or future,
- +44 ; only update, when new service date is closer to today (DT).
- +45 IF ((CSRVDT<DT)&(SRVDT<DT))!((CSRVDT>DT)&(SRVDT>DT))
- Begin DoDot:3
- +46 SET CSPAN=$$FMDIFF^XLFDT(CSRVDT,DT,1)
- SET SPAN=$$FMDIFF^XLFDT(SRVDT,DT,1)
- +47 IF CSPAN<0
- SET CSPAN=-CSPAN
- +48 IF SPAN<0
- SET SPAN=-SPAN
- +49 IF SPAN<CSPAN
- DO SAVETQ^IBCNEUT2(DA,SRVDT)
- DO SAVFRSH(DA,+$$FMDIFF^XLFDT(SRVDT,CSRVDT,1))
- End DoDot:3
- QUIT
- +50 ; If new service date is in the past and current service date is in
- +51 ; the future, update
- +52 IF SRVDT<CSRVDT
- DO SAVETQ^IBCNEUT2(DA,SRVDT)
- DO SAVFRSH(DA,+$$FMDIFF^XLFDT(SRVDT,CSRVDT,1))
- QUIT
- +53 QUIT
- End DoDot:2
- End DoDot:1
- TQUPDSVX ; TQUPDSV exit pt
- +1 QUIT
- +2 ;
- TQMAXSV(DFN,PAYER,EICDEXT) ; Returns MAX(TQ Service Date) for Patient & Payer
- +1 ; Input:
- +2 ; DFN - Patient DFN (2)
- +3 ; PAYER - Payer IEN (365.12)
- +4 ; EICDEXT - 1 OR 0 (Is this from the EICD extract?)
- +5 ;
- +6 ; Output:
- +7 ; TQMAXSV - MAX (most recent) service date from TQ entry for Patient &
- +8 ; Payer
- +9 ;
- +10 ; IB*621 reworked this function to ignore TQ entries with statuses of
- +11 ; "Response Received" for EICD for which the Response indicated a "Clearinghouse Timeout"
- +12 NEW TQMAXSV
- +13 SET TQMAXSV=""
- +14 ;IB*668/TAZ - Added check for PAYER and quit if null
- +15 IF $GET(DFN)=""!'$GET(PAYER)
- GOTO TQMAXSVX
- +16 ;
- +17 NEW ERTXT,IBSKIP,IBTQS,IENS,LASTBYP,STATLIST,TQIEN
- +18 ; This is the list of statuses that are to be ignored for EICD extract only
- +19 ; 3=Response Received
- +20 SET STATLIST=",3,"
- +21 ;
- +22 SET LASTBYP=""
- +23 FOR
- SET LASTBYP=$ORDER(^IBCN(365.1,"AD",DFN,PAYER,LASTBYP))
- if LASTBYP=""
- QUIT
- Begin DoDot:1
- +24 SET TQIEN=""
- +25 FOR
- SET TQIEN=$ORDER(^IBCN(365.1,"AD",DFN,PAYER,LASTBYP,TQIEN))
- if TQIEN=""
- QUIT
- Begin DoDot:2
- +26 SET IBSKIP=0
- +27 IF EICDEXT
- Begin DoDot:3
- +28 ; TQ Transmission Status
- SET IBTQS=+$$GET1^DIQ(365.1,TQIEN_",",.04,"I")
- +29 IF IBTQS
- IF '($FIND(STATLIST,","_IBTQS_","))
- QUIT
- +30 SET IENS="1,"_TQIEN_","
- SET RIEN=$$GET1^DIQ(365.16,IENS,.03,"I")
- +31 ; keep looking
- SET ERTXT=$$GET1^DIQ(365,RIEN_",",4.01)
- IF $$UP^XLFSTR(ERTXT)["TIMEOUT"
- SET IBSKIP=1
- End DoDot:3
- if IBSKIP
- QUIT
- +32 IF LASTBYP>TQMAXSV
- SET TQMAXSV=LASTBYP
- End DoDot:2
- End DoDot:1
- +33 ;
- TQMAXSVX ; TQMAXSV exit pt
- +1 QUIT TQMAXSV
- +2 ;
- SAVFRSH(TQIEN,DTDIFF) ; Update TQ freshness date based on service date diff
- +1 ;
- +2 NEW DIE,DA,FDT,DR,D,D0,DI,DIC,DQ,X
- +3 IF $GET(TQIEN)=""
- QUIT
- +4 SET FDT=$PIECE($GET(^IBCN(365.1,TQIEN,0)),U,17)
- +5 ; Note - will only update if FDT > 0.
- +6 SET FDT=$$FMADD^XLFDT(FDT,+DTDIFF)
- +7 SET DIE="^IBCN(365.1,"
- SET DA=TQIEN
- SET DR=".17////"_FDT
- +8 DO ^DIE
- +9 QUIT
- +10 ;
- EPAT(MSG) ; Check for qualified patient for EICD Identification
- +1 ;INPUT:
- +2 ; MSG - Error Message used in IBCNEQU1
- +3 ;
- +4 NEW OK
- +5 SET OK=0
- +6 ;Test Patient?
- IF +$$GET1^DIQ(2,DFN_",",.6,"I")
- GOTO EPATX
- +7 ;Too soon
- IF (+$$GET1^DIQ(2,DFN_",",2001,"I")>FRESHDT)
- if $DATA(MSG)
- SET MSG=2
- GOTO EPATX
- +8 ;Patient Deceased
- IF +$$GET1^DIQ(2,DFN_",",.351,"I")
- GOTO EPATX
- +9 ;State cannot be null
- IF $$GET1^DIQ(2,DFN_",",.115)=""
- GOTO EPATX
- +10 ;Zip Code cannot be null
- IF $$GET1^DIQ(2,DFN_",",.116)=""
- GOTO EPATX
- +11 ;
- +12 SET OK=1
- EPATX ; Exit
- +1 QUIT OK
- +2 ;
- EPAYR() ; Check EICD Payer
- +1 ;IB*702/TAZ Moved Payer checks from IBCNEDE4 to EPAYR^IBCNEUT5 (this is a new tag)
- +2 NEW IENS,OK,PAYER,PIEN
- +3 SET OK=0
- +4 ;
- +5 ; EICD PAYER
- SET PIEN=+$$GET1^DIQ(350.9,"1,",51.31,"I")
- +6 IF 'PIEN
- GOTO EPAYRX
- +7 ;
- +8 DO PAYER^IBCNINSU(PIEN,"EIV",,"I",.PAYER)
- +9 ; No EIV Data for this Payer
- SET IENS=$ORDER(PAYER(365.121,""))
- IF IENS']""
- GOTO EPAYRX
- +10 ; Not "NATIONALLY ENABLED"
- IF '$GET(PAYER(365.121,IENS,.02,"I"))
- GOTO EPAYRX
- +11 ; Not "LOCALLY ENABLED"
- IF '$GET(PAYER(365.121,IENS,.03,"I"))
- GOTO EPAYRX
- +12 ;
- +13 SET OK=PIEN
- +14 ;
- EPAYRX ; Exit
- +1 QUIT OK
- +2 ;
- EACTPOL() ; Check for active policy for EICD Identification
- +1 NEW EINS,IBACTV,IBEFF,IBEXP,IBIDX,IBINCO,IBINSNM,IBPLAN,IBTOP,IBTOPIEN,IBWK1,IBWK2
- +2 ;
- +3 ; gather the non-active insurance company names
- +4 ; we will strip all blanks from the names, so dashes ('-') are treated properly for a compare
- +5 FOR IBIDX=2:1
- SET IBINCO=$PIECE($TEXT(NAINSCO+IBIDX),";;",2)
- if IBINCO=""
- QUIT
- SET IBINSNM($TRANSLATE(IBINCO," ",""))=""
- +6 ;
- +7 ; gather the non-active type of plan iens
- +8 FOR IBIDX=2:1
- SET IBPLAN=$PIECE($TEXT(NATPLANS+IBIDX),";;",2)
- if IBPLAN=""
- QUIT
- Begin DoDot:1
- +9 SET IBTOP=+$$FIND1^DIC(355.1,,"BQX",IBPLAN)
- if 'IBTOP
- QUIT
- +10 SET IBTOPIEN(IBTOP)=""
- End DoDot:1
- +11 ;
- +12 ; skip any patient with "active" insurance
- +13 SET IBACTV=0
- +14 ; check policies for "active" insurance
- SET IBIDX=0
- +15 FOR
- SET IBIDX=$ORDER(^DPT(DFN,.312,IBIDX))
- if 'IBIDX
- QUIT
- Begin DoDot:1
- +16 SET EINS=IBIDX_","_DFN_","
- +17 ; No effective date
- SET IBEFF=+$$GET1^DIQ(2.312,EINS,8,"I")
- IF 'IBEFF
- QUIT
- +18 ; expired
- SET IBEXP=+$$GET1^DIQ(2.312,EINS,3,"I")
- IF IBEXP
- IF (IBEXP<(DT))
- QUIT
- +19 ;
- +20 ; Check for Non-active Insurance companies
- +21 ; insurance company name
- SET INSNM=$TRANSLATE($$GET1^DIQ(2.312,EINS,.01,"E")," ","")
- +22 ; bad pointer to INSURANCE COMPANY File (#36)
- IF INSNM=""
- QUIT
- +23 IF $DATA(IBINSNM(INSNM))
- QUIT
- +24 ;
- +25 ; Check for Non-active Type of Plan
- +26 ; group plan ien
- SET IBPLAN=$$GET1^DIQ(2.312,EINS,.18,"I")
- +27 ; type of plan ien
- SET IBTOP=$$GET1^DIQ(355.3,IBPLAN_",",.09,"I")
- +28 IF IBTOP'=""
- IF $DATA(IBTOPIEN(IBTOP))
- QUIT
- +29 ;
- +30 ; Insurance is considered active at this point
- +31 ; active
- SET IBACTV=1
- QUIT
- End DoDot:1
- IF IBACTV
- QUIT
- EACTPOLX ; Exit
- +1 QUIT IBACTV
- +2 ;
- NAINSCO ; Non-active Insurance companies
- +1 ;
- +2 ;;MEDICARE (WNR)
- +3 ;;VACAA-WNR
- +4 ;;CAMP LEJEUNE - WNR
- +5 ;;IVF - WNR
- +6 ;;VHA DIRECTIVE 1029 WNR
- +7 ;
- NATPLANS ; Non-active Type of Plans
- +1 ;
- +2 ;;ACCIDENT AND HEALTH INSURANCE
- +3 ;;AUTOMOBILE
- +4 ;;AVIATION TRIP INSURANCE
- +5 ;;CATASTROPHIC INSURANCE
- +6 ;;CHAMPVA
- +7 ;;COINSURANCE
- +8 ;;DENTAL INSURANCE
- +9 ;;DUAL COVERAGE
- +10 ;;INCOME PROTECTION (INDEMNITY)
- +11 ;;KEY-MAN HEALTH INSURANCE
- +12 ;;LABS, PROCEDURES, X-RAY, ETC. (ONLY)
- +13 ;;MEDI-CAL
- +14 ;;MEDICAID
- +15 ;;MEDICARE (M)
- +16 ;;MEDICARE/MEDICAID (MEDI-CAL)
- +17 ;;MENTAL HEALTH
- +18 ;;NO-FAULT INSURANCE
- +19 ;;PRESCRIPTION
- +20 ;;QUALIFIED IMPAIRMENT INSURANCE
- +21 ;;SPECIAL CLASS INSURANCE
- +22 ;;SPECIAL RISK INSURANCE
- +23 ;;SPECIFIED DISEASE INSURANCE
- +24 ;;Substance abuse only
- +25 ;;TORT FEASOR
- +26 ;;TRICARE
- +27 ;;TRICARE SUPPLEMENTAL
- +28 ;;VA SPECIAL CLASS
- +29 ;;VISION
- +30 ;;WORKERS' COMPENSATION INSURANCE
- +31 ;
- +32 QUIT
- +33 ;