APCLOS21 ; IHS/CMI/LAB - continuuation of APCLOS2 ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
THIRD ;ENTRY POINT
S APCLOS="APCLOS" S APCLACE=APCLFYB,APCLACED=APCLFYE
S APCLMCR="MCRA",APCLVAL="A" D MCRA
S APCLMCR="MCRB",APCLVAL="B" D MCRA
S APCLMCR="MCRD",APCLVAL="D" D
.D MCRA
.I $D(APCLGOT) Q
.S X=$$PIDD(DFN,APCLACE) ;check for D- in private insurer name
.I X S ^(APCLMCR)=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,APCLMCR)):(+^(APCLMCR)+1),1:1)
D PI,MCD
S APCLOS="APCLOSP" S APCLACE=APCLPYB,APCLACED=APCLPYE
S APCLMCR="MCRA",APCLVAL="A" D MCRA
S APCLMCR="MCRB",APCLVAL="B" D MCRA
;S APCLMCR="MCRD",APCLVAL="D" D MCRA
S APCLMCR="MCRD",APCLVAL="D" D
.D MCRA
.I $D(APCLGOT) Q
.S X=$$PIDD(DFN,APCLACE) ;check for D- in private insurer name
.I X S ^(APCLMCR)=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,APCLMCR)):(+^(APCLMCR)+1),1:1)
D PI,MCD
Q
MCRA ;
K APCLGOT
Q:'$D(^AUPNMCR(DFN,11))
Q:'$D(^DPT(DFN,0))
I $D(^DPT(DFN,.35)),$P(^(.35),U)]"",$P(^(.35),U)<APCLACED Q
K APCLGOT S APCLMDFN=0 F S APCLMDFN=$O(^AUPNMCR(DFN,11,APCLMDFN)) Q:APCLMDFN'=+APCLMDFN!($D(APCLGOT)) D MCRA2
Q:'$D(APCLGOT)
S ^(APCLMCR)=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,APCLMCR)):(+^(APCLMCR)+1),1:1)
Q
;
MCRA2 ;
Q:APCLVAL'[$P(^AUPNMCR(DFN,11,APCLMDFN,0),U,3)
Q:$P(^AUPNMCR(DFN,11,APCLMDFN,0),U)>APCLACED ;quit if policy started after the end of time frame
I $P(^AUPNMCR(DFN,11,APCLMDFN,0),U,2)]"",$P(^(0),U,2)<APCLACE Q ;quit if policy ended before beginning of time frame
S APCLGOT=""
Q
;
PI ;
I $$PI^AUPNPAT(DFN,APCLACE) S ^("PI")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"PI")):(+^("PI")+1),1:1)
Q
MCD ;
I $$MCD^AUPNPAT(DFN,APCLACE) S ^("MCD")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"MCD")):(+^("MCD")+1),1:1)
Q
PIDD(P,D) ;EP - Is patient P private insurance MEDICARE D eligible on date D. 1= yes, 0=no.
; I = IEN
; Y = 1:yes, 0:no
; X = Pointer to INSURER file.
I '$G(P) Q 0
I '$G(D) Q 0
NEW I,Y,X
S Y=0,U="^"
I '$D(^DPT(P,0)) G PIDDX
I $P(^DPT(P,0),U,19) G PIDDX
I '$D(^AUPNPAT(P,0)) G PIDDX
I '$D(^AUPNPRVT(P,11)) G PIDDX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PIDDX
S I=0
F S I=$O(^AUPNPRVT(P,11,I)) Q:I'=+I D
. Q:$P(^AUPNPRVT(P,11,I,0),U)=""
. S X=$P(^AUPNPRVT(P,11,I,0),U) Q:X=""
. S G=0
. I $E($P(^AUTNINS(X,0),U),1,2)="D-" S G=1
. I $P($G(^AUTNINS(X,2)),U)="MD" S G=1
. Q:'G
. Q:$P(^AUPNPRVT(P,11,I,0),U,6)>D
. I $P(^AUPNPRVT(P,11,I,0),U,7)]"",$P(^(0),U,7)<D Q
. S Y=1
.Q
PIDDX ;
Q Y
APCLOS21 ; IHS/CMI/LAB - continuuation of APCLOS2 ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
THIRD ;ENTRY POINT
+1 SET APCLOS="APCLOS"
SET APCLACE=APCLFYB
SET APCLACED=APCLFYE
+2 SET APCLMCR="MCRA"
SET APCLVAL="A"
DO MCRA
+3 SET APCLMCR="MCRB"
SET APCLVAL="B"
DO MCRA
+4 SET APCLMCR="MCRD"
SET APCLVAL="D"
Begin DoDot:1
+5 DO MCRA
+6 IF $DATA(APCLGOT)
QUIT
+7 ;check for D- in private insurer name
SET X=$$PIDD(DFN,APCLACE)
+8 IF X
SET ^(APCLMCR)=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,APCLMCR)):(+^(APCLMCR)+1),1:1)
End DoDot:1
+9 DO PI
DO MCD
+10 SET APCLOS="APCLOSP"
SET APCLACE=APCLPYB
SET APCLACED=APCLPYE
+11 SET APCLMCR="MCRA"
SET APCLVAL="A"
DO MCRA
+12 SET APCLMCR="MCRB"
SET APCLVAL="B"
DO MCRA
+13 ;S APCLMCR="MCRD",APCLVAL="D" D MCRA
+14 SET APCLMCR="MCRD"
SET APCLVAL="D"
Begin DoDot:1
+15 DO MCRA
+16 IF $DATA(APCLGOT)
QUIT
+17 ;check for D- in private insurer name
SET X=$$PIDD(DFN,APCLACE)
+18 IF X
SET ^(APCLMCR)=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,APCLMCR)):(+^(APCLMCR)+1),1:1)
End DoDot:1
+19 DO PI
DO MCD
+20 QUIT
MCRA ;
+1 KILL APCLGOT
+2 IF '$DATA(^AUPNMCR(DFN,11))
QUIT
+3 IF '$DATA(^DPT(DFN,0))
QUIT
+4 IF $DATA(^DPT(DFN,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<APCLACED
QUIT
+5 KILL APCLGOT
SET APCLMDFN=0
FOR
SET APCLMDFN=$ORDER(^AUPNMCR(DFN,11,APCLMDFN))
IF APCLMDFN'=+APCLMDFN!($DATA(APCLGOT))
QUIT
DO MCRA2
+6 IF '$DATA(APCLGOT)
QUIT
+7 SET ^(APCLMCR)=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,APCLMCR)):(+^(APCLMCR)+1),1:1)
+8 QUIT
+9 ;
MCRA2 ;
+1 IF APCLVAL'[$PIECE(^AUPNMCR(DFN,11,APCLMDFN,0),U,3)
QUIT
+2 ;quit if policy started after the end of time frame
IF $PIECE(^AUPNMCR(DFN,11,APCLMDFN,0),U)>APCLACED
QUIT
+3 ;quit if policy ended before beginning of time frame
IF $PIECE(^AUPNMCR(DFN,11,APCLMDFN,0),U,2)]""
IF $PIECE(^(0),U,2)<APCLACE
QUIT
+4 SET APCLGOT=""
+5 QUIT
+6 ;
PI ;
+1 IF $$PI^AUPNPAT(DFN,APCLACE)
SET ^("PI")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"PI")):(+^("PI")+1),1:1)
+2 QUIT
MCD ;
+1 IF $$MCD^AUPNPAT(DFN,APCLACE)
SET ^("MCD")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"MCD")):(+^("MCD")+1),1:1)
+2 QUIT
PIDD(P,D) ;EP - Is patient P private insurance MEDICARE D eligible on date D. 1= yes, 0=no.
+1 ; I = IEN
+2 ; Y = 1:yes, 0:no
+3 ; X = Pointer to INSURER file.
+4 IF '$GET(P)
QUIT 0
+5 IF '$GET(D)
QUIT 0
+6 NEW I,Y,X
+7 SET Y=0
SET U="^"
+8 IF '$DATA(^DPT(P,0))
GOTO PIDDX
+9 IF $PIECE(^DPT(P,0),U,19)
GOTO PIDDX
+10 IF '$DATA(^AUPNPAT(P,0))
GOTO PIDDX
+11 IF '$DATA(^AUPNPRVT(P,11))
GOTO PIDDX
+12 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PIDDX
+13 SET I=0
+14 FOR
SET I=$ORDER(^AUPNPRVT(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+15 IF $PIECE(^AUPNPRVT(P,11,I,0),U)=""
QUIT
+16 SET X=$PIECE(^AUPNPRVT(P,11,I,0),U)
IF X=""
QUIT
+17 SET G=0
+18 IF $EXTRACT($PIECE(^AUTNINS(X,0),U),1,2)="D-"
SET G=1
+19 IF $PIECE($GET(^AUTNINS(X,2)),U)="MD"
SET G=1
+20 IF 'G
QUIT
+21 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+22 IF $PIECE(^AUPNPRVT(P,11,I,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+23 SET Y=1
+24 QUIT
End DoDot:1
PIDDX ;
+1 QUIT Y
