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

ABSPOS25.m

Go to the documentation of this file. 
  1. ABSPOS25 ; IHS/FCS/DRS - insurance auto-selection ;  [ 08/28/2002  2:43 PM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**3,11,13,21,37,46**;JUN 21, 2001;Build 38
  1.  ; Changed: POS always used ^ABSPCOMB, regardless of ILC presence
  1.  Q
  1.  ; Called from:
  1.  ;   ABSPOSQB as called from ABSPOSQ1
  1.  ;   ABSPOSI8 - Screenman input
  1.  ;   ABSPOSD1 - find unbilled prescriptions
  1.  ;   ABSPOS28 - development, research
  1.  ;   ABSPOS32 - survey insurers
  1.  ;
  1.  ;----------------------------------------------------------
  1.  ;IHS/SD/lwj 8/28/02 Reversed the order of TMP used within the 
  1.  ;INSURER subroutine.  This reversed order is done to simplify 
  1.  ;processing of the array and to comply with Cache systems.
  1.  ;
  1.  ;----------------------------------------------------------
  1.  ;IHS/SD/lwj 10/18/04 patch 11 grace days incorrect
  1.  ; In the subroutine GRACE, and invalid reference was made
  1.  ; to the setup file "INS" entry.
  1.  ;----------------------------------------------------------
  1.  ;IHS/SD/lwj 6/28/05 patch 13 lookup of coverage type
  1.  ;altered to not assume a value is in place
  1.  ;----------------------------------------------------------
  1.  ;IHS/SD/RLT - 5/9/07 - Patch 21
  1.  ;       In ELGDATE tag added code to skip insurance records
  1.  ;       with no effective date.
  1.  ;----------------------------------------------------------
  1. INSURER(ARRAY,FRESH,MAXARRAY,FORRX)    ;EP
  1.  ; pass ARRAY by reference (.ARRAY)
  1.  ; given ABSBVISI, ABSBPATI, ABSBRXI, ABSBRXR
  1.  ; $G(FRESH) true if you want to see all insurances, not just
  1.  ;   what's in the default order of billing for this visit
  1.  ;   (to be implemented - relevant to ILC new A/R package only)
  1.  ;   Default is FRESH = 1 = true
  1.  ; $G(MAXARRAY) if you want no more than this many to be returned
  1.  ;   Default is 0 = no limit
  1.  ;   Working copy of array may be larger than what you specify.
  1.  ; ABSBRXI, ABSBRXR needed only for precision in date filled;
  1.  ;  you can send them as both false and ABSBVISI date will be used.
  1.  ; FORRX = true if this is being called for pharmacy (default = TRUE)
  1.  ;
  1.  ; Fill ARRAY(n) with InsurerIEN^PINS piece^ABSPCOMB n^score^rules
  1.  ;      InsurerIEN points to ^AUTNINS(*)
  1.  ;      PINS piece is   type,D0,D1
  1.  ;          D1 = pointer to subindex of AUPNPRVT; 0 for caid, care
  1.  ;      ABSPCOMB n pointer to ^ABSPCOMB(ABSBPATI,1,*)v
  1.  ;      score = how many points scored in ranking the insurances
  1.  ;      RULES = ";"-delimited list of rules which affected this choice
  1.  ;
  1.  ; and set ARRAY(0)=count^count of prvt^count of care^count of caid
  1.  ; Set ARRAY("ORDER")=$$ returned value from ABSPOS26
  1. A ;N (ABSBVISI,ABSBPATI,ABSBRXI,ABSBRXR,DUZ,DT,U,DEBUG,ARRAY,FRESH,MAXARRAY,FORRX)
  1.  N ONDATE
  1.  I '$D(FRESH) S FRESH=1
  1.  I '$G(MAXARRAY) S MAXARRAY=3 ; send MAXARRAY=0 same as "no limit"
  1.  I '$D(FORRX) S FORRX=1
  1.  K ARRAY S ARRAY(0)=0
  1.  I '$D(DEBUG) N DEBUG S DEBUG=0
  1.  E  I DEBUG D
  1.  . W $T(+0)," for ABSBVISI=",$G(ABSBVISI),", ABSBPATI=",ABSBPATI
  1.  . W ", ABSBRXI=",ABSBRXI,", ABSBRXR=",ABSBRXR
  1.  . W !
  1.  ;
  1.  ; ABSPOS29 is different from VTLCOMB in that ABSPOS29 takes the
  1.  ;   Medicaid FI field into account - ABSPOS29 translates the IEN 3
  1.  ;   into a specific state's IEN. (But site-specific switchable)
  1. B ;I $$ILCAR D
  1.  ;. D EN^VTLCOMB(ABSBPATI) ; update in the combined insurance file
  1.  ;E  D
  1.  D  ; everybody does the point of sale version:
  1.  . D EN^ABSPOS29(ABSBPATI) ; copied from VTLCOMB but in ABSPOS namespace
  1.  ;
  1.  ; We are interested in eligibility on the date filled
  1.  ; (Or visit date, if date filled is missing or not supplied)
  1.  ; (Or just take DT, if you don't even have a visit pointer)
  1.  ;
  1.  ;I ABSBRXR S ONDATE=$P(^PSRX(ABSBRXI,1,ABSBRXR,0),U)
  1.  ;;IHS/OIT/RAN 021810 patch 37 Prevent UNDEFINED errors here -BEGIN
  1.  I $G(ABSBRXR) S ONDATE=$P($G(^PSRX(ABSBRXI,1,ABSBRXR,0)),U)
  1.  ;;IHS/OIT/RAN 021810 patch 37 Prevent UNDEFINED errors here -END
  1.  E  I ABSBRXI S ONDATE=$P(^PSRX(ABSBRXI,2),U,2)
  1.  E  S ONDATE=0
  1.  I 'ONDATE I $G(ABSBVISI) S ONDATE=$P(^AUPNVSIT(ABSBVISI,0),U)\1
  1.  I 'ONDATE S ONDATE=DT
  1.  D GATHER ; PRVT, CAID, and CARE types into ARRAY()
  1.  D SELF ; tack on a SELF PAY at the end
  1. F ;
  1.  ; Now all of the insurances are in the array with initial scores.
  1.  ; Adjust the scores based on the rules in effect for this site.
  1.  ;
  1.  N ORDER,IEN,RULE,ROUTINE,PTSPLUS,PTSMINUS,STOP S (ORDER,STOP)=""
  1.  F  D  Q:ORDER=""
  1.  . S ORDER=$O(^ABSP(9002313.99,1,"INS RULES","B",ORDER))
  1.  . Q:ORDER=""  S IEN=""
  1.  . F  D  Q:IEN=""
  1.  . . S IEN=$O(^ABSP(9002313.99,1,"INS RULES","B",ORDER,IEN))
  1.  . . I IEN="" Q
  1.  . . N X S X=^ABSP(9002313.99,1,"INS RULES",IEN,0)
  1.  . . S RULE=$P(X,U,2),PTSPLUS=$P(X,U,3),PTSMINUS=$P(X,U,4)
  1.  . . ;IHS/OIT/RCS 7/8/2013 Patch 46 - If Rule is Null then Quit, nothing to run
  1.  . . I RULE="" Q
  1.  . . S ROUTINE=$TR($P(^ABSPF(9002313.94,RULE,0),U,2),"~","^")
  1.  . . ; these rules are all in ABSPOS26, at least to start with
  1.  . . X "DO "_ROUTINE_"(.ARRAY,ABSBPATI,ABSBVISI,PTSPLUS,PTSMINUS)"
  1.  ;
  1.  ; Finally, put the insurances in order of their scores
  1.  ; IHS/SD/lwj 8/28/02 reversed order of TMP for easier reading
  1.  ; add to comply with Cache systems
  1.  N TMP,I,II,PTS F I=1:1:ARRAY(0) D
  1.  . S PTS=$P(ARRAY(I),U,4)
  1.  . I PTS<0 D  Q  ; negative points and you don't get considered
  1.  . . I $G(DEBUG) W "Not counting ARRAY(",I,")=",ARRAY(I),!
  1.  . ;IHS/SD/lwj 8/28/02 nxt line remarked out - following added
  1.  . ;S TMP(PTS,I)=ARRAY(I)
  1.  . S TMP(0-PTS,I)=ARRAY(I)  ;reverse for Cache 
  1.  K ARRAY
  1.  ;IHS/SD/lwj 8/28/02 Cache cannot handle a reverse $O on arrays
  1.  ; so we reversed the order of the TMP array and can now simply
  1.  ; read it.  The next line was remarked out and the following added.
  1.  ;  S PTS="",II=0 F  S PTS=$O(TMP(PTS),-1) Q:PTS=""  D
  1.  S PTS="",II=0 F  S PTS=$O(TMP(PTS)) Q:PTS=""  D   ;in high to low now
  1.  . S I=0 F  S I=$O(TMP(PTS,I)) Q:'I  D
  1.  . . S X=TMP(PTS,I) Q:$P(X,U,4)<0
  1.  . . S II=II+1,ARRAY(II)=TMP(PTS,I)
  1.  S ARRAY(0)=II
  1.  ; Since we did a NEW() earlier, junk like II, TMP, etc. is deleted.
  1.  Q:$Q ARRAY(0) Q
  1.  ;
  1. GRACE(INSIEN)     ; 
  1.  N RET S RET=$P($G(^ABSPEI(INSIEN,100)),U,8)
  1.  ;IHS/SD/lwj 10/18/04 nxt ln rmkd out, following added
  1.  ;I RET="" S RET=$P($G(^ABSP(9002313.99,"INS")),U)
  1.  I RET="" S RET=$P($G(^ABSP(9002313.99,1,"INS")),U)
  1.  I RET="" S RET=30 ; the default default
  1.  Q RET
  1. SELF ; add SELF PAY to the list
  1.  N INSIEN
  1.  S INSIEN=$P($G(^ABSP(9002313.99,1,0)),U,5)
  1.  I 'INSIEN S INSIEN=$O(^AUTNINS("B","SELF PAY",0))
  1.  I 'INSIEN Q
  1.  D ADD(INSIEN,"SELF PAY","",$$TYPEPTS("SELF"))
  1.  Q
  1. ILCAR() Q $P(^ABSP(9002313.99,1,"A/R INTERFACE"),U)=0 ; is ILC A/R pkg here?
  1. GATHER ; return the count of how many of these we put in the array
  1.  N COUNT,DFN,X S (COUNT,DFN)=0
  1.  F  S DFN=$O(^ABSPCOMB(ABSBPATI,1,DFN)) Q:'DFN  D
  1.  . S X=^ABSPCOMB(ABSBPATI,1,DFN,0)
  1.  . N INSIEN,TYPE S INSIEN=$P(X,U),TYPE=$P(X,U,2)
  1.  . N POINTS S POINTS=$$TYPEPTS(TYPE) ; based on type, how many pts 
  1.  . S POINTS=DFN/10000+POINTS ;higher DFN is most recent, give it an edge
  1.  . S POINTS=POINTS+$P($G(^ABSPEI(INSIEN,104)),U) ; insurer's delta value
  1.  . ; Check RX BILLING STATUS for this insurer - may be "U" = unbillable
  1.  . ; There's also a field in the ^AUPNPRVT record about RX billing
  1.  . ; if it's unbillable for RX, give it a score of -1000
  1.  . ; Keep it in the array because some rules may need to refer to it.
  1.  . ; (Example:  SEARHC0^ABSPOS26)
  1.  . I FORRX,$P($G(^AUTNINS(INSIEN,2)),U,3)="U" S POINTS=-1000
  1.  . I FORRX,'$$DRUGCOVG(ABSBPATI,$P(X,U,10)) S POINTS=-1000
  1.  . I '$$ELGDATE($P(X,U,5,6),INSIEN) D:DEBUG>99  Q  ; it's expired
  1.  . D ADD(INSIEN,$P(X,U,2)_","_$P(X,U,9)_","_$P(X,U,10),DFN,POINTS)
  1.  . S COUNT=COUNT+1
  1.  Q:$Q ARRAY(0) Q
  1. TYPEPTS(TYPE)      ;
  1.  N X S X=$G(^ABSP(9002313.99,1,"INS BASE SCORES"))
  1.  I TYPE="PRVT" Q +$P(X,U)
  1.  I TYPE="CARE" Q +$P(X,U,2)
  1.  I TYPE="CAID" Q +$P(X,U,3)
  1.  I TYPE="RR" Q +$P(X,U,4)
  1.  I TYPE="SELF" Q +$P(X,U,5)
  1.  D IMPOSS^ABSPOSUE("DB","TI","type of insurance",,"TYPEPTS",$T(+0))
  1.  Q 0 ; if you ignore
  1. ELGDATE(FROMTO,INSIEN)          ; does ONDATE fall in the FROM^TO range?
  1.  ; need INSIEN, too!  for $$ADDGRACE
  1.  I DEBUG>99 D
  1.  . N DEBUG S DEBUG=0
  1.  . W "$$ELGDATE(",FROMTO,") testing INSIEN: "_INSIEN_" for ONDATE=",ONDATE,"..."
  1.  . W $$ELGDATE(FROMTO),!
  1.  N FROM,TO S FROM=$P(FROMTO,U),TO=$P(FROMTO,U,2)
  1.  I 'FROM Q 0        ;RLT 21
  1.  I FROM,ONDATE<FROM Q 0
  1.  I 'TO Q 1
  1.  I ONDATE'>TO Q 1
  1.  I $G(INSIEN),ONDATE'>$$ADDGRACE(TO,INSIEN) Q 1
  1.  Q 0
  1. ADDGRACE(X1,INSIEN)     ; add grace period to the given date ; have INSIEN set, too
  1.  N X2,X,%H S X2=$$GRACE(INSIEN) D C^%DTC
  1.  ;I DEBUG W "Added grace period ",$$GRACE(INSIEN)," to ",TO," giving ",X,!
  1.  Q X
  1.  ;
  1. DRUGCOVG(D0,D1)    ;
  1.  I 'D1 Q 1 ; not private?  or no private pointer?
  1.  N X S X=$G(^AUPNPRVT(D0,11,D1,0))
  1.  S X=$P(X,U,3) I 'X Q 1 ; follow coverage to ^AUTTPIC
  1.  ;IHS/SD/lwj patch 13 added $G to next line
  1.  N Y S Y=$P($G(^AUTTPIC(X,0)),U)
  1.  ;I X["INPATIENT ONLY" Q 0
  1.  ;I X["MEDICARE"!(X["PART A")!(X["PART B") Q 0
  1.  ; I X?.E1P1"DENTAL".E Q 0 ; contains DENTAL in its name
  1.  ; I X?1"DENTAL"1P.E Q 0 ; contains DENTAL in its name
  1.  Q 1 ; didn't explictly say it doesn't cover drugs
  1. ADD(INSIEN,PINS,ABSPCOMB,POINTS)   ;
  1.  I $P(PINS,",",3)="" S $P(PINS,",",3)=0
  1.  S ARRAY(0)=ARRAY(0)+1
  1.  S ARRAY(ARRAY(0))=INSIEN_U_PINS_U_ABSPCOMB_U_POINTS
  1.  Q