Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSRPIN

ACHSRPIN.m

Go to the documentation of this file.
  1. 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
  1. ;ACHS*3.1*3 whole routine new
  1. ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
  1. ;ACHS3.1*21 9.18.2011;IHS/OIT/FCJ ADDED TEST FOR DOS VS ELIG DATES
  1. ;ACHS3.1*27 12/12/2017 IHS.OIT.FCJ ADDED NEW MBI AND D COVERAGE
  1. ;
  1. ;INPUT: DFN
  1. ;
  1. ;OUTPUT: INS array, list all insurances
  1. ;
  1. ;
  1. GET ;EP- FROM ACHSDN2A AND DOC ENTRY-ACHSA1
  1. K INS
  1. ;
  1. I $D(^AUPNMCR(DFN)) D MCR
  1. I $D(^AUPNMCD("B",DFN)) D MCD
  1. I $D(^AUPNRRE(DFN,0)) D RRE
  1. I $D(^AUPNPRVT(DFN,11)) D PVT
  1. ;
  1. K I,JJ
  1. Q
  1. ;
  1. ;
  1. ;
  1. MCR ;
  1. ;I used first to carry this patient's medicare data,
  1. ; later a subscript var
  1. ;X the first three pieces to display about this patient's medicare
  1. ;
  1. S I=$G(^AUPNMCR(DFN,0))
  1. ;
  1. ;if no medicare number, stop
  1. ;I '$P(I,U,3) Q ;ACHS*3.1*27 NEW NUMBER STORED IN PAT REG
  1. ;S X=$P($G(^AUTNINS($P(I,U,2),0)),U)_U_$P(I,U,3)_U ;ACHS*3.1*27
  1. N ACHSMCR,ACHSMCRS S ACHSMCR=0,ACHSMCRS=""
  1. S X=$P($G(^AUTNINS($P(I,U,2),0)),U)
  1. S ACHSMCR=$$GETMBI^AUPNMBI(DFN,DT,0) ;ACHS*3.1*27
  1. 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
  1. Q:+ACHSMCR<1 ;ACHS*3.1*27
  1. ;
  1. ;GO THRU 'MEDICARE ELIGIBLE' FILE
  1. S I=0 F S I=$O(^AUPNMCR(DFN,11,I)) Q:+I=0 D
  1. . ;ACHS*3.1*27 MULTIPLE CHANGES FOR COV TYPE "D"
  1. .S DAT=$G(^AUPNMCR(DFN,11,I,0)) ;ACHS*3.1*21
  1. .I $D(ACHDDOS),ACHDDOS<$P(DAT,U) Q ;ACHS*3.1*21
  1. .I $D(ACHDDOS),$P(DAT,U,2)'="",ACHDDOS>$P(DAT,U,2) Q ;ACHS*3.1*21
  1. .S INS=$G(INS)+1
  1. .S INS(INS)=X
  1. .I $P($G(DAT),U,3)?1"D" S INS(INS)=INS(INS)_U_$P($G(DAT),U,6)_U_""
  1. .E S INS(INS)=INS(INS)_U_ACHSMCR_U_ACHSMCRS
  1. .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
  1. Q
  1. ;
  1. ;LETS LOOK AT POSSIBLE MEDICAID COVERAGE
  1. MCD ;
  1. K ^TMP("ACHSRP31",$J,"MCD")
  1. 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
  1. . S ^TMP("ACHSRP31",$J,"MCD",9999999-JJ)=$G(^AUPNMCD(I,11,JJ,0))
  1. . S $P(^TMP("ACHSRP31",$J,"MCD",9999999-JJ),U,4,6)=$P($G(^AUPNMCD(I,0)),U,2,4)
  1. . S $P(^TMP("ACHSRP31",$J,"MCD",9999999-JJ),U,7,8)=I_U_JJ
  1. . Q
  1. ;
  1. ;ACHS*3.1*21 MODIFIED TO DISPLAY ALL AND TEST FOR DOS
  1. ;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)
  1. ;S I=0 F ACHS=1:1:4 S I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I D
  1. 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)
  1. S I=0,ACHS=0 F S ACHS=ACHS+1,I=$O(^TMP("ACHSRP31",$J,"MCD",I)) Q:'I D
  1. .S DAT=^TMP("ACHSRP31",$J,"MCD",I) ;ACHS*3.1*21
  1. .I $D(ACHDDOS),ACHDDOS<$P(DAT,U) Q ;ACHS*3.1*21
  1. .I $D(ACHDDOS),$P(DAT,U,2)'="",ACHDDOS>$P(DAT,U,2) Q ;ACHS*3.1*21
  1. . S INS=$G(INS)+1
  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)
  1. ;
  1. K DAT,^TMP("ACHSRP31",$J,"MCD")
  1. Q
  1. ;
  1. RRE ;
  1. ;ACHS*3.1*27 REWROTE TO PRINT NEW MBI
  1. S FIRST="" N ACHSMBI
  1. I $P($G(^AUPNRRE(DFN,0)),U,2)'="" S FIRST=$P($G(^AUTNINS($P(^AUPNRRE(DFN,0),U,2),0)),U)
  1. S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
  1. I +ACHSMBI<1 D
  1. .I $P($G(^AUPNRRE(DFN,0)),U,3)'="" S FIRST=FIRST_U_$P(^AUTTRRP($P(^AUPNRRE(DFN,0),U,3),0),U)
  1. .E S FIRST=FIRST_U_""
  1. .S FIRST=FIRST_U_$P($G(^AUPNRRE(DFN,0)),U,4)
  1. E S FIRST=FIRST_"^^"_ACHSMBI
  1. ;
  1. ;******LOOP THRU RAILROAD ELIGIBLE FILE
  1. S JJ=0 F S JJ=$O(^AUPNRRE(DFN,11,JJ)) Q:JJ="" D
  1. .S DAT=$P(^AUPNRRE(DFN,11,JJ,0),U,3) ;ACHS*3.1*21
  1. .I $D(ACHDDOS),ACHDDOS<$P(DAT,U) Q ;ACHS*3.1*21
  1. .I $D(ACHDDOS),$P(DAT,U,2)'="",ACHDDOS>$P(DAT,U,2) Q ;ACHS*3.1*21
  1. . 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
  1. . Q
  1. Q
  1. ;
  1. PVT ;
  1. S I=0 F S I=$O(^AUPNPRVT(DFN,11,I)) Q:'I D
  1. . ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
  1. . ;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)
  1. .S ACHSPINS=^AUPNPRVT(DFN,11,I,0)
  1. .I $D(ACHDDOS),ACHDDOS<$P(ACHSPINS,U,6) Q ;ACHS*3.1*21
  1. .I $D(ACHDDOS),$P(ACHSPINS,U,7)'="",ACHDDOS>$P(ACHSPINS,U,7) Q ;ACHS*3.1*21
  1. .S INS=$G(INS)+1,INS(INS)=$E($P(^AUTNINS($P(ACHSPINS,U),0),U),1,26)
  1. .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)
  1. . ;I $P(^AUPNPRVT(DFN,11,I,0),U,3) S $P(INS(INS),U,4)=$P(^AUTTPIC($P(^(0),U,3),0),U)
  1. . 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)
  1. . 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
  1. K ACHSPINS Q
  1. ;
  1. MDY(X) ;
  1. Q $E(X,4,7)_$E(X,2,3)
  1. ;
  1. PRT ;EP - FROM ACHSDN2A AND DOCUMENT ENTRY-ACHSA1
  1. ;write out the array INS
  1. ;
  1. W !!,?5,"Type of Coverage",?35,"Policy #",?55,"Cov. type EligDt TermDt",!,?5,"----------------",?35,"--------",?55,"--------- ------ ------"
  1. 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)
  1. K CNT,DATA,JJ
  1. Q