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