Routine: ACHSRPIN

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

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

 ;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")

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

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

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

ACHSRPIN.m