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

BDWA1.m

Go to the documentation of this file. 
  1. BDWA1 ;IHS/CMI/LAB - DW EXPORT - OLD, NOT USED;
  1.  ;;1.0;IHS DATA WAREHOUSE;;JAN 23, 2006
  1.  ;
  1.  NEW DFN,BDWADONE,BDWAP3,DX,DY,BDWASITE,BDWAN11,BDWADPT0,BDWAPAT0,T
  1.  S (BDWALDAT,DFN)=0,BDWAFDAT=9999999,BDWAP3=$P(^AUPNPAT(0),U,3)
  1.  S DX=$X,DY=$Y+1
  1.  F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  D  I '(DFN#100),'$D(ZTQUEUED) X IOXY W "On IEN ",DFN," of ",BDWAP3," in ^AUPNPAT(..."
  1.  . Q:'$D(^DPT(DFN))
  1.  . Q:$P(^DPT(DFN,0),U,19)  ; merged pt
  1.  . S (BDWADONE,BDWASITE)=0
  1.  . F  S BDWASITE=$O(^AUPNPAT(DFN,41,BDWASITE)) Q:'BDWASITE  D  Q:BDWADONE
  1.  .. I $L($P(^AUPNPAT(DFN,41,BDWASITE,0),U,5)) Q:"DM"[$P(^(0),U,5)  ; deleted or merged patient
  1.  .. Q:"T"=$E($P(^AUPNPAT(DFN,41,BDWASITE,0),U,2))  ; Temp HRN
  1.  .. KILL T
  1.  .. S BDWADPT0=$G(^DPT(DFN,0)),BDWAPAT0=$G(^AUPNPAT(DFN,0)),BDWAN11=$G(^AUPNPAT(DFN,11))
  1.  .. D RG1,RG2,RG4,RG5
  1.  .. S BDWADONE=1 ; pt is done, one and only one time
  1.  .. S BDWAIN03=BDWAIN03+1
  1.  .. I $P(BDWAPAT0,U,2),$P(BDWAPAT0,U,2)<BDWAFDAT S BDWAFDAT=$P(BDWAPAT0,U,2)
  1.  .. I $P(BDWAPAT0,U,2)>BDWALDAT S BDWALDAT=$P(BDWAPAT0,U,2)
  1.  ..Q
  1.  .Q
  1.  ;
  1.  Q
  1.  ;
  1. RG1 ;
  1.  S T(1)="RG1"
  1.  ;
  1.  ; R1P4:LastName^FirstName^MI
  1.  D NAMECVT($P(BDWADPT0,U))
  1.  S $P(T(1),U,4)=BDWALN,$P(T(1),U,5)=BDWAFN,$P(T(1),U,6)=BDWAMN
  1.  ;
  1.  ; R1P7:Classification
  1.  S X=$P(BDWAN11,U,11)
  1.  I X S $P(T(1),U,7)=$P($G(^AUTTBEN(X,0)),U,2)
  1.  ;
  1.  ; R1P8:DateOfBirth
  1.  S $P(T(1),U,8)=$P(BDWADPT0,U,3)+17000000
  1.  ;
  1.  ; R1P9:Gender
  1.  S $P(T(1),U,9)=$P(BDWADPT0,U,2)
  1.  ;
  1.  ; R1P10:SocialSecNum
  1.  S $P(T(1),U,10)=$TR($P(BDWADPT0,U,9),"-")
  1.  ;
  1.  ; R1P11:TribeCode
  1.  S X=$P(BDWAN11,U,8)
  1.  I X S $P(T(1),U,11)=$P($G(^AUTTTRI(X,0)),U,2)
  1.  ;
  1.  ; R1P12:BloodQuantum
  1.  I $P(BDWAN11,U,10)]"" D  I Y]"" S $P(T(1),U,12)=Y
  1.  . NEW V
  1.  . S V=$P(BDWAN11,U,10),(Y,X)=""
  1.  . I +V>0 S X=$P(V,"/",1)/$P(V,"/",2)
  1.  . S Y=$S((V="FULL"!(X=1)):1,V="NONE":5,V="UNSPECIFIED":6,V="UNKNOWN":7,+V'>0:7,1:Y) Q:Y]""
  1.  . S Y=$S(X'<.5:2,X'<.25:3,X'<.125:4,X<.125:4,1:Y)
  1.  .Q
  1.  ;
  1.  ; R1P13:Father's LastName^FirstName^MI
  1.  I $D(^DPT(DFN,.24)) D NAMECVT($P(^DPT(DFN,.24),U)) S $P(T(1),U,13)=BDWALN,$P(T(1),U,14)=BDWAFN,$P(T(1),U,15)=$E(BDWAMN)
  1.  ;
  1.  ; R1P16:CurrentCommunity
  1.  S X=$P(BDWAN11,U,17)
  1.  I X,$D(^AUTTCOM(X,0)) S X=$P(^AUTTCOM(X,0),U,8),$P(T(1),U,16)=$E(X,5,7)_$E(X,3,4)_$E(X,1,2)
  1.  ;
  1.  I '$D(^DPT(DFN,.11)) G SET1
  1.  ;
  1.  ; R1P17:AddressStreet^AddressTown
  1.  S $P(T(1),U,17)=$P(^DPT(DFN,.11),U),$P(T(1),U,18)=$P(^(.11),U,4),X=$P(^(.11),U,5)
  1.  ;
  1.  ; R1P19:AddressState
  1.  I X S $P(T(1),U,19)=$P(^DIC(5,X,0),U,2)
  1.  ;
  1.  ; R1P20:AddressZip
  1.  S $P(T(1),U,20)=$TR($P(^DPT(DFN,.11),U,6),"-")
  1. SET1 ;
  1.  D SET(1)
  1.  Q
  1.  ;
  1. NAMECVT(%) ;
  1.  S %=$TR(%,"abcdefghijklmnopqrstuvwxyz)(/","ABCDEFGHIJKLMNOPQRSTUVWXYZ---")
  1.  S BDWALN=$P(%,",",1),BDWAFN=$P($P(%,",",2)," ",1),BDWAMN=$P($P(%,",",2)," ",2)
  1.  I $P(%,",",3)]"" S BDWALN=BDWALN_" "_$P(%,",",3)
  1.  Q
  1.  ;
  1. RG2 ;
  1.  S T(2)="RG2",T(5)="RG5"
  1.  ;
  1.  ; R2P2:MotherMaiden Last^First^MI
  1.  I $D(^DPT(DFN,.24)) D NAMECVT($P(^(.24),U,3)) S $P(T(2),U,2)=BDWALN,$P(T(2),U,3)=BDWAFN,$P(T(2),U,4)=$E(BDWAMN)
  1.  ;
  1.  ; R2P5:DateOfDeath
  1.  I $D(^DPT(DFN,.35)) S $P(T(2),U,5)=^(.35)+17000000
  1.  ;
  1.  KILL BDWAFLG
  1.  S BDWACT=""
  1.  G MCR:'$D(^AUPNRRE(DFN,0)),MCR:$P(^AUPNRRE(DFN,0),U,3)=""!($P(^(0),U,4)="")
  1.  S BDWANUMB=$P(^AUTTRRP($P(^AUPNRRE(DFN,0),U,3),0),U)_$P(^AUPNRRE(DFN,0),U,4),BDWARR=0
  1. RRD ;
  1.  S BDWARR=$O(^AUPNRRE(DFN,11,BDWARR))
  1.  G MCR:BDWARR=""
  1.  S BDWAR1=BDWARR,BDWACT=$P(^AUPNRRE(DFN,11,BDWAR1,0),U,3),BDWAVAL=$P(^(0),U),BDWAELGE=$P(^(0),U,2)
  1.  D PTA
  1.  S:$P(^AUPNRRE(DFN,11,BDWAR1,0),U,2)]"" $P(T(2),U,BDWAN1)="N"
  1.  G RRD
  1.  ;
  1. MCR ;
  1.  G MCD:'$D(^AUPNMCR(DFN,0)),MCD:$P(^AUPNMCR(DFN,0),U,3)=""!($P(^(0),U,4)="")
  1.  S BDWANUMB=$P(^AUPNMCR(DFN,0),U,3)_$P(^AUTTMCS($P(^AUPNMCR(DFN,0),U,4),0),U),BDWARR=0
  1.  G:'$D(^AUPNMCR(DFN,21)) MCRCONT
  1.  I $P(^AUPNMCR(DFN,21),U)]"" D NAMECVT($P(^(21),U)) S $P(T(5),U,7)=BDWALN,$P(T(5),U,8)=BDWAFN,$P(T(5),U,9)=BDWAMN
  1.  ;Set Medicare Elig. date to CCYYMMDD -- RG5^13
  1.  I $P(^AUPNMCR(DFN,21),U,2)]"" S $P(T(5),U,13)=$P(^(21),U,2)+17000000
  1. MCRCONT ;
  1.  S BDWARR=$O(^AUPNMCR(DFN,11,BDWARR))
  1.  G MCD:BDWARR=""
  1.  S BDWAR1=BDWARR,BDWACT=$P(^AUPNMCR(DFN,11,BDWAR1,0),U,3),BDWAVAL=$P(^(0),U),BDWAELGE=$P(^(0),U,2)
  1.  D PTA
  1.  S:$P(^AUPNMCR(DFN,11,BDWAR1,0),U,2)]"" $P(T(2),U,BDWAN1)="N"
  1.  G MCRCONT
  1.  ;
  1. MCD ; remember that ^AUPNMCD( is -not- DINUM'd.
  1.  S BDWACT="MM"
  1.  G PRVINS:'$D(^AUPNMCD("AB",DFN))!('$O(^AUPNPAT(DFN,51,""),-1))
  1.  ; lookup previous community
  1.  S BDWA("LKDATA")=$P(^AUPNPAT(DFN,51,$O(^AUPNPAT(DFN,51,""),-1),0),U,3)
  1.  G PRVINS:BDWA("LKDATA")=""
  1.  G:'$D(^AUTTCOM(BDWA("LKDATA"),0)) PRVINS
  1.  S BDWA("STATE")=$P(^AUTTCOM(BDWA("LKDATA"),0),U,3),(BDWA("NM"),BDWA("DT"))=0,BDWAELGE=""
  1. MCD2 ;
  1.  S BDWA("NM")=$O(^AUPNMCD("AB",DFN,BDWA("STATE"),BDWA("NM")))
  1.  G MCD4:BDWA("NM")=""
  1.  S DA=0
  1. MCD3 ;
  1.  S DA=$O(^AUPNMCD("AB",DFN,BDWA("STATE"),BDWA("NM"),DA))
  1.  G MCD2:DA=""
  1.  F I=0:0 S I=$O(^AUPNMCD(DA,11,I)) Q:'(I=+I)  D
  1.  . S BDWA("LKDATA")=$P(^AUPNMCD(DA,11,I,0),U,1)
  1.  . I BDWA("LKDATA")>BDWA("DT") S BDWA("DT")=BDWA("LKDATA")_U_DA,BDWAELGE=$P(^AUPNMCD(DA,11,I,0),U,2),BDWA("MCDCT")=$P(^AUPNMCD(DA,11,I,0),U,3),BDWA("MCDST")=$P(^AUPNMCD(DA,0),U,4)
  1.  .Q
  1.  G MCD3
  1.  ;
  1. MCD4 ;
  1.  G PRVINS:+BDWA("DT")=0
  1.  S DA=$P(BDWA("DT"),U,2),BDWANUMB=$E($P(^AUPNMCD(DA,0),U,3),1,14),BDWAVAL=+BDWA("DT")
  1.  D PTA
  1.  ;
  1.  ; R2P22:Veteran
  1.  S $P(T(2),U,22)=$G(^DPT(DFN,"VET"))
  1.  ;
  1.  ; R2P32:MCaidState
  1.  S $P(T(2),U,32)=$P(^DIC(5,BDWA("MCDST"),0),U,3)
  1.  ;
  1.  ; R2P33:MCaidCovType
  1.  S $P(T(2),U,33)=BDWA("MCDCT")
  1.  ;
  1.  G:'$D(^AUPNMCD(DA,21)) PRVINS
  1.  ;
  1.  ; R5P10:MCaidName Last^First^MI
  1.  I $P(^AUPNMCD(DA,21),U)]"" D NAMECVT($P(^(21),U)) S $P(T(5),U,10)=BDWALN,$P(T(5),U,11)=BDWAFN,$P(T(5),U,12)=BDWAMN
  1.  ;
  1.  ; R5P14:MCaidDOB
  1.  I $P(^AUPNMCD(DA,21),U,2)]"" S $P(T(5),U,14)=$P(^(21),U,2)+17000000
  1.  ;
  1. PRVINS ; R2P24:OtherEligible
  1.  S:$D(^AUPNPRVT(DFN,0)) $P(T(2),U,24)="Y"
  1.  ;
  1.  ; R2P25:CHSEligibility
  1.  S:$P(BDWAN11,U,12)="C" $P(T(2),U,25)="Y"
  1.  ;
  1.  ; R2P26:(?)PtSigned
  1.  ;
  1.  ; R2P27:AddModCode
  1.  S $P(T(2),U,27)=1
  1.  ;
  1.  ; R2P28:MMReleaseDate
  1.  I $P(BDWAPAT0,U,4) S $P(T(2),U,28)=$P(BDWAPAT0,U,4)+17000000
  1.  ;
  1.  ; R2P29:Eligilibity^BICElig^BICIssued
  1.  S $P(T(2),U,29)=$P(BDWAN11,U,12),$P(T(2),U,30)=$P(BDWAN11,U,24)
  1.  S:$P(BDWAN11,U,26)="Y" $P(T(2),U,31)="Y"
  1.  ;
  1.  ; R2P34:DateLastUpdate
  1.  I $P(BDWAPAT0,U,3) S $P(T(2),U,34)=$P(BDWAPAT0,U,3)+17000000
  1.  ;
  1.  D SET(2)
  1.  Q
  1.  ;
  1. PTA ; R2/R5 MMInfo
  1.  Q:'$D(BDWACT)  Q:(BDWACT'?1A.A)  Q:$D(BDWAFLG(BDWACT))
  1.  S BDWAN1=$S(BDWACT="A":6,BDWACT="B":10,BDWACT="AB":14,BDWACT="MM":18,1:0)
  1.  Q:BDWAN1=0
  1.  S $P(T(2),U,BDWAN1)="Y",$P(T(2),U,BDWAN1+1)=BDWANUMB,$P(T(2),U,BDWAN1+2)=""
  1.  ;Set Medicaid & Medicare Elig. dates to CCYYMMDD -- RG2^9,13,17,21
  1.  I $G(BDWAVAL) S $P(T(2),U,BDWAN1+3)=BDWAVAL+17000000
  1.  ;Set Medicaid & Medicare Elig. end dates to CCYYMMDD -- RG5^15,16,17,18
  1.  I $G(BDWAELGE) S BDWAELGE=BDWAELGE+17000000
  1.  S $P(T(5),U,$S(BDWACT="A":15,BDWACT="B":16,BDWACT="AB":17,BDWACT="MM":18))=BDWAELGE
  1.  S BDWAFLG(BDWACT)=""
  1.  Q
  1.  ;
  1. RG4 ;
  1.  D NAMECVT($P(BDWADPT0,U))
  1.  S BDWARSIT=0
  1.  F  S BDWARSIT=$O(^AUPNPAT(DFN,41,BDWARSIT)) Q:BDWARSIT'>0  D
  1.  . I $L($P(^AUPNPAT(DFN,41,BDWASITE,0),U,5)) Q:"DM"[$P(^(0),U,5)
  1.  . Q:"T"=$E($P(^AUPNPAT(DFN,41,BDWARSIT,0),U,2))
  1.  . S T(4)="RG4"_U_$P($G(^AUTTLOC(BDWATXST,0)),U,10)_U_$E(BDWALN)_U_$E(BDWAFN)_U_$P(BDWADPT0,U,2)_U_$P($G(^AUPNPAT(DFN,41,BDWATXST,0)),U,2)_"^^"_$P($G(^AUTTLOC(BDWARSIT,0)),U,10)_U_$P($G(^AUPNPAT(DFN,41,BDWARSIT,0)),U,2)
  1.  . D SET(4)
  1.  .Q
  1.  KILL BDWARSIT
  1.  Q
  1.  ;
  1. RG5 ;
  1.  NEW I
  1.  F I=6,10,14,18 I $P(T(2),U,I)="Y" D  ;>Set Coverages
  1.  . S $P(T(5),U,2,6)=$P(T(2),U,I+1)_U_$P(T(2),U,I+2)_U_$S(I=6:1,I=10:2,I=14:3,1:4)_U_$P(T(1),U,8)_U_$P(T(2),U,I+3)
  1.  . D SET(5)
  1.  .Q
  1.  Q
  1.  ;
  1. SET(%) ;
  1.  S BDWAROUT=BDWAROUT+1,^BDWRDATA(BDWAROUT)=$P(T(%),U,1)_U_$$UID^BDWAID(DFN)_U_$P(T(%),U,2,999),BDWA("TOT")=BDWA("TOT")+1
  1.  S BDWAIN06=BDWAIN06+$L(^BDWRDATA(BDWAROUT))+$L(BDWAROUT)+11
  1.  Q
  1.  ;