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

AGELUP3.m

Go to the documentation of this file. 
  1. AGELUP3 ;IHS/ASDS/EFG - PROCESS RRE ELIGIBILITY FROM CMS FILE ;  
  1.  ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
  1.  ;
  1. R(AG) ;EP - process railroad retirement
  1.  KILL AG1,AG2,AGSAME
  1.  I $D(^AUPNRRE(AG("DFN"))) D MCRY I AGSAME S AGACT="S" Q
  1.  I AGAUTO'="A" D  Q
  1.  . D HEAD^AGELUPUT("RAILROAD")
  1.  . I '$D(^AUPNRRE(AG("DFN"))) D MCRN^AGELUP2
  1.  . D MDISP^AGELUP2(4),PEND^AGELUPUT
  1.  .Q
  1.  U IO(0)
  1.  W "."
  1.  W:'(AGRCNT#100) $J(AGRCNT,8)
  1.  Q
  1. MCRY ;if railroad coverage
  1.  S AGSAME=0
  1.  S (AGMNM,AG1(1))=$P($G(^AUPNRRE(AG("DFN"),21)),U,1)
  1.  S AGMDOB=$P($G(^AUPNRRE(AG("DFN"),21)),U,2)
  1.  S AG1(2)=AGMDOB
  1.  S (AGMNBR,AG1(3))=$P(^AUPNRRE(AG("DFN"),0),U,4)
  1.  S AGMSFX=$P(^AUPNRRE(AG("DFN"),0),U,3)
  1.  S (AGMSFX,AG1(4))=$P($G(^AUTTRRP(+AGMSFX,0)),U,1)
  1.  S DA=0
  1.  ;AG*7.1*2 SEPARATE TO READABLE LINES
  1.  ;F  S DA=$O(^AUPNRRE(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(^AUPNRRE(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^AGELUP2
  1.  S:'$D(AGFL) AGSAME=1
  1.  Q
  1. FILE(AG) ;EP - file RAILROAD FIELDS
  1.  I '$D(^AUTTRRP("B",AG("FSFX"))) D  I +Y<1 W !,"Add to RAILROAD PREFIX file failed for '",AG("FSFX"),"'.",$$DIR^XBDIR("E") Q
  1.  . NEW DIC,DLAYGO
  1.  . S (DIC,DLAYGO)=9999999.33,DIC(0)="FL",X=AG("FSFX")
  1.  . D ^DIC
  1.  .Q
  1.  NEW AGADD
  1.  I '$D(^AUPNRRE(AG("DFN"),0)) D  Q:+Y<0  S AGADD=1 I 1
  1.  . NEW DIC,DLAYGO,DD,DO
  1.  . S DIC="^AUPNRRE(",DIC(0)="F",DLAYGO=9000005,(DINUM,X)=AG("DFN")
  1.  . S DIC("DR")=".02////"_AGINSPT_";.03///"_AG("FSFX")_";.04///"_AG("FNBR")_";2101///"_AG("FNM")_";2102///"_AG("FDOB")
  1.  . K DO,DD
  1.  . D FILE^DICN,PTACT^AGELUP2(1,AG("DFN")):+Y>0
  1.  .Q
  1.  E  D  S AGADD=0
  1.  . NEW DA,DIE,DR
  1.  . S DIE="^AUPNRRE(",DA=AG("DFN"),DR=""
  1.  . I $P(^AUPNRRE(DA,0),U,2)'=AGINSPT S DR=".02////"_AGINSPT
  1.  . I AG("FSFX")'="" D
  1.  .. I $P(^AUPNRRE(DA,0),U,3),AG("FSFX")=$P(^AUTTRRP($P(^AUPNRRE(DA,0),U,3),0),U) Q
  1.  .. S DR=DR_$S($L(DR):";",1:"")_".03///"_AG("FSFX")
  1.  ..Q
  1.  . I AG("FNBR")'="",AG("FNBR")'=$P(^AUPNRRE(DA,0),U,4) S DR=DR_$S($L(DR):";",1:"")_".04///"_AG("FNBR")
  1.  . I AG("FNM")'="",AG("FNM")'=$P($G(^AUPNRRE(DA,21)),U) S DR=DR_$S($L(DR):";",1:"")_"2101///"_AG("FNM")
  1.  . I AG("FDOB")'="",AG("FDOB")'=$P($G(^AUPNRRE(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^AGELUP2(2,AG("DFN")):'$D(Y) KILL DITC
  1.  .Q
  1.  S DA(1)=AG("DFN"),DIK="^AUPNRRE("_DA(1)_",11,",DA=0
  1.  ;F  S DA=$O(^AUPNRRE(DA(1),11,DA)) Q:'DA  D ^DIK
  1.  F  S DA=$O(^AUPNRRE(DA(1),11,DA)) Q:'DA  I $P($G(^AUPNRRE(DA(1),11,DA,0)),U,3)'="D" D ^DIK  ;IHS/SD/TPF 4/25/2006 AG*7.2*2 IM 20585
  1.  S DIC="^AUPNRRE("_DA(1)_",11,",DIC(0)="F",DIC("P")=$P(^DD(9000005,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///"_$P(AG("DT",AGI,AGJ),U,2)_";.03///"_$P(AG("DT",AGI,AGJ),U,3)
  1.  .. K DD,DO
  1.  .. D FILE^DICN
  1.  .. Q:AGADD
  1.  .. D:+Y>0 PTACT^AGELUP2(2,AG("DFN"))
  1.  ..Q
  1.  .Q
  1.  KILL AGI,AGJ
  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"),6,"")
  1.  .Q
  1.  Q
  1. LTR(P) ;EP - Lookup the Area indicator of the file name, based on Area code.
  1.  Q $P($T(@$E($P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10),1,2)),U,P)
  1.  ;;area name ^ 1st char of file ^ 3-letter_Area_ID
  1. 10 ;;ABERDEEN^c^abr
  1. 15 ;;ABERDEEN TRIBE/638^c^abr
  1. 17 ;;ABERDEEN URBAN^c^abr
  1. 30 ;;ALASKA^a^aka
  1. 39 ;;ALASKA NON-IHS^a^aka
  1. 35 ;;ALASKA TRIBE/638^a^aka
  1. 20 ;;ALBUQUERQUE^q^alb
  1. 25 ;;ALBUQUERQUE TRIBE/638^q^alb
  1. 11 ;;BEMIDJI^d^bji
  1. 18 ;;BEMIDJI NON-IHS^d^bji
  1. 16 ;;BEMIDJI TRIBE/638^d^bji
  1. 14 ;;BEMIDJI URBAN^d^bji
  1. 40 ;;BILLINGS^b^bil
  1. 45 ;;BILLINGS TRIBE/638^b^bil
  1. 47 ;;BILLINGS URBAN^b^bil
  1. 61 ;;CALIFORNIA^l^cao
  1. 68 ;;CALIFORNIA NON-IHS^l^cao
  1. 66 ;;CALIFORNIA TRIBE/638^l^cao
  1. 64 ;;CALIFORNIA URBAN^l^cao
  1. 99 ;;HEADQUARTERS EAST
  1. 23 ;;HEADQUARTERS WEST
  1. 51 ;;NASHVILLE^u^nsa
  1. 58 ;;NASHVILLE NON-IHS^u^nsa
  1. 56 ;;NASHVILLE TRIBE/638^u^nsa
  1. 54 ;;NASHVILLE URBAN^u^nsa
  1. 80 ;;NAVAJO^n^nav
  1. 89 ;;NAVAJO NON-IHS^n^nav
  1. 85 ;;NAVAJO TRIBE/638^n^nav
  1. 50 ;;OKLAHOMA^o^okc
  1. 59 ;;OKLAHOMA NON-IHS^o^okc
  1. 55 ;;OKLAHOMA TRIBE/638^o^okc
  1. 57 ;;OKLAHOMA URBAN^o^okc
  1. 60 ;;PHOENIX^x^phx
  1. 69 ;;PHOENIX NON-IHS^x^phx
  1. 65 ;;PHOENIX TRIBE/638^x^phx
  1. 67 ;;PHOENIX URBAN^x^phx
  1. 70 ;;PORTLAND^p^por
  1. 79 ;;PORTLAND NON-IHS^p^por
  1. 75 ;;PORTLAND TRIBE/638^p^por
  1. 77 ;;PORTLAND URBAN^p^por
  1. 00 ;;TUCSON^s^tuc
  1. 09 ;;TUCSON NON-IHS^s^tuc
  1. 05 ;;TUCSON TRIBE/638^s^tuc
  1. 07 ;;TUCSON URBAN^s^tuc
  1.  ;