- 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