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