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