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

ABSPOS26.m

Go to the documentation of this file. 
  1. ABSPOS26 ; IHS/FCS/DRS - put insurance in order ;   
  1.  ;;1.0;PHARMACY POINT OF SALE;*46,49*;JUN 21, 2001;Build 38
  1.  ; these are most of the rules implementations
  1.  ; called from ABSPOS25
  1.  Q
  1.  ; 
  1.  ;  SEARHC set up notes for their conversion:
  1.  ;  * give BENEFICIARY MEDICAL PLAN a huge 
  1.  ;       DELTA FROM BASE PRIORITY score in 9002313.4
  1.  ;  * Mark MEDICARE as not billable
  1.  ;  * Set up the rules in the table
  1.  ;  * Testing
  1.  ;
  1.  ; Utilities - most deal with pointer into ARRAY(N)
  1. INSIEN(N)          Q $P(ARRAY(N),U)
  1. INSTYPE(N)         Q $P($P(ARRAY(N),U,2),",")
  1. COMBREC(N)         Q ^ABSPCOMB(ABSBPATI,1,$P(ARRAY(N),U,3),0) ; copy of record
  1. FINDTYPE(TYPE)      ;EP - from ABSPOS28
  1.  I TYPE="SELF" S TYPE="SELF PAY"
  1.  N I,RET,N S (I,RET)=0
  1.  F I=1:1:ARRAY(0) D  Q:RET
  1.  . I $$INSTYPE(I)=TYPE S RET=I
  1.  Q RET
  1. WCINS(N)        ; what kind of workers comp is this one?
  1.  ; returns ONLY (wc only), BOTH (doesn't matter), NEVER (no wc claims)
  1.  N X S X=$P($G(^ABSPEI($$INSIEN(N),107)),U)
  1.  ; I X="",$P($G(^AUTNINS($$INSIEN(N),2)),U)="W" S X="ONLY"
  1.  I X="",$$INSTYP^AGUTL($$INSIEN(N))="W" S X="ONLY" ; NEW API FOR INSURER TYPE.
  1.  I X="" S X="BOTH"
  1.  Q X
  1. PHOLDER(N)         Q $P($$COMBREC(N),U,7) ; returns pointer to ^AUPN3PPH
  1. THRUEMPL(N)        N X S X=$$PHOLDER(N) I 'X Q 0
  1.  Q $P($G(^AUPN3PPH(X,0)),U,16) ; pointer to employer (as truth value)
  1. PHOLDDOB(N)         N X S X=$$PHOLDER(N) I 'X Q 0
  1.  Q $P($G(^AUPN3PPH(X,0)),U,19) ; policy holder's date of birth
  1. RELATION(N)        ; return relationship (text)
  1.  N X S X=$P($$COMBREC(N),U,11) I X="" Q "SELF"
  1.  S X=$P($G(^AUTTRLSH(X,0)),U) I X="" Q "SELF"
  1.  Q X
  1. ISSPOUSE(N)        N X S X=$$RELATION(N)
  1.  Q X["SPOUSE"!(X="HUSBAND")!(X="WIFE")
  1. ISCHILD(N)         N X S X=$$RELATION(N)
  1.  I X="SON"!(X="DAUGHTER")!(X="CHILD") Q 1
  1.  I X="STEP CHILD"!(X="NATURAL CHILD") Q 1
  1.  Q 0
  1. ISSELF(N)          Q $$RELATION(N)="SELF"
  1. ISBEN() ; Is ABSBPATI a "Beneficiary" according to local definition?
  1.  Q $D(^ABSP(9002313.99,1,"WRITE OFF SELF PAY","B",$$AUTTBEN(ABSBPATI)))
  1. PTS(N) Q $P(ARRAY(N),U,4)
  1. PTSSET(N,POINTS)   S $P(ARRAY(N),U,4)=POINTS Q
  1. PTSADD(N,DELTA)    D PTSSET(N,$$PTS(N)+DELTA) Q
  1. PTSSUB(N,DELTA)    D PTSADD(N,-DELTA) Q
  1. RULESET(N,RULE)         N X S X=$P(ARRAY(N),U,5) S:X]"" X=X_";"
  1.  S X=X_RULE,$P(ARRAY(N),U,5)=X Q
  1.  ;
  1.  ; Other utilities
  1. AUTTBEN(PATDFN) ;EP - return beneficiary code, from ^AUPNPAT
  1.  N AUPNPAT S AUPNPAT=$O(^AUPNPAT("B",PATDFN,0)) I 'AUPNPAT Q 0 ; imposs?
  1.  N X S X=$P($G(^AUPNPAT(AUPNPAT,11)),U,11) ; pointer to ^AUTTBEN
  1.  ;IHS/OIT/RCS 7/5/2013 Patch 46 - Set beneficairy code to Other if value returns Null
  1.  I X="" S X=8
  1.  Q X
  1. WORKREL()          ; is ABSBVISI a worker's comp visit?
  1.  ; If so, return value is true = pointer to ^AUPNVPOV which has
  1.  ;  the CAUSE OF DX listed as EMPLOYMENT RELATED
  1.  N A,RET S (A,RET)=0
  1.  F  S A=$O(^AUPNVPOV("AD",ABSBVISI,A)) Q:'A  D  Q:RET
  1.  . I $P($G(^AUPNVPOV(A,0)),U,7)=4 S RET=A
  1.  Q RET
  1.  ;
  1.  ; SEARHC0 rule, named SEARHC SPECIAL RULE 0
  1.  ; If Medicare + Commercial Ins. + Native Ben,
  1.  ; then it's a write-off; it shouldn't be billed to the commercial ins.
  1.  ; Make this happen by putting SELF PAY at the front of the line -
  1.  ; then ABSBMAKE->ABSBPB->ABSBPBRX will see SELF PAY + Native Ben
  1.  ; and the account will go to the POS Automatic Writeoff List
  1.  ; (Handle this as one of the RULES.)
  1. SEARHC0(ARRAY,ABSBPATI,ABSBVISI,PTSPLUS,PTSMINUS)         ;
  1.  Q:'$$FINDTYPE("CARE")  ; no Medicare; it doesn't apply
  1.  Q:'$$FINDTYPE("PRVT")  ; no private coverage; rule doesn't apply
  1.  Q:$$FINDTYPE("CAID")  ; has Medicaid; rule doesn't apply
  1.  Q:'$$ISBEN  ; not Native Beneficiary; rule doesn't apply
  1.  N X S X=$$FINDTYPE("SELF") I 'X D  Q  ; find the Self Pay
  1.  . D IMPOSS^ABSPOSUE("DB","TI","Missing SELF PAY in INSURER file",,"SEARHC0",$T(+0))
  1.  D PTSSET(X,9999),RULESET(X,"SEARHC0")
  1.  Q
  1.  ;
  1.  ; WORKCOMP rule, named WORKERS COMP RULE
  1.  ;   If this is a worker's comp visit,
  1.  ;   we might eliminate some insurances.
  1. WORKCOMP(ARRAY,ABSBPATI,ABSBVISI,PTSPLUS,PTSMINUS)        ;
  1.  N WCVISIT S WCVISIT=$$WORKREL ; is ABSBVISI a work-related visit?
  1.  N WCINS
  1.  N I F I=1:1:ARRAY(0) D
  1.  . S WCINS=$$WCINS(I) ; what kind of worker's comp coverage here?
  1.  . I WCINS="ONLY" D  ; insurance is ONLY for worker's comp use
  1.  . . ; so if it's not a wcomp visit, don't pick this insurance
  1.  . . I 'WCVISIT D PTSSET(I,-1000),RULESET(I,"WORKCOMP")
  1.  . E  I WCINS="BOTH" D  ; do nothing, insurance doesn't care
  1.  . E  I WCINS="NEVER" D  ; insurance will not cover worker's comp
  1.  . . ; but it is a wcomp visit, so don't pick this insurance
  1.  . . I WCVISIT D PTSSET(I,-1000),RULESET(I,"WORKCOMP")
  1.  . E  D  ; should never happen
  1.  . . D IMPOSS^ABSPOSUE("DB","TI","bad wcomp setting for insurer",WCINS,"WORKCOMP",$T(+0))
  1.  Q
  1.  ;
  1.  ; NULL rule.                                ABSP*1.0T7*10 ; DRS
  1.  ;  EMPLOYMENT BEFORE PRIVATE INS and EMPLOYMENT BEFORE SPOUSE INS
  1.  ;  rules have been temporarily redirected here because of the 
  1.  ;  problem with the EMPLOYER field in the POLICY HOLDER file
  1.  ;
  1. NULL(A,B,C,D,E) ; ABSP*1.0T7*10
  1.  ; This rule does nothing.
  1.  Q
  1.  ; EMPLOY1 rule, named EMPLOYMENT OVER PRIVATE
  1.  ;    Insurance through employment takes precedence over
  1.  ;    insurance through private purchase.
  1.  ;    We distinguish using the ^AUPN3PPH employer.
  1. EMPLOY1(ARRAY,ABSBPATI,ABSBVISI,PTSPLUS,PTSMINUS) ;
  1.  ; Insurance through employment takes precedence over
  1.  ; insurance through private purchase
  1.  ; Give it a plus, in the neighborhood of 10 points
  1.  N I F I=1:1:ARRAY(0) D
  1.  . I $$INSTYPE(I)'="PRVT" Q
  1.  . I $$THRUEMPL(I) D
  1.  . . Q:'PTSPLUS  D RULESET(I,"EMPLOY1"),PTSADD(I,PTSPLUS)
  1.  . E  D
  1.  . . Q:'PTSMINUS  D RULESET(I,"EMPLOY1"),PTSSUB(I,PTSMINUS)
  1.  Q
  1.  ;
  1.  ; EMPLOY2 rule, named EMPLOYMENT BEFORE SPOUSE
  1.  ;   If you are covered through your employment,
  1.  ;   and also by a policy held by your spouse,
  1.  ;   then the employment-based policy takes precedence.
  1.  ;  Note that the employment-based policy probably already
  1.  ;    has received a bonus, but it will get another bonus
  1.  ;    if RELATIONSHIP TO INSURED is SELF
  1. EMPLOY2(ARRAY,ABSBPATI,ABSBVISI,PTSPLUS,PTSMINUS)          ;
  1.  N I F I=1:1:ARRAY(0) D
  1.  . I $$INSTYPE(I)'="PRVT" Q
  1.  . I $$RELATION(I)="SELF",$$THRUEMPL(I) D
  1.  . . D PTSADD(I,PTSPLUS),RULESET(I,"EMPLOY2")
  1.  Q
  1.  ; SELFRULE, code for POLICY HOLDER IS SELF rule ; ABSP*1.0T7*9
  1. SELFRULE(ARRAY,%1,%2,%3,%4) ; new with ABSP*1.0T7*9
  1.  N I F I=1:1:ARRAY(0) D
  1.  . I $$INSTYPE(I)'="PRVT" Q  ; ABSP*1.0T7*10
  1.  . I $$RELATION(I)="SELF" D PTSADD(I,PTSPLUS),RULESET(I,"SELFRULE")
  1.  Q
  1.  ;
  1.  ; BIRTHDAY rule, named BIRTHDAY RULE
  1. BIRTHDAY(ARRAY,ABSBPATI,ABSBVISI,PTSPLUS,PTSMINUS)         ;
  1.  ;  If the patient is a child and both parents cover the
  1.  ;   child through their work, the parent whose birthday falls 
  1.  ;   first within the calendar year's insurance is primary and
  1.  ;   the other parent's insurance is secondary.  "The birthday rule".
  1.  ;   [law]
  1.  ; Problem:  we have no idea when the parents' birthdays are.
  1.  ; There's no guarantee that they are in our patient file.
  1.  N I F I=1:1:ARRAY(0) D
  1.  . Q:$$INSTYPE(I)'="PRVT"  ; private insurance 
  1.  . Q:'$$THRUEMPL(I)  ; insured through employer's policy
  1.  . Q:'$$ISCHILD(I)  ; child of the policy holder
  1.  . ; Slick trick:  we award PTSPLUS scaled according to when the
  1.  . ; birthday occurs.  If birthday is not on file, default to midyear
  1.  . ; Jan 1 gets entire PTSPLUS amount, Dec 31 gets about 8.2% of it
  1.  . N X S X=$$PHOLDDOB(I),X=$E(X,4,7) S:X="" X="0631" ; no June 31st
  1.  . D PTSADD(I,1-(X-0101/1231)*PTSPLUS*1000\1/1000)
  1.  . D RULESET(I,"BIRTHDAY")
  1.  Q