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

ABSPOS29.m

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