ABSPOS29 ; IHS/FCS/DRS - BUILD COMBINED INSURANCE ; [ 09/12/2002 10:04 AM ]
;;1.0;PHARMACY POINT OF SALE;**3,14,15,16,17,21,22,37,44,46,49,50**;JUN 21, 2001;Build 38
;
; Copied from VTLCOMB on 08/18/2000
; Removed $ZT="DX^KCRZT"
; Verified no other instances of "KCR" or "VTL"
;
; DRS 10/16/2000 Follow the FI pointer
; in ^AUTNINS(insurer,13,state,0),U,2) right now.
; Site-selectable switch for this, though it perhaps isn't
; in the setup routines. See $$USEFI, below.
; This was done because Pawhuska has ^AUTNINS(3,), MEDICAID,
; set to not billable for RX. But if you follow the pointer
; to Oklahoma Medicaid, that one is billable.
; This sets the right medicaid insurer from the very beginning.
;
;** vtl 6/26/00 - get elig dates from Pvt Ins. file
;
;** this program will search the three files containing insurance
; information. 1: Private Insurance Eligible
; 2: Medicare Eligible
; 3: Medicaid Eligible
;** It will update ^ABSPCOMB with the data found
; IHS/SD/RLT - 04/25/06 - Patch 17
; Added Railroad search
; 4: Railroad Eligible
;---
;IHS/SD/lwj 07/21/05 patch 14 (????) need to adjust UPDATE so
; that previously entries in ^ABSPCOMB are deleted if the patient
; no longer has any insurance references
;---
;IHS/SD/RLT - 01/24/06 - Patch 15
; Added new code to access new Medicare D eligibility data.
;---
;IHS/SD/RLT - 01/24/06 - Patch 16
; Added insurer to Medicare D eligibility data.
;---
;IHS/SD/RLT - 04/25/06 - Patch 17
; Added Railroad search.
;---
;IHS/SD/RLT - 05/01/07 - Patch 21
; Changed Medicare and Railroad to capture B and D and
; to skip incomplete D.
;---
;IHS/SD/RLT - 07/25/07 - Patch 22
; Updated Medicare and RR D lookup.
;---
;IHS/CAS/RCS - 08/12/13 - Patch 46
; Skip Patient records with missing Insurer link
;
EN(PATDFN) ;EP - from ABSPOS25
;
N ARRAY,BEGDAT,CAIDDFN,CAIDNAM,CAREDFN,CARENAM,CNT,D1,DA,DIK,DIQUIET
N ENDDAT,FILE,FILECNT,NUMBER,P1,P2,P3
N POLCOV,POLIEN,POLNAM,POLNUM,POLREL,POLSEX,PRVDFN,REC,REC11,SUFFIX
N RRDFN,RRPREFIX,RRNAM,INSDFN,COVTYP,INSTYP,STATENM
;S $ZT="DX^KCRZT"
Q:'$G(PATDFN)
;N (DT,DUZ,PATDFN)
N DIQUIET,NUMBER
S DIQUIET=1 D DT^DICRW
S NUMBER=0
D PRIVATE
D MEDICAID
D MEDICARE
D RAILROAD
D UPDATE
Q
TRANSFI(INSDFN,STATE) ; translate based on the Medicaid FI field
I '$$USEFI Q INSDFN ; flag is set to NOT do the translation
N X S X=$P($G(^AUTNINS(INSDFN,13,STATE,0)),U,2)
Q $S(X:X,1:INSDFN)
USEFI() Q '$P($G(^ABSP(9002313.99,1,"INS")),U,3)
;---
PRIVATE ;
;** scan the Private Insurance Eligible file
S PRVDFN=$O(^AUPNPRVT("B",PATDFN,0))
Q:'PRVDFN
S FILE=$O(^DIC("B","PRIVATE INSURANCE ELIGIBLE",0))
S D1=0
F S D1=$O(^AUPNPRVT(PRVDFN,11,D1)) Q:'D1 DO
. S NUMBER=NUMBER+1
. S REC=^AUPNPRVT(PRVDFN,11,D1,0)
. S INSDFN=$P(REC,U,1)
. S POLNUM=$P(REC,U,2)
. S POLCOV=$P(REC,U,3)
. S POLNAM=$P(REC,U,4)
. S POLREL=$P(REC,U,5)
. S BEGDAT=$P(REC,U,6)
. S ENDDAT=$P(REC,U,7)
. S POLIEN=$P(REC,U,8)
. Q:INSDFN="" ;OIT/CAS/RCS - 081213 Patch 46, skip insurer with missing pointer
. ;I POLIEN DO ;vtl 6/26/00 - get elig dates from Pvt Ins. file
.;.; S BEGDAT=$P(^AUPN3PPH(POLIEN,0),U,17)
.;.; S ENDDAT=$P(^AUPN3PPH(POLIEN,0),U,18)
. S ARRAY(NUMBER)=INSDFN_U_"PRVT"_U_POLNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_PRVDFN_U_D1_U_POLREL
Q
;---
MEDICAID ;
S FILE=$O(^DIC("B","MEDICAID ELIGIBLE",0))
S CAIDDFN=0
F S CAIDDFN=$O(^AUPNMCD("B",PATDFN,CAIDDFN)) Q:'CAIDDFN DO
. ;IHS/OIT/RAN 021710 patch 37 add all dates, not just most recent -Move following line
. ;S NUMBER=NUMBER+1
. S REC=^AUPNMCD(CAIDDFN,0)
. S INSDFN=$P(REC,U,2)
. Q:INSDFN="" ;OIT/CAS/RCS - 081213 Patch 46, skip insurer with missing pointer
. S POLNUM=$P(REC,U,3)
. S STATE=$P(REC,U,4)
. I INSDFN,STATE S INSDFN=$$TRANSFI(INSDFN,STATE)
. S POLNAM=$P(REC,U,5)
. S POLREL=$P(REC,U,6)
. S POLSEX=$P(REC,U,7)
. S POLIEN=$P(REC,U,9)
. ;IHS/OIT/RCS 07262012 - Patch 44 Fix Medicaid Insurer mapping, HEAT Ticket #73100
. ; S INSTYP=$P($G(^AUTNINS(INSDFN,2)),U),STATENM=""
. S INSTYP=$$INSTYP^AGUTL(INSDFN),STATENM="" ; USE NEW API TO GET INSURER TYPE.
. I STATE S STATENM=$P($G(^DIC(5,STATE,0)),U,2)
. ;I INSDFN,$P($G(^AUTNINS(INSDFN,0)),U)="NEW MEXICO MEDICAID" D
. I INSDFN,INSTYP="D",STATENM'="" D ;Add All sates to the MEDICAID plan mapping, Patch 44
. . I $P(REC,U,10) S INSDFN=$P(REC,U,10) ; replace with plan name
. S CAIDNAM=$P($G(^AUPNMCD(CAIDDFN,21)),U,1)
. S (BEGDAT,ENDDAT)=""
. ;S D1=$O(^AUPNMCD(CAIDDFN,11,"A"),-1)
. ;I D1 DO
. ;. S BEGDAT=$P(^AUPNMCD(CAIDDFN,11,D1,0),U,1)
. ;. S ENDDAT=$P(^AUPNMCD(CAIDDFN,11,D1,0),U,2)
. ;S ARRAY(NUMBER)=INSDFN_U_"CAID"_U_POLNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_CAIDDFN_U_U_POLREL
. ;IHS/OIT/RAN 021710 patch 37 add all dates, not just most recent -BEGIN
. S ABSPD1=0
. F S ABSPD1=$O(^AUPNMCD(CAIDDFN,11,ABSPD1)) Q:ABSPD1="" D
. . S NUMBER=NUMBER+1
. . S BEGDAT=$P(^AUPNMCD(CAIDDFN,11,ABSPD1,0),U,1)
. . S ENDDAT=$P(^AUPNMCD(CAIDDFN,11,ABSPD1,0),U,2)
. . S ARRAY(NUMBER)=INSDFN_U_"CAID"_U_POLNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_CAIDDFN_U_U_POLREL
. ;IHS/OIT/RAN 021710 patch 37 add all dates, not just most recent -END
Q
;
MEDICARE ;
N MBIARRAY,STATUS
S FILE=$O(^DIC("B","MEDICARE ELIGIBLE",0))
S CAREDFN=$O(^AUPNMCR("B",PATDFN,0))
Q:'CAREDFN
;S NUMBER=NUMBER+1 ;RLT 21
S REC=^AUPNMCR(CAREDFN,0)
S STATUS=$$HISTMBI^AUPNMBI(PATDFN,.MBIARRAY) ; /IHS/OIT/RAM ; 15 DEC 17 ; GET THE STATUS OF ALL MBI INFO.
S D1=0
F S D1=$O(^AUPNMCR(CAREDFN,11,D1)) Q:'D1 D
. S REC11=$G(^AUPNMCR(CAREDFN,11,D1,0))
. S COVTYP=$P(REC11,U,3)
. Q:COVTYP="A"
. S INSDFN=$P(REC,U,2)
. S POLNUM=$$GETMCR^AGUTL(CAREDFN) ; /IHS/OIT/RAM ; 18 DEC 17 ; New method for retrieving Policy Number...
. I POLNUM="" S POLNUM=$P(REC,U,3) ; /IHS/OIT/RAM ; 18 DEC 17 ; Old method for retrieving Policy Number...; only if new didn't work.
. S SUFFIX=$P(REC,U,4)
. S POLNAM=""
. S POLREL=$O(^AUTTRLSH("B","SELF",0))
. S POLIEN=""
. S CARENAM=$P($G(^AUPNMCR(CAREDFN,21)),U,1)
. S BEGDAT=$P(REC11,U,1)
. S ENDDAT=$P(REC11,U,2)
. I COVTYP="D" D
.. S INSDFN=$P(REC11,U,4)
.. S CARENAM=$P(REC11,U,5)
.. S POLNUM=$$GETMCR^AGUTL(CAREDFN) ; /IHS/OIT/RAM ; 18 DEC 17 ; New method for retrieving Policy Number...
.. I POLNUM="" S POLNUM=$P(REC11,U,6) ; /IHS/OIT/RAM ; 18 DEC 17 ; Old method for retrieving Policy Number...; only if new didn't work.
. Q:INSDFN="" ;RLT 21 incomplete record
. S NUMBER=NUMBER+1 ;RLT 21
. ;S ARRAY(NUMBER)=INSDFN_U_"CARE"_U_CARENAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_CAREDFN_U_U_POLREL
. S ARRAY(NUMBER)=INSDFN_U_"CARE"_U_CARENAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_CAREDFN_U_D1_U_POLREL
Q
;---
RAILROAD ;RLT - 04/25/06 - Patch 17
; /IHS/OIT/RAM ; THE POLNUM RETRIEVAL SEGMENTS OF THIS ROUTINE AREN'T RIGHT - SHOULD LOOK FOR PIECE #4, NOT 3... IS THIS EVEN USED?
; RAILROAD ALSO USES A PREFIX, NOT A SUFFIX - THE 'SUFFIX' FIELD IS A DATE FIELD!
S FILE=$O(^DIC("B","RAILROAD ELIGIBLE",0))
S RRDFN=$O(^AUPNRRE("B",PATDFN,0))
Q:'RRDFN
;S NUMBER=NUMBER+1 ;RLT 21
S REC=^AUPNRRE(RRDFN,0)
S D1=0
F S D1=$O(^AUPNRRE(RRDFN,11,D1)) Q:'D1 D
. S REC11=$G(^AUPNRRE(RRDFN,11,D1,0))
. S COVTYP=$P(REC11,U,3)
. Q:COVTYP="A"
. S INSDFN=$P(REC,U,2)
. S POLNUM=$$GETRRE^AGUTL(RRDFN) ; /IHS/OIT/RAM ; 18 DEC 17 ; New method for retrieving Policy Number...
. I POLNUM="" S POLNUM=$P(REC,U,3) ; /IHS/OIT/RAM ; 18 DEC 17 ; Old method for retrieving Policy Number...; only if new didn't work.
. S SUFFIX=$P(REC,U,4)
. S POLNAM=""
. S POLREL=$O(^AUTTRLSH("B","SELF",0))
. S POLIEN=""
. S RRNAM=$P($G(^AUPNRRE(RRDFN,21)),U,1)
. S BEGDAT=$P(REC11,U,1)
. S ENDDAT=$P(REC11,U,2)
. I COVTYP="D" D
.. S INSDFN=$P(REC11,U,4)
.. S RRNAM=$P(REC11,U,5)
.. S POLNUM=$$GETRRE^AGUTL(RRDFN) ; /IHS/OIT/RAM ; 18 DEC 17 ; New method for retrieving Policy Number...
.. I POLNUM="" S POLNUM=$P(REC11,U,6) ; /IHS/OIT/RAM ; 18 DEC 17 ; Old method for retrieving Policy Number...; only if new didn't work.
. Q:INSDFN="" ;RLT 21 incomplete record
. S NUMBER=NUMBER+1 ;RLT 21
. ;S ARRAY(NUMBER)=INSDFN_U_"RR"_U_RRNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_RRDFN_U_U_POLREL
. S ARRAY(NUMBER)=INSDFN_U_"RR"_U_RRNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_RRDFN_U_D1_U_POLREL
Q
;---
UPDATE ;
;IHS/SD/lwj 07/21/05 patch 14 (???) adjust logic to delete
; previous entries in ^ABSPCOMB if the patient no longer
; has any insurance entries (Pine Hill)
;
I (('$D(ARRAY))&($D(^ABSPCOMB(PATDFN)))) D
. N DIK,DA
. S DIK="^ABSPCOMB("
. S DA=PATDFN
. D ^DIK
;IHS/SD/lwj 7/21/05 end changes
;
Q:'$D(ARRAY)
F L +^ABSPCOMB(0):10 Q:$T
S FILECNT=$P(^ABSPCOMB(0),U,4)
I '$D(^ABSPCOMB(PATDFN)) S FILECNT=FILECNT+1
S $P(^ABSPCOMB(0),U,4)=FILECNT
S $P(^ABSPCOMB(0),U,3)=PATDFN
L -^ABSPCOMB(0)
K ^ABSPCOMB(PATDFN,1)
S ^ABSPCOMB(PATDFN,0)=PATDFN
S ^ABSPCOMB("B",PATDFN,PATDFN)=""
S D1=0,CNT=0
F S D1=$O(ARRAY(D1)) Q:'D1 DO
. S CNT=CNT+1
. S ^ABSPCOMB(PATDFN,1,D1,0)=ARRAY(D1)
. S ^ABSPCOMB(PATDFN,1,"B",$P(ARRAY(D1),U,1),D1)=""
. S P1=$P(ARRAY(D1),U,2),P2=$P(ARRAY(D1),U,9),P3=+$P(ARRAY(D1),U,10)
. S ^ABSPCOMB(PATDFN,1,"AZ",P1,P2,P3,D1)=""
S ^ABSPCOMB(PATDFN,1,0)="^9002313.11P^"_CNT_"^"_CNT
S DIK="^ABSPCOMB(",DA=PATDFN D IX1^DIK
Q
ABSPOS29 ; IHS/FCS/DRS - BUILD COMBINED INSURANCE ; [ 09/12/2002 10:04 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3,14,15,16,17,21,22,37,44,46,49,50**;JUN 21, 2001;Build 38
+2 ;
+3 ; Copied from VTLCOMB on 08/18/2000
+4 ; Removed $ZT="DX^KCRZT"
+5 ; Verified no other instances of "KCR" or "VTL"
+6 ;
+7 ; DRS 10/16/2000 Follow the FI pointer
+8 ; in ^AUTNINS(insurer,13,state,0),U,2) right now.
+9 ; Site-selectable switch for this, though it perhaps isn't
+10 ; in the setup routines. See $$USEFI, below.
+11 ; This was done because Pawhuska has ^AUTNINS(3,), MEDICAID,
+12 ; set to not billable for RX. But if you follow the pointer
+13 ; to Oklahoma Medicaid, that one is billable.
+14 ; This sets the right medicaid insurer from the very beginning.
+15 ;
+16 ;** vtl 6/26/00 - get elig dates from Pvt Ins. file
+17 ;
+18 ;** this program will search the three files containing insurance
+19 ; information. 1: Private Insurance Eligible
+20 ; 2: Medicare Eligible
+21 ; 3: Medicaid Eligible
+22 ;** It will update ^ABSPCOMB with the data found
+23 ; IHS/SD/RLT - 04/25/06 - Patch 17
+24 ; Added Railroad search
+25 ; 4: Railroad Eligible
+26 ;---
+27 ;IHS/SD/lwj 07/21/05 patch 14 (????) need to adjust UPDATE so
+28 ; that previously entries in ^ABSPCOMB are deleted if the patient
+29 ; no longer has any insurance references
+30 ;---
+31 ;IHS/SD/RLT - 01/24/06 - Patch 15
+32 ; Added new code to access new Medicare D eligibility data.
+33 ;---
+34 ;IHS/SD/RLT - 01/24/06 - Patch 16
+35 ; Added insurer to Medicare D eligibility data.
+36 ;---
+37 ;IHS/SD/RLT - 04/25/06 - Patch 17
+38 ; Added Railroad search.
+39 ;---
+40 ;IHS/SD/RLT - 05/01/07 - Patch 21
+41 ; Changed Medicare and Railroad to capture B and D and
+42 ; to skip incomplete D.
+43 ;---
+44 ;IHS/SD/RLT - 07/25/07 - Patch 22
+45 ; Updated Medicare and RR D lookup.
+46 ;---
+47 ;IHS/CAS/RCS - 08/12/13 - Patch 46
+48 ; Skip Patient records with missing Insurer link
+49 ;
EN(PATDFN) ;EP - from ABSPOS25
+1 ;
+2 NEW ARRAY,BEGDAT,CAIDDFN,CAIDNAM,CAREDFN,CARENAM,CNT,D1,DA,DIK,DIQUIET
+3 NEW ENDDAT,FILE,FILECNT,NUMBER,P1,P2,P3
+4 NEW POLCOV,POLIEN,POLNAM,POLNUM,POLREL,POLSEX,PRVDFN,REC,REC11,SUFFIX
+5 NEW RRDFN,RRPREFIX,RRNAM,INSDFN,COVTYP,INSTYP,STATENM
+6 ;S $ZT="DX^KCRZT"
+7 IF '$GET(PATDFN)
QUIT
+8 ;N (DT,DUZ,PATDFN)
+9 NEW DIQUIET,NUMBER
+10 SET DIQUIET=1
DO DT^DICRW
+11 SET NUMBER=0
+12 DO PRIVATE
+13 DO MEDICAID
+14 DO MEDICARE
+15 DO RAILROAD
+16 DO UPDATE
+17 QUIT
TRANSFI(INSDFN,STATE) ; translate based on the Medicaid FI field
+1 ; flag is set to NOT do the translation
IF '$$USEFI
QUIT INSDFN
+2 NEW X
SET X=$PIECE($GET(^AUTNINS(INSDFN,13,STATE,0)),U,2)
+3 QUIT $SELECT(X:X,1:INSDFN)
USEFI() QUIT '$PIECE($GET(^ABSP(9002313.99,1,"INS")),U,3)
+1 ;---
PRIVATE ;
+1 ;** scan the Private Insurance Eligible file
+2 SET PRVDFN=$ORDER(^AUPNPRVT("B",PATDFN,0))
+3 IF 'PRVDFN
QUIT
+4 SET FILE=$ORDER(^DIC("B","PRIVATE INSURANCE ELIGIBLE",0))
+5 SET D1=0
+6 FOR
SET D1=$ORDER(^AUPNPRVT(PRVDFN,11,D1))
IF 'D1
QUIT
Begin DoDot:1
+7 SET NUMBER=NUMBER+1
+8 SET REC=^AUPNPRVT(PRVDFN,11,D1,0)
+9 SET INSDFN=$PIECE(REC,U,1)
+10 SET POLNUM=$PIECE(REC,U,2)
+11 SET POLCOV=$PIECE(REC,U,3)
+12 SET POLNAM=$PIECE(REC,U,4)
+13 SET POLREL=$PIECE(REC,U,5)
+14 SET BEGDAT=$PIECE(REC,U,6)
+15 SET ENDDAT=$PIECE(REC,U,7)
+16 SET POLIEN=$PIECE(REC,U,8)
+17 ;OIT/CAS/RCS - 081213 Patch 46, skip insurer with missing pointer
IF INSDFN=""
QUIT
+18 ;I POLIEN DO ;vtl 6/26/00 - get elig dates from Pvt Ins. file
+19 ;.; S BEGDAT=$P(^AUPN3PPH(POLIEN,0),U,17)
+20 ;.; S ENDDAT=$P(^AUPN3PPH(POLIEN,0),U,18)
+21 SET ARRAY(NUMBER)=INSDFN_U_"PRVT"_U_POLNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_PRVDFN_U_D1_U_POLREL
End DoDot:1
+22 QUIT
+23 ;---
MEDICAID ;
+1 SET FILE=$ORDER(^DIC("B","MEDICAID ELIGIBLE",0))
+2 SET CAIDDFN=0
+3 FOR
SET CAIDDFN=$ORDER(^AUPNMCD("B",PATDFN,CAIDDFN))
IF 'CAIDDFN
QUIT
Begin DoDot:1
+4 ;IHS/OIT/RAN 021710 patch 37 add all dates, not just most recent -Move following line
+5 ;S NUMBER=NUMBER+1
+6 SET REC=^AUPNMCD(CAIDDFN,0)
+7 SET INSDFN=$PIECE(REC,U,2)
+8 ;OIT/CAS/RCS - 081213 Patch 46, skip insurer with missing pointer
IF INSDFN=""
QUIT
+9 SET POLNUM=$PIECE(REC,U,3)
+10 SET STATE=$PIECE(REC,U,4)
+11 IF INSDFN
IF STATE
SET INSDFN=$$TRANSFI(INSDFN,STATE)
+12 SET POLNAM=$PIECE(REC,U,5)
+13 SET POLREL=$PIECE(REC,U,6)
+14 SET POLSEX=$PIECE(REC,U,7)
+15 SET POLIEN=$PIECE(REC,U,9)
+16 ;IHS/OIT/RCS 07262012 - Patch 44 Fix Medicaid Insurer mapping, HEAT Ticket #73100
+17 ; S INSTYP=$P($G(^AUTNINS(INSDFN,2)),U),STATENM=""
+18 ; USE NEW API TO GET INSURER TYPE.
SET INSTYP=$$INSTYP^AGUTL(INSDFN)
SET STATENM=""
+19 IF STATE
SET STATENM=$PIECE($GET(^DIC(5,STATE,0)),U,2)
+20 ;I INSDFN,$P($G(^AUTNINS(INSDFN,0)),U)="NEW MEXICO MEDICAID" D
+21 ;Add All sates to the MEDICAID plan mapping, Patch 44
IF INSDFN
IF INSTYP="D"
IF STATENM'=""
Begin DoDot:2
+22 ; replace with plan name
IF $PIECE(REC,U,10)
SET INSDFN=$PIECE(REC,U,10)
End DoDot:2
+23 SET CAIDNAM=$PIECE($GET(^AUPNMCD(CAIDDFN,21)),U,1)
+24 SET (BEGDAT,ENDDAT)=""
+25 ;S D1=$O(^AUPNMCD(CAIDDFN,11,"A"),-1)
+26 ;I D1 DO
+27 ;. S BEGDAT=$P(^AUPNMCD(CAIDDFN,11,D1,0),U,1)
+28 ;. S ENDDAT=$P(^AUPNMCD(CAIDDFN,11,D1,0),U,2)
+29 ;S ARRAY(NUMBER)=INSDFN_U_"CAID"_U_POLNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_CAIDDFN_U_U_POLREL
+30 ;IHS/OIT/RAN 021710 patch 37 add all dates, not just most recent -BEGIN
+31 SET ABSPD1=0
+32 FOR
SET ABSPD1=$ORDER(^AUPNMCD(CAIDDFN,11,ABSPD1))
IF ABSPD1=""
QUIT
Begin DoDot:2
+33 SET NUMBER=NUMBER+1
+34 SET BEGDAT=$PIECE(^AUPNMCD(CAIDDFN,11,ABSPD1,0),U,1)
+35 SET ENDDAT=$PIECE(^AUPNMCD(CAIDDFN,11,ABSPD1,0),U,2)
+36 SET ARRAY(NUMBER)=INSDFN_U_"CAID"_U_POLNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_CAIDDFN_U_U_POLREL
End DoDot:2
+37 ;IHS/OIT/RAN 021710 patch 37 add all dates, not just most recent -END
End DoDot:1
+38 QUIT
+39 ;
MEDICARE ;
+1 NEW MBIARRAY,STATUS
+2 SET FILE=$ORDER(^DIC("B","MEDICARE ELIGIBLE",0))
+3 SET CAREDFN=$ORDER(^AUPNMCR("B",PATDFN,0))
+4 IF 'CAREDFN
QUIT
+5 ;S NUMBER=NUMBER+1 ;RLT 21
+6 SET REC=^AUPNMCR(CAREDFN,0)
+7 ; /IHS/OIT/RAM ; 15 DEC 17 ; GET THE STATUS OF ALL MBI INFO.
SET STATUS=$$HISTMBI^AUPNMBI(PATDFN,.MBIARRAY)
+8 SET D1=0
+9 FOR
SET D1=$ORDER(^AUPNMCR(CAREDFN,11,D1))
IF 'D1
QUIT
Begin DoDot:1
+10 SET REC11=$GET(^AUPNMCR(CAREDFN,11,D1,0))
+11 SET COVTYP=$PIECE(REC11,U,3)
+12 IF COVTYP="A"
QUIT
+13 SET INSDFN=$PIECE(REC,U,2)
+14 ; /IHS/OIT/RAM ; 18 DEC 17 ; New method for retrieving Policy Number...
SET POLNUM=$$GETMCR^AGUTL(CAREDFN)
+15 ; /IHS/OIT/RAM ; 18 DEC 17 ; Old method for retrieving Policy Number...; only if new didn't work.
IF POLNUM=""
SET POLNUM=$PIECE(REC,U,3)
+16 SET SUFFIX=$PIECE(REC,U,4)
+17 SET POLNAM=""
+18 SET POLREL=$ORDER(^AUTTRLSH("B","SELF",0))
+19 SET POLIEN=""
+20 SET CARENAM=$PIECE($GET(^AUPNMCR(CAREDFN,21)),U,1)
+21 SET BEGDAT=$PIECE(REC11,U,1)
+22 SET ENDDAT=$PIECE(REC11,U,2)
+23 IF COVTYP="D"
Begin DoDot:2
+24 SET INSDFN=$PIECE(REC11,U,4)
+25 SET CARENAM=$PIECE(REC11,U,5)
+26 ; /IHS/OIT/RAM ; 18 DEC 17 ; New method for retrieving Policy Number...
SET POLNUM=$$GETMCR^AGUTL(CAREDFN)
+27 ; /IHS/OIT/RAM ; 18 DEC 17 ; Old method for retrieving Policy Number...; only if new didn't work.
IF POLNUM=""
SET POLNUM=$PIECE(REC11,U,6)
End DoDot:2
+28 ;RLT 21 incomplete record
IF INSDFN=""
QUIT
+29 ;RLT 21
SET NUMBER=NUMBER+1
+30 ;S ARRAY(NUMBER)=INSDFN_U_"CARE"_U_CARENAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_CAREDFN_U_U_POLREL
+31 SET ARRAY(NUMBER)=INSDFN_U_"CARE"_U_CARENAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_CAREDFN_U_D1_U_POLREL
End DoDot:1
+32 QUIT
+33 ;---
RAILROAD ;RLT - 04/25/06 - Patch 17
+1 ; /IHS/OIT/RAM ; THE POLNUM RETRIEVAL SEGMENTS OF THIS ROUTINE AREN'T RIGHT - SHOULD LOOK FOR PIECE #4, NOT 3... IS THIS EVEN USED?
+2 ; RAILROAD ALSO USES A PREFIX, NOT A SUFFIX - THE 'SUFFIX' FIELD IS A DATE FIELD!
+3 SET FILE=$ORDER(^DIC("B","RAILROAD ELIGIBLE",0))
+4 SET RRDFN=$ORDER(^AUPNRRE("B",PATDFN,0))
+5 IF 'RRDFN
QUIT
+6 ;S NUMBER=NUMBER+1 ;RLT 21
+7 SET REC=^AUPNRRE(RRDFN,0)
+8 SET D1=0
+9 FOR
SET D1=$ORDER(^AUPNRRE(RRDFN,11,D1))
IF 'D1
QUIT
Begin DoDot:1
+10 SET REC11=$GET(^AUPNRRE(RRDFN,11,D1,0))
+11 SET COVTYP=$PIECE(REC11,U,3)
+12 IF COVTYP="A"
QUIT
+13 SET INSDFN=$PIECE(REC,U,2)
+14 ; /IHS/OIT/RAM ; 18 DEC 17 ; New method for retrieving Policy Number...
SET POLNUM=$$GETRRE^AGUTL(RRDFN)
+15 ; /IHS/OIT/RAM ; 18 DEC 17 ; Old method for retrieving Policy Number...; only if new didn't work.
IF POLNUM=""
SET POLNUM=$PIECE(REC,U,3)
+16 SET SUFFIX=$PIECE(REC,U,4)
+17 SET POLNAM=""
+18 SET POLREL=$ORDER(^AUTTRLSH("B","SELF",0))
+19 SET POLIEN=""
+20 SET RRNAM=$PIECE($GET(^AUPNRRE(RRDFN,21)),U,1)
+21 SET BEGDAT=$PIECE(REC11,U,1)
+22 SET ENDDAT=$PIECE(REC11,U,2)
+23 IF COVTYP="D"
Begin DoDot:2
+24 SET INSDFN=$PIECE(REC11,U,4)
+25 SET RRNAM=$PIECE(REC11,U,5)
+26 ; /IHS/OIT/RAM ; 18 DEC 17 ; New method for retrieving Policy Number...
SET POLNUM=$$GETRRE^AGUTL(RRDFN)
+27 ; /IHS/OIT/RAM ; 18 DEC 17 ; Old method for retrieving Policy Number...; only if new didn't work.
IF POLNUM=""
SET POLNUM=$PIECE(REC11,U,6)
End DoDot:2
+28 ;RLT 21 incomplete record
IF INSDFN=""
QUIT
+29 ;RLT 21
SET NUMBER=NUMBER+1
+30 ;S ARRAY(NUMBER)=INSDFN_U_"RR"_U_RRNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_RRDFN_U_U_POLREL
+31 SET ARRAY(NUMBER)=INSDFN_U_"RR"_U_RRNAM_U_POLNUM_U_BEGDAT_U_ENDDAT_U_POLIEN_U_FILE_U_RRDFN_U_D1_U_POLREL
End DoDot:1
+32 QUIT
+33 ;---
UPDATE ;
+1 ;IHS/SD/lwj 07/21/05 patch 14 (???) adjust logic to delete
+2 ; previous entries in ^ABSPCOMB if the patient no longer
+3 ; has any insurance entries (Pine Hill)
+4 ;
+5 IF (('$DATA(ARRAY))&($DATA(^ABSPCOMB(PATDFN))))
Begin DoDot:1
+6 NEW DIK,DA
+7 SET DIK="^ABSPCOMB("
+8 SET DA=PATDFN
+9 DO ^DIK
End DoDot:1
+10 ;IHS/SD/lwj 7/21/05 end changes
+11 ;
+12 IF '$DATA(ARRAY)
QUIT
+13 FOR
LOCK +^ABSPCOMB(0):10
IF $TEST
QUIT
+14 SET FILECNT=$PIECE(^ABSPCOMB(0),U,4)
+15 IF '$DATA(^ABSPCOMB(PATDFN))
SET FILECNT=FILECNT+1
+16 SET $PIECE(^ABSPCOMB(0),U,4)=FILECNT
+17 SET $PIECE(^ABSPCOMB(0),U,3)=PATDFN
+18 LOCK -^ABSPCOMB(0)
+19 KILL ^ABSPCOMB(PATDFN,1)
+20 SET ^ABSPCOMB(PATDFN,0)=PATDFN
+21 SET ^ABSPCOMB("B",PATDFN,PATDFN)=""
+22 SET D1=0
SET CNT=0
+23 FOR
SET D1=$ORDER(ARRAY(D1))
IF 'D1
QUIT
Begin DoDot:1
+24 SET CNT=CNT+1
+25 SET ^ABSPCOMB(PATDFN,1,D1,0)=ARRAY(D1)
+26 SET ^ABSPCOMB(PATDFN,1,"B",$PIECE(ARRAY(D1),U,1),D1)=""
+27 SET P1=$PIECE(ARRAY(D1),U,2)
SET P2=$PIECE(ARRAY(D1),U,9)
SET P3=+$PIECE(ARRAY(D1),U,10)
+28 SET ^ABSPCOMB(PATDFN,1,"AZ",P1,P2,P3,D1)=""
End DoDot:1
+29 SET ^ABSPCOMB(PATDFN,1,0)="^9002313.11P^"_CNT_"^"_CNT
+30 SET DIK="^ABSPCOMB("
SET DA=PATDFN
DO IX1^DIK
+31 QUIT
