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

IBCNEUT5.m

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