ACHSRPIN ; IHS/ITSC/PMF - retrieve ALL insurances, display, choose ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,13,21,27**;JUN 11,2001;Build 43
;ACHS*3.1*3 whole routine new
;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
;ACHS3.1*21 9.18.2011;IHS/OIT/FCJ ADDED TEST FOR DOS VS ELIG DATES
;ACHS3.1*27 12/12/2017 IHS.OIT.FCJ ADDED NEW MBI AND D COVERAGE
;
;INPUT: DFN
;
;OUTPUT: INS array, list all insurances
;
;
GET ;EP- FROM ACHSDN2A AND DOC ENTRY-ACHSA1
K INS
;
I $D(^AUPNMCR(DFN)) D MCR
I $D(^AUPNMCD("B",DFN)) D MCD
I $D(^AUPNRRE(DFN,0)) D RRE
I $D(^AUPNPRVT(DFN,11)) D PVT
;
K I,JJ
Q
;
;
;
MCR ;
;I used first to carry this patient's medicare data,
; later a subscript var
;X the first three pieces to display about this patient's medicare
;
S I=$G(^AUPNMCR(DFN,0))
;
;if no medicare number, stop
;I '$P(I,U,3) Q ;ACHS*3.1*27 NEW NUMBER STORED IN PAT REG
;S X=$P($G(^AUTNINS($P(I,U,2),0)),U)_U_$P(I,U,3)_U ;ACHS*3.1*27
N ACHSMCR,ACHSMCRS S ACHSMCR=0,ACHSMCRS=""
S X=$P($G(^AUTNINS($P(I,U,2),0)),U)
S ACHSMCR=$$GETMBI^AUPNMBI(DFN,DT,0) ;ACHS*3.1*27
I +ACHSMCR<1 S ACHSMCR=$P(I,U,3) I $P(I,U,4)'="" S ACHSMCRS=^AUTTMCS($P(I,U,4),0) ;ACHS*3.1*27
Q:+ACHSMCR<1 ;ACHS*3.1*27
;
;GO THRU 'MEDICARE ELIGIBLE' FILE
S I=0 F S I=$O(^AUPNMCR(DFN,11,I)) Q:+I=0 D
. ;ACHS*3.1*27 MULTIPLE CHANGES FOR COV TYPE "D"
.S DAT=$G(^AUPNMCR(DFN,11,I,0)) ;ACHS*3.1*21
.I $D(ACHDDOS),ACHDDOS<$P(DAT,U) Q ;ACHS*3.1*21
.I $D(ACHDDOS),$P(DAT,U,2)'="",ACHDDOS>$P(DAT,U,2) Q ;ACHS*3.1*21
.S INS=$G(INS)+1
.S INS(INS)=X
.I $P($G(DAT),U,3)?1"D" S INS(INS)=INS(INS)_U_$P($G(DAT),U,6)_U_""
.E S INS(INS)=INS(INS)_U_ACHSMCR_U_ACHSMCRS
.S INS(INS)=INS(INS)_U_$P($G(^AUPNMCR(DFN,11,I,0)),U,3)_U_$$MDY($P($G(^AUPNMCR(DFN,11,I,0)),U))_U_$$MDY($P($G(^AUPNMCR(DFN,11,I,0)),U,2))_U_"M"_U_I
Q
;
;LETS LOOK AT POSSIBLE MEDICAID COVERAGE
MCD ;
K ^TMP("ACHSRP31",$J,"MCD")
S I=0 F S I=$O(^AUPNMCD("B",DFN,I)) Q:'I S JJ=0 F S JJ=$O(^AUPNMCD(I,11,JJ)) Q:'JJ D
. S ^TMP("ACHSRP31",$J,"MCD",9999999-JJ)=$G(^AUPNMCD(I,11,JJ,0))
. S $P(^TMP("ACHSRP31",$J,"MCD",9999999-JJ),U,4,6)=$P($G(^AUPNMCD(I,0)),U,2,4)
. S $P(^TMP("ACHSRP31",$J,"MCD",9999999-JJ),U,7,8)=I_U_JJ
. Q
;
;ACHS*3.1*21 MODIFIED TO DISPLAY ALL AND TEST FOR DOS
;S JJ=0 F ACHS=1:1:4 S JJ=$O(^TMP("ACHSRP31",$J,"MCD",JJ)) Q:'JJ I $P(^TMP("ACHSRP31",$J,"MCD",JJ),U,6)]"",$D(^DIC(5,$P(^(JJ),U,6),0)) S $P(^TMP("ACHSRP31",$J,"MCD",JJ),U,6)=$P(^(0),U,2)
;S I=0 F ACHS=1:1:4 S I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I D
S JJ=0,ACHS=0 F S ACHS=ACHS+1,JJ=$O(^TMP("ACHSRP31",$J,"MCD",JJ)) Q:'JJ I $P(^TMP("ACHSRP31",$J,"MCD",JJ),U,6)]"",$D(^DIC(5,$P(^(JJ),U,6),0)) S $P(^TMP("ACHSRP31",$J,"MCD",JJ),U,6)=$P(^(0),U,2)
S I=0,ACHS=0 F S ACHS=ACHS+1,I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I D
.S DAT=^TMP("ACHSRP31",$J,"MCD",I) ;ACHS*3.1*21
.I $D(ACHDDOS),ACHDDOS<$P(DAT,U) Q ;ACHS*3.1*21
.I $D(ACHDDOS),$P(DAT,U,2)'="",ACHDDOS>$P(DAT,U,2) Q ;ACHS*3.1*21
. S INS=$G(INS)+1
. S INS(INS)=$P(^AUTNINS($P(DAT,U,4),0),U)_U_$P(DAT,U,5)_U_$P(DAT,U,6)_U_$P(DAT,U,3)_U_$$MDY($P(DAT,U))_U_$$MDY($P(DAT,U,2))_U_"C"_U_$P(DAT,U,7,8)
;
K DAT,^TMP("ACHSRP31",$J,"MCD")
Q
;
RRE ;
;ACHS*3.1*27 REWROTE TO PRINT NEW MBI
S FIRST="" N ACHSMBI
I $P($G(^AUPNRRE(DFN,0)),U,2)'="" S FIRST=$P($G(^AUTNINS($P(^AUPNRRE(DFN,0),U,2),0)),U)
S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
I +ACHSMBI<1 D
.I $P($G(^AUPNRRE(DFN,0)),U,3)'="" S FIRST=FIRST_U_$P(^AUTTRRP($P(^AUPNRRE(DFN,0),U,3),0),U)
.E S FIRST=FIRST_U_""
.S FIRST=FIRST_U_$P($G(^AUPNRRE(DFN,0)),U,4)
E S FIRST=FIRST_"^^"_ACHSMBI
;
;******LOOP THRU RAILROAD ELIGIBLE FILE
S JJ=0 F S JJ=$O(^AUPNRRE(DFN,11,JJ)) Q:JJ="" D
.S DAT=$P(^AUPNRRE(DFN,11,JJ,0),U,3) ;ACHS*3.1*21
.I $D(ACHDDOS),ACHDDOS<$P(DAT,U) Q ;ACHS*3.1*21
.I $D(ACHDDOS),$P(DAT,U,2)'="",ACHDDOS>$P(DAT,U,2) Q ;ACHS*3.1*21
. S INS=$G(INS)+1,INS(INS)=FIRST_U_$P(^AUPNRRE(DFN,11,JJ,0),U,3)_U_$$MDY($P(^(0),U))_U_$$MDY($P(^(0),U,2))_U_"R"_U_JJ
. Q
Q
;
PVT ;
S I=0 F S I=$O(^AUPNPRVT(DFN,11,I)) Q:'I D
. ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
. ;S INS=$G(INS)+1,INS(INS)=$E($P(^AUTNINS($P(^AUPNPRVT(DFN,11,I,0),U),0),U),1,26)_U_$P(^AUPNPRVT(DFN,11,I,0),U,2)
.S ACHSPINS=^AUPNPRVT(DFN,11,I,0)
.I $D(ACHDDOS),ACHDDOS<$P(ACHSPINS,U,6) Q ;ACHS*3.1*21
.I $D(ACHDDOS),$P(ACHSPINS,U,7)'="",ACHDDOS>$P(ACHSPINS,U,7) Q ;ACHS*3.1*21
.S INS=$G(INS)+1,INS(INS)=$E($P(^AUTNINS($P(ACHSPINS,U),0),U),1,26)
.I $P(ACHSPINS,U,8),$D(^AUPN3PPH($P(ACHSPINS,U,8),0)) S INS(INS)=INS(INS)_U_$P(^AUPN3PPH($P(ACHSPINS,U,8),0),U,4)
. ;I $P(^AUPNPRVT(DFN,11,I,0),U,3) S $P(INS(INS),U,4)=$P(^AUTTPIC($P(^(0),U,3),0),U)
. I $P(ACHSPINS,U,8),$P(^AUPN3PPH($P(ACHSPINS,U,8),0),U,5) S $P(INS(INS),U,4)=$P(^AUTTPIC($P(^AUPN3PPH($P(ACHSPINS,U,8),0),U,5),0),U)
. S $P(INS(INS),U,5,6)=$$MDY($P(^AUPNPRVT(DFN,11,I,0),U,6))_U_$$MDY($P(^(0),U,7))_U_"P"_U_I
K ACHSPINS Q
;
MDY(X) ;
Q $E(X,4,7)_$E(X,2,3)
;
PRT ;EP - FROM ACHSDN2A AND DOCUMENT ENTRY-ACHSA1
;write out the array INS
;
W !!,?5,"Type of Coverage",?35,"Policy #",?55,"Cov. type EligDt TermDt",!,?5,"----------------",?35,"--------",?55,"--------- ------ ------"
F JJ="" F CNT=1:1 S JJ=$O(INS(JJ)) Q:JJ="" S DATA=INS(JJ) W !,CNT,".",?5,$P(DATA,U,1),?35,$P(DATA,U,2)," ",$P(DATA,U,3),?55,$P(DATA,U,4),?66,$P(DATA,U,5),?73,$P(DATA,U,6)
K CNT,DATA,JJ
Q
ACHSRPIN ; IHS/ITSC/PMF - retrieve ALL insurances, display, choose ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,13,21,27**;JUN 11,2001;Build 43
+2 ;ACHS*3.1*3 whole routine new
+3 ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
+4 ;ACHS3.1*21 9.18.2011;IHS/OIT/FCJ ADDED TEST FOR DOS VS ELIG DATES
+5 ;ACHS3.1*27 12/12/2017 IHS.OIT.FCJ ADDED NEW MBI AND D COVERAGE
+6 ;
+7 ;INPUT: DFN
+8 ;
+9 ;OUTPUT: INS array, list all insurances
+10 ;
+11 ;
GET ;EP- FROM ACHSDN2A AND DOC ENTRY-ACHSA1
+1 KILL INS
+2 ;
+3 IF $DATA(^AUPNMCR(DFN))
DO MCR
+4 IF $DATA(^AUPNMCD("B",DFN))
DO MCD
+5 IF $DATA(^AUPNRRE(DFN,0))
DO RRE
+6 IF $DATA(^AUPNPRVT(DFN,11))
DO PVT
+7 ;
+8 KILL I,JJ
+9 QUIT
+10 ;
+11 ;
+12 ;
MCR ;
+1 ;I used first to carry this patient's medicare data,
+2 ; later a subscript var
+3 ;X the first three pieces to display about this patient's medicare
+4 ;
+5 SET I=$GET(^AUPNMCR(DFN,0))
+6 ;
+7 ;if no medicare number, stop
+8 ;I '$P(I,U,3) Q ;ACHS*3.1*27 NEW NUMBER STORED IN PAT REG
+9 ;S X=$P($G(^AUTNINS($P(I,U,2),0)),U)_U_$P(I,U,3)_U ;ACHS*3.1*27
+10 NEW ACHSMCR,ACHSMCRS
SET ACHSMCR=0
SET ACHSMCRS=""
+11 SET X=$PIECE($GET(^AUTNINS($PIECE(I,U,2),0)),U)
+12 ;ACHS*3.1*27
SET ACHSMCR=$$GETMBI^AUPNMBI(DFN,DT,0)
+13 ;ACHS*3.1*27
IF +ACHSMCR<1
SET ACHSMCR=$PIECE(I,U,3)
IF $PIECE(I,U,4)'=""
SET ACHSMCRS=^AUTTMCS($PIECE(I,U,4),0)
+14 ;ACHS*3.1*27
IF +ACHSMCR<1
QUIT
+15 ;
+16 ;GO THRU 'MEDICARE ELIGIBLE' FILE
+17 SET I=0
FOR
SET I=$ORDER(^AUPNMCR(DFN,11,I))
IF +I=0
QUIT
Begin DoDot:1
+18 ;ACHS*3.1*27 MULTIPLE CHANGES FOR COV TYPE "D"
+19 ;ACHS*3.1*21
SET DAT=$GET(^AUPNMCR(DFN,11,I,0))
+20 ;ACHS*3.1*21
IF $DATA(ACHDDOS)
IF ACHDDOS<$PIECE(DAT,U)
QUIT
+21 ;ACHS*3.1*21
IF $DATA(ACHDDOS)
IF $PIECE(DAT,U,2)'=""
IF ACHDDOS>$PIECE(DAT,U,2)
QUIT
+22 SET INS=$GET(INS)+1
+23 SET INS(INS)=X
+24 IF $PIECE($GET(DAT),U,3)?1"D"
SET INS(INS)=INS(INS)_U_$PIECE($GET(DAT),U,6)_U_""
+25 IF '$TEST
SET INS(INS)=INS(INS)_U_ACHSMCR_U_ACHSMCRS
+26 SET INS(INS)=INS(INS)_U_$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,3)_U_$$MDY($PIECE($GET(^AUPNMCR(DFN,11,I,0)),U))_U_$$MDY($PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,2))_U_"M"_U_I
End DoDot:1
+27 QUIT
+28 ;
+29 ;LETS LOOK AT POSSIBLE MEDICAID COVERAGE
MCD ;
+1 KILL ^TMP("ACHSRP31",$JOB,"MCD")
+2 SET I=0
FOR
SET I=$ORDER(^AUPNMCD("B",DFN,I))
IF 'I
QUIT
SET JJ=0
FOR
SET JJ=$ORDER(^AUPNMCD(I,11,JJ))
IF 'JJ
QUIT
Begin DoDot:1
+3 SET ^TMP("ACHSRP31",$JOB,"MCD",9999999-JJ)=$GET(^AUPNMCD(I,11,JJ,0))
+4 SET $PIECE(^TMP("ACHSRP31",$JOB,"MCD",9999999-JJ),U,4,6)=$PIECE($GET(^AUPNMCD(I,0)),U,2,4)
+5 SET $PIECE(^TMP("ACHSRP31",$JOB,"MCD",9999999-JJ),U,7,8)=I_U_JJ
+6 QUIT
End DoDot:1
+7 ;
+8 ;ACHS*3.1*21 MODIFIED TO DISPLAY ALL AND TEST FOR DOS
+9 ;S JJ=0 F ACHS=1:1:4 S JJ=$O(^TMP("ACHSRP31",$J,"MCD",JJ)) Q:'JJ I $P(^TMP("ACHSRP31",$J,"MCD",JJ),U,6)]"",$D(^DIC(5,$P(^(JJ),U,6),0)) S $P(^TMP("ACHSRP31",$J,"MCD",JJ),U,6)=$P(^(0),U,2)
+10 ;S I=0 F ACHS=1:1:4 S I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I D
+11 SET JJ=0
SET ACHS=0
FOR
SET ACHS=ACHS+1
SET JJ=$ORDER(^TMP("ACHSRP31",$JOB,"MCD",JJ))
IF 'JJ
QUIT
IF $PIECE(^TMP("ACHSRP31",$JOB,"MCD",JJ),U,6)]""
IF $DATA(^DIC(5,$PIECE(^(JJ),U,6),0))
SET $PIECE(^TMP("ACHSRP31",$JOB,"MCD",JJ),U,6)=$PIECE(^(0),U,2)
+12 SET I=0
SET ACHS=0
FOR
SET ACHS=ACHS+1
SET I=$ORDER(^TMP("ACHSRP31",$JOB,"MCD",I))
IF 'I
QUIT
Begin DoDot:1
+13 ;ACHS*3.1*21
SET DAT=^TMP("ACHSRP31",$JOB,"MCD",I)
+14 ;ACHS*3.1*21
IF $DATA(ACHDDOS)
IF ACHDDOS<$PIECE(DAT,U)
QUIT
+15 ;ACHS*3.1*21
IF $DATA(ACHDDOS)
IF $PIECE(DAT,U,2)'=""
IF ACHDDOS>$PIECE(DAT,U,2)
QUIT
+16 SET INS=$GET(INS)+1
+17 SET INS(INS)=$PIECE(^AUTNINS($PIECE(DAT,U,4),0),U)_U_$PIECE(DAT,U,5)_U_$PIECE(DAT,U,6)_U_$PIECE(DAT,U,3)_U_$$MDY($PIECE(DAT,U))_U_$$MDY($PIECE(DAT,U,2))_U_"C"_U_$PIECE(DAT,U,7,8)
End DoDot:1
+18 ;
+19 KILL DAT,^TMP("ACHSRP31",$JOB,"MCD")
+20 QUIT
+21 ;
RRE ;
+1 ;ACHS*3.1*27 REWROTE TO PRINT NEW MBI
+2 SET FIRST=""
NEW ACHSMBI
+3 IF $PIECE($GET(^AUPNRRE(DFN,0)),U,2)'=""
SET FIRST=$PIECE($GET(^AUTNINS($PIECE(^AUPNRRE(DFN,0),U,2),0)),U)
+4 SET ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
+5 IF +ACHSMBI<1
Begin DoDot:1
+6 IF $PIECE($GET(^AUPNRRE(DFN,0)),U,3)'=""
SET FIRST=FIRST_U_$PIECE(^AUTTRRP($PIECE(^AUPNRRE(DFN,0),U,3),0),U)
+7 IF '$TEST
SET FIRST=FIRST_U_""
+8 SET FIRST=FIRST_U_$PIECE($GET(^AUPNRRE(DFN,0)),U,4)
End DoDot:1
+9 IF '$TEST
SET FIRST=FIRST_"^^"_ACHSMBI
+10 ;
+11 ;******LOOP THRU RAILROAD ELIGIBLE FILE
+12 SET JJ=0
FOR
SET JJ=$ORDER(^AUPNRRE(DFN,11,JJ))
IF JJ=""
QUIT
Begin DoDot:1
+13 ;ACHS*3.1*21
SET DAT=$PIECE(^AUPNRRE(DFN,11,JJ,0),U,3)
+14 ;ACHS*3.1*21
IF $DATA(ACHDDOS)
IF ACHDDOS<$PIECE(DAT,U)
QUIT
+15 ;ACHS*3.1*21
IF $DATA(ACHDDOS)
IF $PIECE(DAT,U,2)'=""
IF ACHDDOS>$PIECE(DAT,U,2)
QUIT
+16 SET INS=$GET(INS)+1
SET INS(INS)=FIRST_U_$PIECE(^AUPNRRE(DFN,11,JJ,0),U,3)_U_$$MDY($PIECE(^(0),U))_U_$$MDY($PIECE(^(0),U,2))_U_"R"_U_JJ
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
PVT ;
+1 SET I=0
FOR
SET I=$ORDER(^AUPNPRVT(DFN,11,I))
IF 'I
QUIT
Begin DoDot:1
+2 ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
+3 ;S INS=$G(INS)+1,INS(INS)=$E($P(^AUTNINS($P(^AUPNPRVT(DFN,11,I,0),U),0),U),1,26)_U_$P(^AUPNPRVT(DFN,11,I,0),U,2)
+4 SET ACHSPINS=^AUPNPRVT(DFN,11,I,0)
+5 ;ACHS*3.1*21
IF $DATA(ACHDDOS)
IF ACHDDOS<$PIECE(ACHSPINS,U,6)
QUIT
+6 ;ACHS*3.1*21
IF $DATA(ACHDDOS)
IF $PIECE(ACHSPINS,U,7)'=""
IF ACHDDOS>$PIECE(ACHSPINS,U,7)
QUIT
+7 SET INS=$GET(INS)+1
SET INS(INS)=$EXTRACT($PIECE(^AUTNINS($PIECE(ACHSPINS,U),0),U),1,26)
+8 IF $PIECE(ACHSPINS,U,8)
IF $DATA(^AUPN3PPH($PIECE(ACHSPINS,U,8),0))
SET INS(INS)=INS(INS)_U_$PIECE(^AUPN3PPH($PIECE(ACHSPINS,U,8),0),U,4)
+9 ;I $P(^AUPNPRVT(DFN,11,I,0),U,3) S $P(INS(INS),U,4)=$P(^AUTTPIC($P(^(0),U,3),0),U)
+10 IF $PIECE(ACHSPINS,U,8)
IF $PIECE(^AUPN3PPH($PIECE(ACHSPINS,U,8),0),U,5)
SET $PIECE(INS(INS),U,4)=$PIECE(^AUTTPIC($PIECE(^AUPN3PPH($PIECE(ACHSPINS,U,8),0),U,5),0),U)
+11 SET $PIECE(INS(INS),U,5,6)=$$MDY($PIECE(^AUPNPRVT(DFN,11,I,0),U,6))_U_$$MDY($PIECE(^(0),U,7))_U_"P"_U_I
End DoDot:1
+12 KILL ACHSPINS
QUIT
+13 ;
MDY(X) ;
+1 QUIT $EXTRACT(X,4,7)_$EXTRACT(X,2,3)
+2 ;
PRT ;EP - FROM ACHSDN2A AND DOCUMENT ENTRY-ACHSA1
+1 ;write out the array INS
+2 ;
+3 WRITE !!,?5,"Type of Coverage",?35,"Policy #",?55,"Cov. type EligDt TermDt",!,?5,"----------------",?35,"--------",?55,"--------- ------ ------"
+4 FOR JJ=""
FOR CNT=1:1
SET JJ=$ORDER(INS(JJ))
IF JJ=""
QUIT
SET DATA=INS(JJ)
WRITE !,CNT,".",?5,$PIECE(DATA,U,1),?35,$PIECE(DATA,U,2)," ",$PIECE(DATA,U,3),?55,$PIECE(DATA,U,4),?66,$PIECE(DATA,U,5),?73,$PIECE(DATA,U,6)
+5 KILL CNT,DATA,JJ
+6 QUIT
