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

AGELUP2.m

Go to the documentation of this file. 
  1. AGELUP2 ;IHS/ASDS/EFG - PROCESS MCR ELIGIBILITY FROM CMS FILE ;  
  1.  ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
  1.  ;
  1. M(AG) ;EP - process Medicare
  1.  KILL AG1,AG2,AGSAME
  1.  I $D(^AUPNMCR(AG("DFN"))) D MCRY I AGSAME S AGACT="S" Q
  1.  I AGAUTO'="A" D  Q
  1.  . D HEAD^AGELUPUT("MEDICARE")
  1.  . I '$D(^AUPNMCR(AG("DFN"))) D MCRN
  1.  . D MDISP(5),PEND^AGELUPUT
  1.  .Q
  1.  U IO(0)
  1.  W "."
  1.  W:'(AGRCNT#100) $J(AGRCNT,8)
  1.  Q
  1. MCRY ;if medicare coverage
  1.  S AGSAME=0
  1.  ;MediCare name.
  1.  S (AGMNM,AG1(1))=$P($G(^AUPNMCR(AG("DFN"),21)),U)
  1.  ;MediCare DOB.
  1.  S AGMDOB=$P($G(^AUPNMCR(AG("DFN"),21)),U,2)
  1.  S AG1(2)=AGMDOB
  1.  ;MediCare #.
  1.  S (AGMNBR,AG1(3))=$P(^AUPNMCR(AG("DFN"),0),U,3)
  1.  ;MediCare Suffix.
  1.  S AGMSFX=$P(^AUPNMCR(AG("DFN"),0),U,4)
  1.  S (AGMSFX,AG1(4))=$P($G(^AUTTMCS(+AGMSFX,0)),U)
  1.  ;AG1("DT",EligDt,CovType)=EligDt^ELigEndDt^CovType
  1.  S DA=0
  1.  ;F  S DA=$O(^AUPNMCR(AG("DFN"),11,DA)) Q:'DA  S %=^(DA,0) S:$P(%,U,3)="" $P(%,U,3)=" " S AG1("DT",$P(%,U,1),$P(%,U,3))=%
  1.  F  S DA=$O(^AUPNMCR(AG("DFN"),11,DA)) Q:'DA  D
  1.  .;S %=^(DA,0)
  1.  .S %=$P(^(DA,0),U,1,3)  ;PART D COVERAGES THREW THIS OFF AG*7.1*2 IM????? NO IM FOUND DURING TESTING ON NEW HRN LENGTH
  1.  .Q:$P(%,U,3)="D"        ;AG*7.1*2 IM22061 IGNORE PART D FOR DIFFERENCE COMPARISON
  1.  .S:$P(%,U,3)="" $P(%,U,3)=" "
  1.  .S AG1("DT",$P(%,U,1),$P(%,U,3))=%
  1.  KILL AGFL
  1.  D DFL
  1.  S:'$D(AGFL) AGSAME=1
  1.  Q
  1. MCRN ;EP - No MCR/RRE coverage in rpms.
  1.  S AG1(1)="NO ELIGIBILITY ON FILE"
  1.  F I=2:1:4 S AG1(I)=""
  1.  D DFL
  1.  Q
  1. DFL ;EP - Set descrepency flags.
  1.  KILL AGFL
  1.  S AG2(1)=$G(AG("FNM"))
  1.  S:AG2(1)'=$G(AGMNM) AGFL(1)=1  ;Name.
  1.  S AG2(2)=$G(AG("FDOB"))
  1.  S:AG2(2)'=$G(AGMDOB) AGFL(2)=1 ;DOB.
  1.  S AG2(3)=$G(AG("FNBR"))
  1.  S:AG2(3)'=$G(AGMNBR) AGFL(3)=1 ;#.
  1.  S AG2(4)=$G(AG("FSFX"))
  1.  S:AG2(4)'=$G(AGMSFX) AGFL(4)=1 ;Suffix.
  1.  ;Compare file eligibilities with existing eligibilities.
  1.  ;AG1("DT",EligDt,CovType)=EligDt^ELigEndDt^CovType
  1.  NEW I,J
  1.  S I=0
  1.  F  S I=$O(AG("DT",I)) Q:'I  D
  1.  . S J=0
  1.  . F  S J=$O(AG("DT",I,J)) Q:J=""  D
  1.  .. I $G(AG1("DT",I,J))'=AG("DT",I,J) S AGFL(5)=1
  1.  ..Q
  1.  .Q
  1.  S I=0
  1.  F  S I=$O(AG1("DT",I)) Q:'I  D
  1.  . S J=0
  1.  . F  S J=$O(AG1("DT",I,J)) Q:J=""  D
  1.  .. I $G(AG("DT",I,J))'=AG1("DT",I,J) S AGFL(5)=1
  1.  ..Q
  1.  .Q
  1.  Q
  1. MDISP(AGDISP) ;EP - display medicare info
  1.  I AGDISP=5 S AG1(5)="DATES",AG2(5)=""
  1.  F I=1:1:AGDISP D
  1.  . W !,$P($T(@I),";;",$S(AGTYPE="D":3,1:2)),":",?13
  1.  . W:$G(AGFL(I)) $$S^AGVDF("RVN")
  1.  . W $S('$L(AG1(I)):"     ",I=2:$$FMTE^XLFDT(AG1(I),5),1:AG1(I))
  1.  . W:$G(AGFL(I)) $$S^AGVDF("RVF")
  1.  . I AGTYPE="D",I=5 W " ( Matching Medicaid eligibility dates are not displayed )"
  1.  . W ?45,$S(I=2:$$FMTE^XLFDT(AG2(I),5),1:AG2(I))
  1.  .Q
  1.  I AGDISP=4 W !
  1.  ;Dates from RPMS file.
  1.  S (AG1,AGCNT)=0
  1.  KILL AGLINE
  1.  F  S AG1=$O(AG1("DT",AG1)) Q:'AG1  D
  1.  . S AGCVT=0
  1.  . F  S AGCVT=$O(AG1("DT",AG1,AGCVT)) Q:AGCVT=""  D
  1.  .. S AGCNT=AGCNT+1,AGLINE(AGCNT)=AG1("DT",AG1,AGCVT)
  1.  .. I $G(AG("DT",AG1,AGCVT)) S $P(AGLINE(AGCNT),"*",2)=AG("DT",AG1,AGCVT)
  1.  ..Q
  1.  .Q
  1.  ;Dates from incoming file.
  1.  S AG2=0
  1.  F  S AG2=$O(AG("DT",AG2)) Q:'AG2  D
  1.  . S AGCVT=0
  1.  . F  S AGCVT=$O(AG("DT",AG2,AGCVT)) Q:AGCVT=""  D
  1.  .. Q:$G(AG1("DT",AG2,AGCVT))  S AGCNT=AGCNT+1,$P(AGLINE(AGCNT),"*",2)=AG("DT",AG2,AGCVT)
  1.  .. S:$P(AGLINE(AGCNT),"*",1)="" $P(AGLINE(AGCNT),"*",1)="^^"
  1.  ..Q
  1.  .Q
  1.  S (I,AGCNT)=0
  1.  F  S I=$O(AGLINE(I)) Q:'I  D
  1.  . I AGTYPE="D" Q:$P(AGLINE(I),"*",2)=""  Q:$P(AGLINE(I),"*",1)=$P(AGLINE(I),"*",2)
  1.  . S AGLINE(I)=$TR(AGLINE(I),"*","^")
  1.  . W !,"START DATE: "
  1.  . W ?13,$$FMTE^XLFDT($P(AGLINE(I),U,1),5)
  1.  . W ?45,$S('($P(AGLINE(I),U,1)):IORVON,1:""),$$FMTE^XLFDT($P(AGLINE(I),U,4),5),IORVOFF
  1.  . W !,"  END DATE: "
  1.  . W ?13,$$FMTE^XLFDT($P(AGLINE(I),U,2),5)
  1.  . W ?45,$S('$P(AGLINE(I),U,1):IORVON,($P(AGLINE(I),U,5))&($P(AGLINE(I),U,2)'=$P(AGLINE(I),U,5)):IORVON,1:""),$S($P(AGLINE(I),U,5):$$FMTE^XLFDT($P(AGLINE(I),U,5),5),1:$J("",10)),IORVOFF
  1.  . W !,"  COV TYPE: ",?13,$P(AGLINE(I),U,3),?45,$S('$L($P(AGLINE(I),U,3)):IORVON,1:""),$P(AGLINE(I),U,6),IORVOFF
  1.  .Q
  1.  Q
  1. 1 ;;MCR NAME;;MCD NAME;;
  1. 2 ;;MCR DOB;;MCD DOB;;
  1. 3 ;;MCR NUMBER;;MCD NUMBER;;
  1. 4 ;;SFX;;;;
  1. 5 ;;ELIGIBILITY;;ELIGIBILITY;;
  1.  ;
  1. FILE(AG) ;EP - file MEDICARE FIELDS
  1.  I '$D(^AUTTMCS("B",AG("FSFX"))) S DIC=9999999.32,DIC(0)="L",X=AG("FSFX") D ^DIC I +Y<1 W !,"Add to MEDICARE SUFFIX file failed for '",AG("FSFX"),"'.",$$DIR^XBDIR("E") Q
  1.  NEW AGADD
  1.  I '$D(^AUPNMCR(AG("DFN"),0)) D  Q:+Y<0  S AGADD=1 I 1
  1.  . NEW DIC,DLAYGO,DD,DO
  1.  . S DIC="^AUPNMCR(",DIC(0)="F",DLAYGO=9000003,(DINUM,X)=AG("DFN")
  1.  . S DIC("DR")=".02////"_AGINSPT_";.03///"_AG("FNBR")_";.04///"_AG("FSFX")_";2101///"_AG("FNM")_";2102///"_AG("FDOB")
  1.  . K DD,DO
  1.  . D FILE^DICN,PTACT(1,AG("DFN")):+Y>0
  1.  .Q
  1.  E  D  S AGADD=0
  1.  . NEW DA,DIE,DR
  1.  . S DIE="^AUPNMCR(",DA=AG("DFN"),DR=""
  1.  . I $P(^AUPNMCR(DA,0),U,2)'=AGINSPT S DR=".02////"_AGINSPT
  1.  . I AG("FNBR")'="",AG("FNBR")'=$P(^AUPNMCR(DA,0),U,3) S DR=DR_$S($L(DR):";",1:"")_".03///"_AG("FNBR")
  1.  . I AG("FSFX")'="" D
  1.  .. I $P(^AUPNMCR(DA,0),U,4),AG("FSFX")=$P(^AUTTMCS($P(^AUPNMCR(DA,0),U,4),0),U) Q
  1.  .. S DR=DR_$S($L(DR):";",1:"")_".04///"_AG("FSFX")
  1.  ..Q
  1.  . I AG("FNM")'="",AG("FNM")'=$P($G(^AUPNMCR(DA,21)),U) S DR=DR_$S($L(DR):";",1:"")_"2101///"_AG("FNM")
  1.  . I AG("FDOB")'="",AG("FDOB")'=$P($G(^AUPNMCR(DA,21)),U,2) S DR=DR_$S($L(DR):";",1:"")_"2102////"_AG("FDOB")
  1.  . I $L(DR) NEW DITC S DITC="" D ^DIE,PTACT(2,AG("DFN")):'$D(Y) KILL DITC
  1.  .Q
  1.  ;
  1.  S DA(1)=AG("DFN"),DIK="^AUPNMCR("_DA(1)_",11,",DA=0
  1.  ;F  S DA=$O(^AUPNMCR(DA(1),11,DA)) Q:'DA  D ^DIK
  1.  F  S DA=$O(^AUPNMCR(DA(1),11,DA)) Q:'DA  I $P($G(^AUPNMCR(DA(1),11,DA,0)),U,3)'="D" D ^DIK  ;IHS/SD/TPF 4/25/2006 AG*7.1*2 IM20585
  1.  S DIC="^AUPNMCR("_DA(1)_",11,",DIC(0)="F",DIC("P")=$P(^DD(9000003,1101,0),U,2)
  1.  KILL DD,DO
  1.  S AGI=0
  1.  F  S AGI=$O(AG("DT",AGI)) Q:'AGI  D
  1.  . S AGJ=0
  1.  . F  S AGJ=$O(AG("DT",AGI,AGJ)) Q:AGJ=""  D
  1.  .. S X=$P(AG("DT",AGI,AGJ),U,1)
  1.  .. Q:'X
  1.  .. S DIC("DR")=".02////^S X=$P(AG(""DT"",AGI,AGJ),U,2)"
  1.  .. S DIC("DR")=DIC("DR")_";.03////^S X=$P(AG(""DT"",AGI,AGJ),U,3)"
  1.  .. K DD,DO
  1.  .. D FILE^DICN
  1.  .. Q:AGADD
  1.  .. D:+Y>0 PTACT(2,AG("DFN"))
  1.  ..Q
  1.  .Q
  1.  KILL AGI,AGJ
  1.  ;
  1.  D
  1.  . NEW DFN
  1.  . S DFN=AG("DFN")
  1.  . D ^AGDATCK
  1.  . I $D(AG("ER")) KILL AG("DATE"),AG("DTOT"),AG("ER") Q
  1.  . D UPDATE1^AGED(DUZ(2),AG("DFN"),4,"")
  1.  .Q
  1.  Q
  1.  ;
  1. PTACT(AG,X) ;EP - Record action AG on patient X (DFN). 1=add, 2=edit.
  1.  NEW DA,DIC,DIE,DINUM,DR,Y
  1.  S DA(1)=AGRUN,DIC("P")=$P(^DD(9009062.02,AG,0),U,2),DIC="^AGELUPLG("_DA(1)_","_AG_",",DIC(0)="F",DINUM=X
  1.  K DD,DO
  1.  D FILE^DICN
  1.  Q