- 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
