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

ABMDLCK.m

Go to the documentation of this file. 
  1. ABMDLCK ; IHS/ASDST/DMJ - Eligibility Checker ;    
  1.  ;;2.6;IHS 3P BILLING SYSTEM;**13,21**;NOV 12, 2009;Build 379
  1.  ;Original;TMD;
  1.  ;
  1.  ;This rtn expects that ABMVDFN, the visit file ien be defined
  1.  ;It also uses DFN - Patient DFN & ABMVDT - Visit date
  1.  ;This rtn returns eligibility info in the array ABML.  The array has
  1.  ;the following format (approximately)
  1.  ;
  1.  ;ABML(PRIORITY,INSIEN)=D^I^TYPE^SDATE^EDATE^UBILL
  1.  ;ABML(PRIORITY,INSIEN,"COV",CTIEN)=COV
  1.  ;PRIORITY  =  Priority of the coverage
  1.  ;INSIEN    =  IEN from the Insurer file
  1.  ;TYPE      =  One letter code M=Medicare, D=Medicaid, P=Private, 
  1.  ;             R=Railroad ret, N=Non-ben, I=Indian, A=Accident (or tort)
  1.  ;             W=Workman's comp
  1.  ;D         =  IEN from Medicaid ins file if Medicaid, else nul
  1.  ;I         =  subfile ien from ins file, a date for medicaid
  1.  ;CTIEN     =  IEN from Coverage Type file
  1.  ;COV       =  A or B if the type is Medicare
  1.  ;SDATE     =  Start date
  1.  ;EDATE     =  End Date.  These 2 fields are for elig change during inpt
  1.  ;UBILL     =  Code for NO ELIGIBILITY FOUND     44=Unbillable Visit
  1.  ;
  1.  ;Required input variables:  ABMVDFN or (DFN and ABMVDT)
  1.  ;ABMVDFN      The PCC Visit file ien
  1.  ;DFN          Patient file ien
  1.  ;ABMVDT       (Visit) date in Fileman internal format
  1.  ;
  1.  ;Output
  1.  ;ABML array.  It must be passed by reference
  1.  ;
  1.  ; *********************************************************************
  1.  ; IHS/SD/SDR - 12/7/2004 - V2.5 P7 - Made change so if inpatient and
  1.  ;     the clinic is pharmacy it will change the clinic to general.  This
  1.  ;     is a new issue with Pharmacy 7.
  1.  ;
  1.  ; IHS/SD/SDR - v2.5 p9 - IM19399
  1.  ;    Added code to look at new worker's comp file for eligibility
  1.  ;
  1.  ;IHS/SD/SDR - 2.6*21 - HEAT234095 - Fix for <UNDEF>AA+11^ABMDLCK.
  1.  ;IHS/SD/SDR - 2.6*21 - VMBP - Added code for new VAMB Eligible File; will be last insurer,
  1.  ;    with non-ben as final
  1.  ; *********************************************************************
  1.  ;
  1. ELG(ABMVDFN,ABML,DFN,ABMVDT) ;EP Entry point - Eligibility checker
  1.  N ABM,COV,ACCDENT,ABMPRVTI,ABMCLN,ABMCDFN,D1,Y,ABMVT
  1.  K ABMNOELG
  1.  K AUPNCPT
  1.  S DFN=$G(DFN)
  1.  S ABMVDT=$G(ABMVDT)
  1.  I ABMVDFN_DFN="" K ABML Q
  1.  I ABMVDFN,'$D(^AUPNVSIT(ABMVDFN)) D  Q
  1.  .S ABML("ERROR")="NOT A VALID VISIT IEN"
  1.  I DFN,'$D(^DPT(DFN)) D  Q
  1.  .S ABML("ERROR")="NOT A VALID PATIENT NUMBER"
  1.  I ABMVDFN D
  1.  .S Y=^AUPNVSIT(ABMVDFN,0)
  1.  .S:'DFN DFN=$P(Y,U,5)
  1.  .S ABMCLN=$P(Y,U,8)
  1.  .S SERVCAT=$P(Y,U,7)
  1.  .I ("IDH"[$G(SERVCAT)),(ABMCLN=39) S ABMCLN=1
  1.  .S:+$G(ABMP("CDFN")) ABMCLN=$$GET1^DIQ(9002274.3,ABMP("CDFN"),.06,"I")
  1.  .S:'ABMVDT ABMVDT=+Y\1
  1.  .S ABMCDFN=$O(^ABMDCLM(DUZ(2),"AV",ABMVDFN,""))
  1.  .I '$D(ABMDISDT) D
  1.  ..S I=$O(^AUPNVINP("AD",ABMVDFN,0))
  1.  ..S ABMDISDT=$S(I]"":$P(^AUPNVINP(I,0),U,1),1:0)
  1.  S ABMDISDT=$G(ABMDISDT)
  1.  K ABML
  1.  ; Check if visit after Date of Death
  1.  ; 41 ; Visit date after date of death
  1.  I $D(^DPT(DFN,.35)),$P(^(.35),U,1)]"",$P(^(.35),U,1)<$P(ABMVDT,".",1) S ABMNOELG=41 Q
  1.  S Y=^AUPNPAT(DFN,0)
  1.  ;In ver 1.6 this var would be 0 if piece 21 was blank
  1.  S ABM("EMPLOYED")=+$P(Y,U,21)
  1.  I ABM("EMPLOYED")=3 S ABM("EMPLOYED")=0
  1.  S ABM("PRIMARY")=$P(Y,U,25)
  1.  ;WRKC - Workman's comp
  1.  ;AA   - Accident or tort
  1.  ;5    - Private insurance
  1.  ;3    - Railroad ret
  1.  ;2    - Medicare
  1.  ;4    - Medicaid
  1.  ;5.5  - VMBP VA billing (at linetag 7)  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_90
  1.  ;6    - non-ben
  1.  ;F ABM("PROC")="WRKC","AA","5^ABMDLCK2",3,2,"4^ABMDLCK2","6^ABMDLCK2" D  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_90
  1.  S ABM("VACHK")=0  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_90
  1.  F ABM("PROC")="WRKC","AA","5^ABMDLCK2",3,2,"4^ABMDLCK2","7^ABMDLCK4","6^ABMDLCK2" D  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_90
  1.  .S (ABM("COV"),ABM("MDFN"))=""
  1.  .K ABM("FLG"),ABM("XIT")
  1.  .D @ABM("PROC")
  1.  I $D(ABML(1)) D
  1.  .I $O(ABML(1,$O(ABML(1,"")))) D
  1.  ..S P=96
  1.  ..F  S P=$O(ABML(P),-1) Q:'P  D
  1.  ...S I=0
  1.  ...F  S I=$O(ABML(P,I)) Q:'I  D
  1.  ....I I'=ABM("PRIMARY") D
  1.  .....M ABML(P+1,I)=ABML(P,I)
  1.  .....K ABML(P,I)
  1.  G XIT
  1.  ;
  1. 2 ; Medicare Elig Chk
  1.  K ABM("XIT")
  1.  S ABM("PRI")=$S(ABM("EMPLOYED")=5:1,1:3)
  1.  S ABM("TYP")="M"
  1.  D PRIO
  1.  ;After setting priority we check medicare eligibility file
  1.  Q:'$D(^AUPNMCR(DFN,0))
  1.  S ABM("INS")=$$MCRIEN(ABMVDT)
  1.  I '+ABM("INS") S ABME(166)="" Q
  1.  K ABM("REC")
  1.  I '+$O(^AUPNMCR(DFN,11,0)) D  Q
  1.  .D CHK^ABMDLCK1
  1.  .I $G(ABM("XIT")) D UNCHK^ABMDLCK2
  1.  ;Node 11 has the Medicare Part A and/or B eligibility
  1.  S ABMELGDT=0
  1.  S ABM("MDFN")=0
  1.  F  S ABM("MDFN")=$O(^AUPNMCR(DFN,11,ABM("MDFN"))) Q:'ABM("MDFN")  D 23
  1.  I 'ABMELGDT D  Q
  1.  .I '$D(ABML(ABM("PRI"),ABM("INS"))) D
  1.  ..I '$D(ABML(99,ABM("INS"))) D
  1.  ...S $P(ABML(99,ABM("INS")),U)=$G(DFN)
  1.  ...S $P(ABML(99,ABM("INS")),U,2)=$G(ABM("MDFN"))
  1.  ...S $P(ABML(99,ABM("INS")),U,3)="M"
  1.  ..S $P(ABML(99,ABM("INS")),U,6)=34
  1.  E  I $D(ABML(ABM("PRI"),ABM("INS"))),ABM("PRI")<97 D
  1.  .K ABML(99,ABM("INS")) I $G(ABM("XIT")) D UNCHK^ABMDLCK2 Q
  1.  I $G(ABM("XIT"))="A" K ABML(ABM("PRI"),ABM("INS"),"COV",ABM("CV"))
  1.  Q
  1.  ;
  1. MCRIEN(X) ;EP - determine medicare fi on visit date
  1.  N I,Y
  1.  S Y=0
  1.  S I=0
  1.  F  S I=$O(^AUTNINS(2,12,I)) Q:'I  D
  1.  .S ABM0=^AUTNINS(2,12,I,0)
  1.  .Q:'$P(ABM0,"^",2)
  1.  .Q:$P(ABM0,"^",2)>X
  1.  .I $P(ABM0,"^",3),$P(ABM0,"^",3)<X Q
  1.  .S Y=I
  1.  I 'Y S Y=$O(^AUTNINS("B","MEDICARE",0))
  1.  Q Y
  1.  ;
  1. 23 ;
  1.  S ABM("REC")=^AUPNMCR(DFN,11,ABM("MDFN"),0)
  1.  I $P(ABM("REC"),U,1)>$P($S(ABMDISDT:ABMDISDT,1:ABMVDT),".",1) Q
  1.  I $P(ABM("REC"),U,2)]"" Q:$P(ABM("REC"),U,2)<$P(ABMVDT,".",1)
  1.  S ABMELGDT=1
  1.  S COV=$P(ABM("REC"),U,3)
  1.  ;For A or B get ien from ^AUTTPIC file
  1.  I COV]"" S ABM("COV")=$O(^AUTTPIC("AC",ABM("INS"),COV,""))
  1.  E  S ABM("COV")=""
  1.  D CHK^ABMDLCK1
  1.  ; This block will never get called as ABM("MSUP") never gets set.
  1.  ; It should be fixed of removed for the next version.
  1.  ; It is trying to address ; 38 ; Medicare eligible; but also mcr suppl
  1.  I '$D(ABML(ABM("PRI"),ABM("INS"))),$D(ABM("MSUP")) D
  1.  .S ABM=0
  1.  .F  S ABM=$O(ABM("MSUP",ABM)) Q:'ABM  D
  1.  ..Q:'$D(ABML(4,ABM))
  1.  ..S ABML(99,ABM)=ABML(4,ABM)
  1.  .. S $P(ABML(99,ABM("INS")),U,6)=38
  1.  ..S CV=0
  1.  ..F  S CV=$O(ABML(4,ABM,"COV",CV)) Q:'CV  D
  1.  ...S ABML(99,ABM,"COV",CV)=ABML(4,ABM,"COV",CV)
  1.  ..K ABML(4,ABM)
  1.  .K ABM("MSUP")
  1.  K CV
  1.  Q
  1.  ;
  1. 3 ; RailRoad Elig Chk
  1.  K ABM("XIT")
  1.  S ABM("PRI")=$S(ABM("EMPLOYED")=5:1,1:3)
  1.  S ABM("TYP")="R"
  1.  D PRIO
  1.  Q:'$D(^AUPNRRE(DFN,0))
  1.  S ABM("INS")=$O(^AUTNINS("B","RAILROAD RETIREMENT",""))
  1.  I '+ABM("INS") S ABME(168)="" Q
  1.  K ABM("REC")
  1.  I '+$O(^AUPNRRE(DFN,11,0)) D CHK^ABMDLCK1 Q
  1.  K ABMGOOD
  1.  S ABM("MDFN")=0
  1.  F  S ABM("MDFN")=$O(^AUPNRRE(DFN,11,ABM("MDFN"))) Q:'ABM("MDFN")  D
  1.  .D 33
  1.  I '$G(ABMGOOD) D
  1.  .S $P(ABML(99,ABM("INS")),"^",6)=35
  1.  I $G(ABM("XIT")) D UNCHK^ABMDLCK2
  1.  K COV
  1.  Q
  1.  ;
  1. 33 ;
  1.  S ABM("REC")=^AUPNRRE(DFN,11,ABM("MDFN"),0)
  1.  ; 35 ; RailRoad coverage; visit outside eligibility dates
  1.  I $P(ABM("REC"),U,1)>$P($S(ABMDISDT:ABMDISDT,1:ABMVDT),".",1) Q
  1.  I $P(ABM("REC"),U,2)]"",$P(ABM("REC"),U,2)<$P(ABMVDT,".",1) Q
  1.  S ABMGOOD=1
  1.  S COV=$P(ABM("REC"),U,3)
  1.  I COV]"" S ABM("COV")=$O(^AUTTPIC("AC",ABM("INS"),COV,""))
  1.  E  S ABM("COV")=""
  1.  D CHK^ABMDLCK1
  1.  Q
  1.  ;
  1. WRKC ;Workman's comp
  1.  S ABM("EMPL REL")=0
  1.  Q:$S(ABM("EMPLOYED")=0:1,ABM("EMPLOYED")=5:1,1:0)
  1.  Q:'$G(ABMVDFN)
  1.  N ABMLW
  1.  K ABM("XIT")
  1.  S ABM("TYP")="W"
  1.  S ABM=0
  1.  F  S ABM=$O(^AUPNVPOV("AD",ABMVDFN,ABM)) Q:'ABM  D  Q:$D(ABMLW)
  1.  .;Check if POV employment related
  1.  .Q:$P($G(^AUPNVPOV(ABM,0)),U,7)'=4
  1.  .S ABM("EMPL REL")=1
  1.  .S ABM("PRI")=1
  1.  .;19th piece of pat file is employer
  1.  .S Y=$P($G(^AUPNPAT(DFN,0)),U,19)
  1.  .I Y,$G(^AUPNWC(DFN,0))'="" D  ;entry in 9000042-Workman's Comp
  1.  ..S ABMWCIEN=0
  1.  ..F  S ABMWCIEN=$O(^AUPNWC(DFN,11,ABMWCIEN)) Q:+ABMWCIEN=0  D  Q:$D(ABMLW)
  1.  ...S ABMWEFDT=$P($G(^AUPNWC(DFN,11,ABMWCIEN,0)),U,12)
  1.  ...S ABMWEXDT=$P($G(^AUPNWC(DFN,11,ABMWCIEN,0)),U,13)
  1.  ...I ABMWEFDT>$P($S(ABMDISDT:ABMDISDT,1:ABMVDT),".",1) Q
  1.  ...I ABMWEXDT'="",ABMWEXDT<$P(ABMVDT,".",1) Q
  1.  ...S ABM("INS")=$P($G(^AUPNWC(DFN,11,ABMWCIEN,0)),U,10),ABMLW=1
  1.  .Q:$D(ABMLW)
  1.  .I Y,$P($G(^AUTNEMPL(Y,0)),U,8) D  Q:$D(ABMLW)
  1.  ..S ABM("INS")=$P(^AUTNEMPL(Y,0),U,8)
  1.  ..S Y=$P($G(^AUTNINS(ABM("INS"),1)),U,7)
  1.  ..;Piece 7 is status field: 0=UNSELECTABLE, 4=UNBILLABLE
  1.  ..I Y]"","04"'[Y S ABMLW=1
  1.  Q:'ABM("EMPL REL")
  1.  I $G(ABMLW),($G(ABM("INS"))'="") D  Q
  1.  .D CHK^ABMDLCK1
  1.  .I $G(ABM("XIT")) D UNCHK^ABMDLCK2
  1.  ;Go on and look further if not found yet.
  1.  S ABM("INS")=$O(^AUTNINS("B","WORKMEN'S COMP",0))
  1.  Q:'ABM("INS")
  1.  ;This is looking at the workmen's comp field of the Medicaid mult
  1.  S ABM=0
  1.  F  S ABM=$O(^AUTNINS(ABM("INS"),13,ABM)) Q:'ABM  I $P(^(ABM,0),U,3) S ABM("INS")=$P(^(0),U,3) Q
  1.  D CHK^ABMDLCK1
  1.  I $G(ABM("XIT")) D UNCHK^ABMDLCK2
  1.  Q
  1.  ;
  1. AA ;Automobile accident or other accident or tort related.
  1.  N V
  1.  K ABM("XIT")
  1.  S ABM("TYP")="A"
  1.  S V=0,ACCDENT=0
  1.  Q:'$G(ABMVDFN)
  1.  ;Quit if this is a workman's comp case
  1.  I ABM("EMPL REL"),$D(ABML(1)),$P(ABML(1,$O(ABML(1,0))),U,3)="W" D  Q
  1.  .S ACCDENT=1
  1.  .K ABM("INS")
  1.  F  S V=$O(^AUPNVPOV("AD",ABMVDFN,V)) Q:'V  D  Q:ACCDENT
  1.  .;I $P(^AUPNVPOV(V,0),U,11)]"" S ACCDENT=1  ;abm*2.6*21 IHS/SD/SDR HEAT234095
  1.  .I $P($G(^AUPNVPOV(V,0)),U,11)]"" S ACCDENT=1  ;abm*2.6*21 IHS/SD/SDR HEAT234095
  1.  Q:'ACCDENT                  ;Not accident related
  1.  Q:'$D(^AUPNPRVT(DFN))   ;No accident insurance
  1.  S ABM("PRI")=1
  1.  S D1="@",ACCDENT=0               ;@ Collates before all X-refs
  1.  F  S D1=$O(^AUPNPRVT(DFN,11,D1),-1) Q:'D1  D
  1.  .Q:$P($G(^AUPNPRVT(DFN,11,D1,0)),U)=""
  1.  .I $$ACCREL(D1) D
  1.  ..Q:ABMVDT<$P(ABMPRVTI,U,6)!(($P(ABMPRVTI,U,7)]"")&(ABMVDT>$P(ABMPRVTI,U,7)))
  1.  ..S ACCDENT=1
  1.  ..S ABM("INS")=$P(ABMPRVTI,U)
  1.  ..S ABM("MDFN")=D1
  1.  ..D PRIO
  1.  ..D CHK^ABMDLCK1
  1.  ..I $G(ABM("XIT")) D UNCHK^ABMDLCK2
  1.  ..I $D(ABML(ABM("PRI"),ABM("INS"))) S ABMLX(ABM("INS"),ABM("PRI"))=""
  1.  Q
  1.  ;
  1. ACCREL(D1) ;EP - Ext func to determine if ins is accident or tort related
  1.  N RELPT
  1.  S ABMPRVTI=$G(^AUPNPRVT(DFN,11,D1,0))
  1.  S RELPT=$P(ABMPRVTI,U,5)
  1.  Q:'RELPT 0
  1.  I $P(^AUTTRLSH(RELPT,0),U,4) Q 1
  1.  Q 0
  1.  ;
  1. PRIO ;SET PRIORITY
  1.  F  D  Q:'$D(ABML(ABM("PRI")))
  1.  .Q:'$D(ABML(ABM("PRI")))
  1.  .S ABM("PRI")=ABM("PRI")+1
  1.  Q
  1.  ;
  1. XIT K ABM,ABMLX
  1.  Q