BDWDWPX ; IHS/CMI/LAB - RPMS report for DW export-3/12/2004 12:46:58 PM ; 30 May 2005 6:52 PM
;;1.0;IHS DATA WAREHOUSE;**2**;JAN 23, 2006
;
;IHS/SD/lwj 4/16/04
; DW team requested changes - routine altered to allow
; automate calls and ready for natl dist.
; * variables "new"ed for integration
; * temp gbl renamed to BDWDWPX for XBGSAVE
; * visit info excluded
; * merged patients bypassed
Q ;IHS/SD/lwj
;
INCREP ;EP IHS/SD/lwj 4/20/04 gather information for patients
; whose records have been modified since the last
; update export. This entry point is called from the
; DW menu and needs to be run PRIOR to the export.
W:$D(IOF) @IOF
W !!,"This option is used to create a registration audit file prior"
W !,"to generate transactions to send to the data warehouse (GDW option)."
W !!,"This option should only be run immediately prior to using the GDW"
W !,"option."
S BDW("RUN LOCATION")=$P($G(^BDWSITE(1,0)),U)
I DUZ(2)'=BDW("RUN LOCATION") W !,"You need to be logged in as ",$P(^DIC(4,BDW("RUN LOCATION"),0),U)," in order to do this audit report.",! K BDW Q
K DIR
S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I 'Y Q
K ^BDWDWPX($J)
S ^BDWDWPX($J,0)="H0^"_$P($$DATE^INHUT($$NOW^XLFDT,1),"-")
N DFN,AGDPT,AGAUPN,AGNAME,AG,AGRCNT,AGFLAG
S U="^"
S (AGRCNT,DFN)=0
W !!,"Now creating the update DW Patient Audit file...."
F S DFN=$O(^AUPNDWAF(DFN)) Q:+DFN=0 D
. I '$D(^AUPNPAT(DFN,0)) Q
. S AGDPT=$G(^DPT(DFN,0))
. Q:AGDPT=""
. Q:$P(AGDPT,U,19)]" " ;IHS/SD/lwj 4/20/04 merged away flag set
. S AGAUPN=$G(^AUPNPAT(DFN,0))
. S AGNAME=$P($G(^DPT(DFN,0)),U)
. D PROCESS
. S AGRCNT=AGRCNT+1
. I AGRCNT#100=0 W "."
;
S:AGRCNT>0 AGFLAG=$$WRITE^BDWDWPX1 ;IHS/CMI/LAB - had to break routine due to size
I AGRCNT=0 D
. W !!!,"**** DW INCREMENTAL FILE EMPTY - "
. W " AUDIT FILE NOT CREATED ****",!!!
. H 5
Q
FULLEP() ;EP IHS/SD/lwj 4/20/04 gather information for all patients
; This entry point is called from the BDW1BLR routine, which
; is a full patient export for the data warehouse.
K ^BDWDWPX($J) S ^BDWDWPX($J,0)="H0^"_$P($$DATE^INHUT($$NOW^XLFDT,1),"-")
N DFN,AGDPT,AGAUPN,AGNAME,AG,AGRCNT,AGFLAG
S U="^"
S (DFN,AGRCNT)=0
W !!,"Now creating the full DW Patient Audit file...."
F S DFN=$O(^DPT(DFN)) Q:'+DFN D
. S AGDPT=$G(^DPT(DFN,0))
. Q:$P(AGDPT,U,19)]" " ;IHS/SD/lwj 4/20/04 merged away flag set
. S AGAUPN=$G(^AUPNPAT(DFN,0))
. S AGNAME=$P($G(^DPT(DFN,0)),U)
. D PROCESS
. S AGRCNT=AGRCNT+1
. W:AGRCNT#1000=0 "."
S AGFLAG=$$WRITE^BDWDWPX1
Q AGFLAG
PROCESS ; this routine simply acts as the driver for gathering the
; needed information - regardless of a full or partial run
N AGCCHK,AGUID
D P1REC ;demographic info
D P2REC ;more demographic info
D P4REC ;chart information
I 'AGCCHK K AG(DFN) Q ;no chart? don't continue
D SAVE ;save the p1 and p2 records to the global
D P3REC ;alias information
D CARE ;gather medicare info (p5 record)
D RAIL ;gather railroad info (p5 record)
D CAID ;gather medicaid info (p5 record)
D PI ;gather private insurance info (p5 record)
D SAVE2 ;save the p3, p4 and p5 records to the global
K AG(DFN)
Q
;
P1REC ; this routine creates the P1 record
; P1^Unique ID^Modication Date^Unique Reg ID^DOB^Date of Death
; ^Cause of Death^Gender^SSN^SSN Verification Code^Father
; ^Mother^Creation Date
N AGDOB,AGDOD,AGCOD,AGSEX,AGSSN,AGSSNV
N AGFTHR,AGMTHR,AGCRTDT,AGURID,AGMDT
S AGUID=$$UID^BDWAID(DFN) ;Unique ID
S AGMDT=""
S:$D(^AUPNDWAF(DFN)) AGMDT=$$DATE^INHUT($P(^AUPNDWAF(DFN,0),U,2)) ;Date/Time of mods
S AGURID=DFN ;Unique Reg ID
S AGDOB=$$DATE^INHUT($P(AGDPT,U,3)) ;DOB
S AGDOD=$$DATE^INHUT($P($G(^DPT(DFN,.35)),U)) ;DOD
S AGCOD=$P($G(^AUPNPAT(DFN,11)),U,14) ;Cause of Death
;S:$G(AGCOD)'="" AGCOD=$P($G(^ICD9(AGCOD,0)),"^") ;cmi/anch/maw 8/27/2007 orig line patch 2
S:$G(AGCOD)'="" AGCOD=$P($$ICDDX^ICDCODE(AGCOD,AGDOD),"^",2) ;cmi/anch/maw 8/27/2007 code set versioning patch 2
S AGSEX=$P(AGDPT,U,2) ;Gender
S AGSSN=$P(AGDPT,U,9) ;SSN
S AGSSNV=$$GET1^DIQ(9000001,DFN,.23) ;SSN ver. code
S AGFTHR=$P($G(^DPT(DFN,.24)),U) ;father
S AGMTHR=$P($G(^DPT(DFN,.24)),U,3) ; mother
S AGCRTDT=$$DATE^INHUT($P(AGAUPN,U,2)) ;create date
S AG(DFN,"P1")="P1^"_AGUID_"^"_AGMDT_"^"_AGURID
S AG(DFN,"P1")=$G(AG(DFN,"P1"))_"^"_AGDOB_"^"_AGDOD_"^"_AGCOD_"^"_AGSEX
S AG(DFN,"P1")=$G(AG(DFN,"P1"))_"^"_AGSSN_"^"_AGSSNV_"^"_AGFTHR
S AG(DFN,"P1")=$G(AG(DFN,"P1"))_"^"_AGMTHR_"^"_AGCRTDT
Q
P2REC ;this subroutine creates the P2 record
; P2^Unique ID^Modification Date^Patient^Address^City^State
; ^Zip^Community of Residence^Date Moved^Eligibility
; ^Veteran^Classification^Tribe^Blood Quantum^Rec Status
N AGPAT,AGSTR,AGCITY,AGST,AGZIP,AGCOM,AGDTM,AGVET,AGCLS
N AGTRIBE,AGBLD,AGRECS,AGELIG,AGVAL,AGMDT
S AGMDT=""
S:$D(^AUPNDWAF(DFN)) AGMDT=$$DATE^INHUT($P(^AUPNDWAF(DFN,0),U,4)) ;Date/Time of mods
S AGPAT=$P(AGDPT,U) ;patient
S AGSTR=$P($G(^DPT(DFN,.11)),U) ;street
S AGCITY=$P($G(^DPT(DFN,.11)),U,4) ;city
;S AGST=$P($G(^DPT(DFN,.11)),U,5) S AGST=$S($G(AGST):$P(^DIC(5,AGST,0),U,2),1:"") ;state IHS/SD/lwj 7/15/04 use VA state code now
S AGST=$P($G(^DPT(DFN,.11)),U,5) S AGST=$S($G(AGST):$P(^DIC(5,AGST,0),U,2),1:"") ;state IHS/SD/lwj 7/15/04 using VA state code
S AGZIP=$P($G(^DPT(DFN,.11)),U,6) ;zip
S AGCOM=$P($G(^AUPNPAT(DFN,11)),U,17) ;community of residence
S:AGCOM AGCOM=$P($G(^AUTTCOM(AGCOM,0)),U,8)
S AGDTM=$$DATE^INHUT($P($G(^AUPNPAT(DFN,11)),U,13)) ;date moved to community
S AGELIG=$P($G(^AUPNPAT(DFN,11)),U,12) ;eligibility
S AGVET=$S($D(^DPT(DFN,"VET")):$P($G(^DPT(DFN,"VET")),U),1:"N") ;veteran elig
S AGCLS=$S($P($G(^AUPNPAT(DFN,11)),U,11):$P($G(^AUTTBEN($P($G(^AUPNPAT(DFN,11)),U,11),0)),U,2),1:"") ;class
S AGTRIBE=$S($P($G(^AUPNPAT(DFN,11)),U,8):$P($G(^AUTTTRI($P($G(^AUPNPAT(DFN,11)),U,8),0)),U,2),1:"") ;tribe
S AGVAL=$P($G(^AUPNPAT(DFN,11)),U,10) ;blood
D QNTCVT^AGTX1 ;converts quantum to number 1->7
S AGBLD=Y
S AGRECS=$P($G(^DPT(DFN,0)),U,19) ;reg record status
S AG(DFN,"P2")="P2^"_AGUID_"^"_AGMDT_"^"_AGPAT_"^"_AGSTR_"^"_AGCITY_"^"_AGST_"^"_AGZIP
S AG(DFN,"P2")=$G(AG(DFN,"P2"))_"^"_AGCOM_"^"_$G(AGDTM)_"^"_AGELIG_"^"_AGVET
S AG(DFN,"P2")=$G(AG(DFN,"P2"))_"^"_AGCLS_"^"_AGTRIBE_"^"_AGBLD_"^"_AGRECS
Q
;
P3REC ;this subroutine creates the P3 record - Alias
; P3^Unique ID^Modification Date^Alais
N AGALS,AGD0,AGMDT
S AGMDT=""
S:$D(^AUPNDWAF(DFN)) AGMDT=$$DATE^INHUT($P(^AUPNDWAF(DFN,0),U,6)) ;Date/Time of mods
S AGD0=0
F S AGD0=$O(^DPT(DFN,.01,AGD0)) Q:AGD0="" D
. S AGALS=$P($G(^DPT(DFN,.01,AGD0,0)),U)
. S AG(DFN,"P3",AGD0)="P3^"_AGUID_"^"_AGD0_"^"_AGMDT_"^"_AGALS
Q
;
P4REC ;this subroutine creates the P4 record - facility/chart info
; P4^Unique ID^Modification Date^Facility^Chart^Chart Status
N AGCFAC,AGCHRT,AGCHRTS,AGD0,AGMDT,AGPAT41
S AGCCHK=0 ;chart check flag
S AGMDT=""
S:$D(^AUPNDWAF(DFN)) AGMDT=$$DATE^INHUT($P(^AUPNDWAF(DFN,0),U,8)) ;Date/Time of mods
S AGD0=0
F S AGD0=$O(^AUPNPAT(DFN,41,AGD0)) Q:+AGD0=0 D
. Q:$P($G(^AGFAC(AGD0,0)),"^",21)'="Y" ;only want ORFs
. S AGCFAC=$P($G(^AUTTLOC(AGD0,0)),U,10)
. S AGPAT41=$G(^AUPNPAT(DFN,41,AGD0,0))
. S AGCHRT=$P(AGPAT41,U,2) ;chart
. S AGCHRTS=$P(AGPAT41,U,5) ;chart status
. S AG(DFN,"P4",AGD0)="P4^"_AGUID_"^"_AGCFAC_"^"_AGMDT_"^"_AGCFAC_"^"_AGCHRT_"^"_AGCHRTS
. S AGCCHK=1 ;chart found
Q
;
CARE ; Create p5 record - medicare eligibility
N AGLID,AGDTM,AGCAT,AGCOV,AGBEG,AGPOLN,AGMCDST,AGMCDPLN
N AGINS,AGEND,AGEIN,AGPRE,AGPOL,AGREL,AGUPDT,AGCNT
N AGD1,AGMDT
Q:'$D(^AUPNMCR(DFN)) ;no entry in mcr file
S AGLID=DFN ;local ID
S AGCNT=1
S AGMDT=""
S:$D(^AUPNDWAF(DFN)) AGDTM=$$DATE^INHUT($P(^AUPNDWAF(DFN,0),U,11)) ;Date/Time of mods
S AGCAT="MCR" ;Ins. Category
S AGPOLN=$P($G(^AUPNMCR(DFN,0)),U,3) ;policy number
S AGPRE=$P($G(^AUPNMCR(DFN,0)),U,4) ;Prefix/Suffix
S AGMCDST="" ;MCD state
S AGMCDPLN="" ;MCD plan
S AGEIN=$S($P($G(^AUPNMCR(DFN,0)),U,2):$P($G(^AUTNINS($P($G(^AUPNMCR(DFN,0)),U,2),0)),U,7),1:"") ;Insurer EIN
S AGPOL="" I $P($G(^AUPNMCR(DFN,0)),U) S AGPOL=$P($G(^DPT($P($G(^AUPNMCR(DFN,0)),U),0)),"^") ;Policy Holder
S AGREL="" ;Relationship
S AGUPDT=$$DATE^INHUT($P($G(^AUPNMCR(DFN,0)),U,7)) ;Date of last update
S AGINS=$S($P($G(^AUPNMCR(DFN,0)),U,2):$P($G(^AUTNINS($P($G(^AUPNMCR(DFN,0)),U,2),0)),U),1:"") ;Insurer name cmi/maw 6/30/2004 missing insurer causes sbscr
I $P($G(^AUPNMCR(DFN,0)),U,4)'="" S AGPRE=$P(^AUTTMCS($P($G(^AUPNMCR(DFN,0)),U,4),0),"^") ;Policy Prefix/Suffix
S AGD1=0
F S AGD1=$O(^AUPNMCR(DFN,11,AGD1)) Q:AGD1="" D
. S AGCOV=$P($G(^AUPNMCR(DFN,11,AGD1,0)),U,3) ;Coverage Type
. S AGBEG=$$DATE^INHUT($P($G(^AUPNMCR(DFN,11,AGD1,0)),U,1)) ;Begin date
. S AGEND=$$DATE^INHUT($P($G(^AUPNMCR(DFN,11,AGD1,0)),U,2)) ;End date
. D P5REC ;write the p5 record to the array
Q
;
RAIL ; Create p5 record - railroad eligibility
N AGLID,AGDTM,AGCAT,AGCOV,AGBEG,AGPOLN,AGMCDST,AGMCDPLN
N AGINS,AGEND,AGEIN,AGPRE,AGPOL,AGREL,AGUPDT,AGCNT
N AGD1,AGMDT
S AGCNT=1
Q:'$D(^AUPNRRE(DFN))
S AGLID=DFN ;local ID
S AGMDT=""
S:$D(^AUPNDWAF(DFN)) AGDTM=$$DATE^INHUT($P(^AUPNDWAF(DFN,0),U,11)) ;Date/Time of mods
S AGCAT="RRE" ;Ins. Category
S AGPOLN=$P($G(^AUPNRRE(DFN,0)),U,4) ;policy number
S AGMCDST="" ;MCD state
S AGMCDPLN="" ;MCD plan
S AGINS=$P($G(^AUPNRRE(DFN,0)),U,2) ;Insurer pointer
Q:AGINS=""
S AGINS=$P($G(^AUTNINS(AGINS,0)),U) ;Insurer name
S AGEIN=$S($P($G(^AUPNRRE(DFN,0)),U,2):$P($G(^AUTNINS($P($G(^AUPNRRE(DFN,0)),U,2),0)),U,7),1:"") ;Insurer EIN
I $P($G(^AUPNRRE(DFN,0)),U,3)'="" S AGPRE=$P(^AUTTRRP($P($G(^AUPNRRE(DFN,0)),U,3),0),"^") ;Policy Prefix/Suffix
E S AGPRE=""
S AGPOL="" ;Policy Holder
S AGREL="" ;Relationship
S AGUPDT=$$DATE^INHUT($P($G(^AUPNRRE(DFN,0)),U,7)) ;Date of last update
S AGD1=0 ;IHS/SD/lwj 5/3/04 chged from ""
F S AGD1=$O(^AUPNRRE(DFN,11,AGD1)) Q:AGD1="" D
. S AGCOV=$P($G(^AUPNRRE(DFN,11,AGD1,0)),U,3) ;Coverage Type
. S AGBEG=$$DATE^INHUT($P($G(^AUPNRRE(DFN,11,AGD1,0)),U,1)) ;Begin date
. S AGEND=$$DATE^INHUT($P($G(^AUPNRRE(DFN,11,AGD1,0)),U,2)) ;End date
. D P5REC ;write the p5 record to the array
Q
;
CAID ; Create p5 record - medicaid eligibility
N AGLID,AGDTM,AGCAT,AGCOV,AGBEG,AGPOLN,AGMCDST,AGMCDPLN
N AGINS,AGEND,AGEIN,AGPRE,AGPOL,AGREL,AGUPDT,AGCNT
N AGIEN,AGD1
S AGCNT=1
S AGDTM=""
S AGIEN=0
F S AGIEN=$O(^AUPNMCD("B",DFN,AGIEN)) Q:AGIEN="" D
. S AGLID=AGIEN ;local ID
. S:$D(^AUPNDWAF(DFN)) AGDTM=$$DATE^INHUT($P(^AUPNDWAF(DFN,0),U,11)) ;Date/Time of mods
. S AGCAT="MCD" ;Ins. Category
. S AGPOLN=$P($G(^AUPNMCD(AGIEN,0)),"^",3) ;policy number
. S AGMCDST=""
. S:$P($G(^AUPNMCD(AGIEN,0)),U,4) AGMCDST=$P($G(^DIC(5,$P($G(^AUPNMCD(AGIEN,0)),U,4),0)),U,3) ;MCD stateIHS/CMI/LAB - changed piece 2 to piece 3 for state code
. S AGMCDPLN=$S($P($G(^AUPNMCD(AGIEN,0)),U,10):$P($G(^AUTNINS($P($G(^AUPNMCD(AGIEN,0)),U,10),0)),U),1:"") ;MCD plan
. S AGINS=$S($P($G(^AUPNMCD(AGIEN,0)),U,2):$P($G(^AUTNINS($P($G(^AUPNMCD(AGIEN,0)),U,2),0)),U),1:"") ;Insurer name
. S AGEIN=$S($P($G(^AUPNMCD(AGIEN,0)),U,2):$P($G(^AUTNINS($P($G(^AUPNMCD(AGIEN,0)),U,2),0)),U,7),1:"") ;Insurer EIN
. S AGPRE="" ;Policy Prefix/Suffix
. S AGUPDT=$$DATE^INHUT($P($G(^AUPNMCD(AGIEN,0)),U,8)) ;Date of last update
. S AGPOL=$S($P($G(^AUPNMCD(AGIEN,0)),U,9):$P($G(^DPT($P($G(^AUPNMCD(AGIEN,0)),U,9),0)),U),1:$P($G(^AUPNMCD(AGIEN,0)),U,5)) ;Policy Holder
. S AGREL=$S($P($G(^AUPNMCD(AGIEN,0)),U,6):$P($G(^AUTTRLSH($P($G(^AUPNMCD(AGIEN,0)),U,6),0)),U),1:"") ;Relationship
. S AGD1=0
. F S AGD1=$O(^AUPNMCD(AGIEN,11,AGD1)) Q:AGD1="" D
.. S AGCOV=$P($G(^AUPNMCD(AGIEN,11,AGD1,0)),U,3) ;Coverage Type
.. S AGBEG=$$DATE^INHUT($P($G(^AUPNMCD(AGIEN,11,AGD1,0)),U,1)) ;Begin date
.. S AGEND=$$DATE^INHUT($P($G(^AUPNMCD(AGIEN,11,AGD1,0)),U,2)) ;End date
.. D P5REC ;write the p5 record out to the array
Q
;
PI ; Create p5 record - private eligibility
N AGLID,AGDTM,AGCAT,AGCOV,AGBEG,AGPOLN,AGMCDST,AGMCDPLN
N AGINS,AGEND,AGEIN,AGPRE,AGPOL,AGREL,AGUPDT,AGCNT
N AGPOLI,AGD1,AGPOL0
S AGCNT=1
Q:'$D(^AUPNPRVT(DFN))
S AGD1=0
F S AGD1=$O(^AUPNPRVT(DFN,11,AGD1)) Q:AGD1=""!(+AGD1=0) D
. Q:$P(^AUPNPRVT(DFN,11,AGD1,0),U)=""
. S (AGPOL,AGCOV,AGPOLN,AGDTM)=""
. S AGLID=AGD1 ;local ID
. S:$D(^AUPNDWAF(DFN)) AGDTM=$$DATE^INHUT($P(^AUPNDWAF(DFN,0),U,11)) ;Date/Time of mods
. S AGCAT="PVT" ;Ins. Category
. S AGBEG=$$DATE^INHUT($P($G(^AUPNPRVT(DFN,11,AGD1,0)),U,6)) ;Begin dt
. S AGPOLI=$P($G(^AUPNPRVT(DFN,11,AGD1,0)),U,8) ;Policy Hldr
. I $G(AGPOLI) D
.. S AGPOL0=$G(^AUPN3PPH(AGPOLI,0)) ;policy hldr file
.. S AGPOL=$P(AGPOL0,U)
.. S AGPOLN=$P(AGPOL0,U,4) ;policy #
.. S AGCOV=$P(AGPOL0,U,5) ;covg type pntr
.. S:AGCOV'="" AGCOV=$P($G(^AUTTPIC(AGCOV,0)),U) ;Covg Type
. S AGMCDST="" ;MCD state
. S AGMCDPLN="" ;MCD plan
. S AGINS=$P($G(^AUTNINS($P($G(^AUPNPRVT(DFN,11,AGD1,0)),U,1),0)),U) ;Insurer name
. S AGEND=$$DATE^INHUT($P($G(^AUPNPRVT(DFN,11,AGD1,0)),U,7)) ;End date
. S AGEIN=$S($P($G(^AUPNPRVT(DFN,11,AGD1,0)),U):$P($G(^AUTNINS($P($G(^AUPNPRVT(DFN,11,AGD1,0)),U),0)),U,7),1:"") ;Insurer EIN
. S AGPRE="" ;Policy Prefix/Suffix
. S AGREL=$S($P($G(^AUPNPRVT(DFN,11,AGD1,0)),U,5):$P($G(^AUTTRLSH($P($G(^AUPNPRVT(DFN,11,AGD1,0)),U,5),0)),U),1:"") ;Relationship
. S AGUPDT="" ;Date of last update
. D P5REC ;write the p5 record to the array
Q
;
P5REC ; write the eligibility data to the p5 record in the array
; P5^Unique ID^Modification Date^Category^Coverage Type
; ^Begin Date^Policy Number^Medicaid State^Plan^Insurer
; ^End Date^Insurer EIN^Prefix/Suffix^Policy Holder
; ^Relationship^Last Updated
S AG(DFN,"P5",AGCAT_AGCNT_AGD1)="P5^"_AGUID_"^"_$G(AGDTM)_"^"_AGCAT_"^"_AGCOV_"^"_AGBEG
S AG(DFN,"P5",AGCAT_AGCNT_AGD1)=$G(AG(DFN,"P5",AGCAT_AGCNT_AGD1))_"^"_AGPOLN_"^"_AGMCDST_"^"_AGMCDPLN
S AG(DFN,"P5",AGCAT_AGCNT_AGD1)=$G(AG(DFN,"P5",AGCAT_AGCNT_AGD1))_"^"_AGINS_"^"_AGEND_"^"_AGEIN
S AG(DFN,"P5",AGCAT_AGCNT_AGD1)=$G(AG(DFN,"P5",AGCAT_AGCNT_AGD1))_"^"_AGPRE_"^"_AGPOL_"^"_AGREL_"^"_AGUPDT
S AGCNT=AGCNT+1
Q
;
SAVE ; save the p1 and p2 array entries to the temp global
N AGTMP,AGTMP1,AGTMP2
S AGTMP=""
F AGTMP="P1","P2" D
.S ^BDWDWPX($J,DFN,AGTMP)=$G(AG(DFN,AGTMP))
.K AG(DFN,AGTMP)
Q
;
SAVE2 ; save the p3, p4 and p5 array entries (which may be multiples)
; to the temp global
N AGTMP1,AGTMP2
S (AGTMP1,AGTMP2)=""
F AGTMP1="P3","P4","P5" D
.S AGTMP2=0
.F S AGTMP2=$O(AG(DFN,AGTMP1,AGTMP2)) Q:AGTMP2="" D
..S ^BDWDWPX($J,DFN,AGTMP1,AGTMP2)=$G(AG(DFN,AGTMP1,AGTMP2))
K AG(DFN)
Q
BDWDWPX ; IHS/CMI/LAB - RPMS report for DW export-3/12/2004 12:46:58 PM ; 30 May 2005 6:52 PM
+1 ;;1.0;IHS DATA WAREHOUSE;**2**;JAN 23, 2006
+2 ;
+3 ;IHS/SD/lwj 4/16/04
+4 ; DW team requested changes - routine altered to allow
+5 ; automate calls and ready for natl dist.
+6 ; * variables "new"ed for integration
+7 ; * temp gbl renamed to BDWDWPX for XBGSAVE
+8 ; * visit info excluded
+9 ; * merged patients bypassed
+10 ;IHS/SD/lwj
QUIT
+11 ;
INCREP ;EP IHS/SD/lwj 4/20/04 gather information for patients
+1 ; whose records have been modified since the last
+2 ; update export. This entry point is called from the
+3 ; DW menu and needs to be run PRIOR to the export.
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !!,"This option is used to create a registration audit file prior"
+6 WRITE !,"to generate transactions to send to the data warehouse (GDW option)."
+7 WRITE !!,"This option should only be run immediately prior to using the GDW"
+8 WRITE !,"option."
+9 SET BDW("RUN LOCATION")=$PIECE($GET(^BDWSITE(1,0)),U)
+10 IF DUZ(2)'=BDW("RUN LOCATION")
WRITE !,"You need to be logged in as ",$PIECE(^DIC(4,BDW("RUN LOCATION"),0),U)," in order to do this audit report.",!
KILL BDW
QUIT
+11 KILL DIR
+12 SET DIR(0)="Y"
SET DIR("A")="Do you want to continue"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+13 IF $DATA(DIRUT)
QUIT
+14 IF 'Y
QUIT
+15 KILL ^BDWDWPX($JOB)
+16 SET ^BDWDWPX($JOB,0)="H0^"_$PIECE($$DATE^INHUT($$NOW^XLFDT,1),"-")
+17 NEW DFN,AGDPT,AGAUPN,AGNAME,AG,AGRCNT,AGFLAG
+18 SET U="^"
+19 SET (AGRCNT,DFN)=0
+20 WRITE !!,"Now creating the update DW Patient Audit file...."
+21 FOR
SET DFN=$ORDER(^AUPNDWAF(DFN))
IF +DFN=0
QUIT
Begin DoDot:1
+22 IF '$DATA(^AUPNPAT(DFN,0))
QUIT
+23 SET AGDPT=$GET(^DPT(DFN,0))
+24 IF AGDPT=""
QUIT
+25 ;IHS/SD/lwj 4/20/04 merged away flag set
IF $PIECE(AGDPT,U,19)]" "
QUIT
+26 SET AGAUPN=$GET(^AUPNPAT(DFN,0))
+27 SET AGNAME=$PIECE($GET(^DPT(DFN,0)),U)
+28 DO PROCESS
+29 SET AGRCNT=AGRCNT+1
+30 IF AGRCNT#100=0
WRITE "."
End DoDot:1
+31 ;
+32 ;IHS/CMI/LAB - had to break routine due to size
IF AGRCNT>0
SET AGFLAG=$$WRITE^BDWDWPX1
+33 IF AGRCNT=0
Begin DoDot:1
+34 WRITE !!!,"**** DW INCREMENTAL FILE EMPTY - "
+35 WRITE " AUDIT FILE NOT CREATED ****",!!!
+36 HANG 5
End DoDot:1
+37 QUIT
FULLEP() ;EP IHS/SD/lwj 4/20/04 gather information for all patients
+1 ; This entry point is called from the BDW1BLR routine, which
+2 ; is a full patient export for the data warehouse.
+3 KILL ^BDWDWPX($JOB)
SET ^BDWDWPX($JOB,0)="H0^"_$PIECE($$DATE^INHUT($$NOW^XLFDT,1),"-")
+4 NEW DFN,AGDPT,AGAUPN,AGNAME,AG,AGRCNT,AGFLAG
+5 SET U="^"
+6 SET (DFN,AGRCNT)=0
+7 WRITE !!,"Now creating the full DW Patient Audit file...."
+8 FOR
SET DFN=$ORDER(^DPT(DFN))
IF '+DFN
QUIT
Begin DoDot:1
+9 SET AGDPT=$GET(^DPT(DFN,0))
+10 ;IHS/SD/lwj 4/20/04 merged away flag set
IF $PIECE(AGDPT,U,19)]" "
QUIT
+11 SET AGAUPN=$GET(^AUPNPAT(DFN,0))
+12 SET AGNAME=$PIECE($GET(^DPT(DFN,0)),U)
+13 DO PROCESS
+14 SET AGRCNT=AGRCNT+1
+15 IF AGRCNT#1000=0
WRITE "."
End DoDot:1
+16 SET AGFLAG=$$WRITE^BDWDWPX1
+17 QUIT AGFLAG
PROCESS ; this routine simply acts as the driver for gathering the
+1 ; needed information - regardless of a full or partial run
+2 NEW AGCCHK,AGUID
+3 ;demographic info
DO P1REC
+4 ;more demographic info
DO P2REC
+5 ;chart information
DO P4REC
+6 ;no chart? don't continue
IF 'AGCCHK
KILL AG(DFN)
QUIT
+7 ;save the p1 and p2 records to the global
DO SAVE
+8 ;alias information
DO P3REC
+9 ;gather medicare info (p5 record)
DO CARE
+10 ;gather railroad info (p5 record)
DO RAIL
+11 ;gather medicaid info (p5 record)
DO CAID
+12 ;gather private insurance info (p5 record)
DO PI
+13 ;save the p3, p4 and p5 records to the global
DO SAVE2
+14 KILL AG(DFN)
+15 QUIT
+16 ;
P1REC ; this routine creates the P1 record
+1 ; P1^Unique ID^Modication Date^Unique Reg ID^DOB^Date of Death
+2 ; ^Cause of Death^Gender^SSN^SSN Verification Code^Father
+3 ; ^Mother^Creation Date
+4 NEW AGDOB,AGDOD,AGCOD,AGSEX,AGSSN,AGSSNV
+5 NEW AGFTHR,AGMTHR,AGCRTDT,AGURID,AGMDT
+6 ;Unique ID
SET AGUID=$$UID^BDWAID(DFN)
+7 SET AGMDT=""
+8 ;Date/Time of mods
IF $DATA(^AUPNDWAF(DFN))
SET AGMDT=$$DATE^INHUT($PIECE(^AUPNDWAF(DFN,0),U,2))
+9 ;Unique Reg ID
SET AGURID=DFN
+10 ;DOB
SET AGDOB=$$DATE^INHUT($PIECE(AGDPT,U,3))
+11 ;DOD
SET AGDOD=$$DATE^INHUT($PIECE($GET(^DPT(DFN,.35)),U))
+12 ;Cause of Death
SET AGCOD=$PIECE($GET(^AUPNPAT(DFN,11)),U,14)
+13 ;S:$G(AGCOD)'="" AGCOD=$P($G(^ICD9(AGCOD,0)),"^") ;cmi/anch/maw 8/27/2007 orig line patch 2
+14 ;cmi/anch/maw 8/27/2007 code set versioning patch 2
IF $GET(AGCOD)'=""
SET AGCOD=$PIECE($$ICDDX^ICDCODE(AGCOD,AGDOD),"^",2)
+15 ;Gender
SET AGSEX=$PIECE(AGDPT,U,2)
+16 ;SSN
SET AGSSN=$PIECE(AGDPT,U,9)
+17 ;SSN ver. code
SET AGSSNV=$$GET1^DIQ(9000001,DFN,.23)
+18 ;father
SET AGFTHR=$PIECE($GET(^DPT(DFN,.24)),U)
+19 ; mother
SET AGMTHR=$PIECE($GET(^DPT(DFN,.24)),U,3)
+20 ;create date
SET AGCRTDT=$$DATE^INHUT($PIECE(AGAUPN,U,2))
+21 SET AG(DFN,"P1")="P1^"_AGUID_"^"_AGMDT_"^"_AGURID
+22 SET AG(DFN,"P1")=$GET(AG(DFN,"P1"))_"^"_AGDOB_"^"_AGDOD_"^"_AGCOD_"^"_AGSEX
+23 SET AG(DFN,"P1")=$GET(AG(DFN,"P1"))_"^"_AGSSN_"^"_AGSSNV_"^"_AGFTHR
+24 SET AG(DFN,"P1")=$GET(AG(DFN,"P1"))_"^"_AGMTHR_"^"_AGCRTDT
+25 QUIT
P2REC ;this subroutine creates the P2 record
+1 ; P2^Unique ID^Modification Date^Patient^Address^City^State
+2 ; ^Zip^Community of Residence^Date Moved^Eligibility
+3 ; ^Veteran^Classification^Tribe^Blood Quantum^Rec Status
+4 NEW AGPAT,AGSTR,AGCITY,AGST,AGZIP,AGCOM,AGDTM,AGVET,AGCLS
+5 NEW AGTRIBE,AGBLD,AGRECS,AGELIG,AGVAL,AGMDT
+6 SET AGMDT=""
+7 ;Date/Time of mods
IF $DATA(^AUPNDWAF(DFN))
SET AGMDT=$$DATE^INHUT($PIECE(^AUPNDWAF(DFN,0),U,4))
+8 ;patient
SET AGPAT=$PIECE(AGDPT,U)
+9 ;street
SET AGSTR=$PIECE($GET(^DPT(DFN,.11)),U)
+10 ;city
SET AGCITY=$PIECE($GET(^DPT(DFN,.11)),U,4)
+11 ;S AGST=$P($G(^DPT(DFN,.11)),U,5) S AGST=$S($G(AGST):$P(^DIC(5,AGST,0),U,2),1:"") ;state IHS/SD/lwj 7/15/04 use VA state code now
+12 ;state IHS/SD/lwj 7/15/04 using VA state code
SET AGST=$PIECE($GET(^DPT(DFN,.11)),U,5)
SET AGST=$SELECT($GET(AGST):$PIECE(^DIC(5,AGST,0),U,2),1:"")
+13 ;zip
SET AGZIP=$PIECE($GET(^DPT(DFN,.11)),U,6)
+14 ;community of residence
SET AGCOM=$PIECE($GET(^AUPNPAT(DFN,11)),U,17)
+15 IF AGCOM
SET AGCOM=$PIECE($GET(^AUTTCOM(AGCOM,0)),U,8)
+16 ;date moved to community
SET AGDTM=$$DATE^INHUT($PIECE($GET(^AUPNPAT(DFN,11)),U,13))
+17 ;eligibility
SET AGELIG=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
+18 ;veteran elig
SET AGVET=$SELECT($DATA(^DPT(DFN,"VET")):$PIECE($GET(^DPT(DFN,"VET")),U),1:"N")
+19 ;class
SET AGCLS=$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,11):$PIECE($GET(^AUTTBEN($PIECE($GET(^AUPNPAT(DFN,11)),U,11),0)),U,2),1:"")
+20 ;tribe
SET AGTRIBE=$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,8):$PIECE($GET(^AUTTTRI($PIECE($GET(^AUPNPAT(DFN,11)),U,8),0)),U,2),1:"")
+21 ;blood
SET AGVAL=$PIECE($GET(^AUPNPAT(DFN,11)),U,10)
+22 ;converts quantum to number 1->7
DO QNTCVT^AGTX1
+23 SET AGBLD=Y
+24 ;reg record status
SET AGRECS=$PIECE($GET(^DPT(DFN,0)),U,19)
+25 SET AG(DFN,"P2")="P2^"_AGUID_"^"_AGMDT_"^"_AGPAT_"^"_AGSTR_"^"_AGCITY_"^"_AGST_"^"_AGZIP
+26 SET AG(DFN,"P2")=$GET(AG(DFN,"P2"))_"^"_AGCOM_"^"_$GET(AGDTM)_"^"_AGELIG_"^"_AGVET
+27 SET AG(DFN,"P2")=$GET(AG(DFN,"P2"))_"^"_AGCLS_"^"_AGTRIBE_"^"_AGBLD_"^"_AGRECS
+28 QUIT
+29 ;
P3REC ;this subroutine creates the P3 record - Alias
+1 ; P3^Unique ID^Modification Date^Alais
+2 NEW AGALS,AGD0,AGMDT
+3 SET AGMDT=""
+4 ;Date/Time of mods
IF $DATA(^AUPNDWAF(DFN))
SET AGMDT=$$DATE^INHUT($PIECE(^AUPNDWAF(DFN,0),U,6))
+5 SET AGD0=0
+6 FOR
SET AGD0=$ORDER(^DPT(DFN,.01,AGD0))
IF AGD0=""
QUIT
Begin DoDot:1
+7 SET AGALS=$PIECE($GET(^DPT(DFN,.01,AGD0,0)),U)
+8 SET AG(DFN,"P3",AGD0)="P3^"_AGUID_"^"_AGD0_"^"_AGMDT_"^"_AGALS
End DoDot:1
+9 QUIT
+10 ;
P4REC ;this subroutine creates the P4 record - facility/chart info
+1 ; P4^Unique ID^Modification Date^Facility^Chart^Chart Status
+2 NEW AGCFAC,AGCHRT,AGCHRTS,AGD0,AGMDT,AGPAT41
+3 ;chart check flag
SET AGCCHK=0
+4 SET AGMDT=""
+5 ;Date/Time of mods
IF $DATA(^AUPNDWAF(DFN))
SET AGMDT=$$DATE^INHUT($PIECE(^AUPNDWAF(DFN,0),U,8))
+6 SET AGD0=0
+7 FOR
SET AGD0=$ORDER(^AUPNPAT(DFN,41,AGD0))
IF +AGD0=0
QUIT
Begin DoDot:1
+8 ;only want ORFs
IF $PIECE($GET(^AGFAC(AGD0,0)),"^",21)'="Y"
QUIT
+9 SET AGCFAC=$PIECE($GET(^AUTTLOC(AGD0,0)),U,10)
+10 SET AGPAT41=$GET(^AUPNPAT(DFN,41,AGD0,0))
+11 ;chart
SET AGCHRT=$PIECE(AGPAT41,U,2)
+12 ;chart status
SET AGCHRTS=$PIECE(AGPAT41,U,5)
+13 SET AG(DFN,"P4",AGD0)="P4^"_AGUID_"^"_AGCFAC_"^"_AGMDT_"^"_AGCFAC_"^"_AGCHRT_"^"_AGCHRTS
+14 ;chart found
SET AGCCHK=1
End DoDot:1
+15 QUIT
+16 ;
CARE ; Create p5 record - medicare eligibility
+1 NEW AGLID,AGDTM,AGCAT,AGCOV,AGBEG,AGPOLN,AGMCDST,AGMCDPLN
+2 NEW AGINS,AGEND,AGEIN,AGPRE,AGPOL,AGREL,AGUPDT,AGCNT
+3 NEW AGD1,AGMDT
+4 ;no entry in mcr file
IF '$DATA(^AUPNMCR(DFN))
QUIT
+5 ;local ID
SET AGLID=DFN
+6 SET AGCNT=1
+7 SET AGMDT=""
+8 ;Date/Time of mods
IF $DATA(^AUPNDWAF(DFN))
SET AGDTM=$$DATE^INHUT($PIECE(^AUPNDWAF(DFN,0),U,11))
+9 ;Ins. Category
SET AGCAT="MCR"
+10 ;policy number
SET AGPOLN=$PIECE($GET(^AUPNMCR(DFN,0)),U,3)
+11 ;Prefix/Suffix
SET AGPRE=$PIECE($GET(^AUPNMCR(DFN,0)),U,4)
+12 ;MCD state
SET AGMCDST=""
+13 ;MCD plan
SET AGMCDPLN=""
+14 ;Insurer EIN
SET AGEIN=$SELECT($PIECE($GET(^AUPNMCR(DFN,0)),U,2):$PIECE($GET(^AUTNINS($PIECE($GET(^AUPNMCR(DFN,0)),U,2),0)),U,7),1:"")
+15 ;Policy Holder
SET AGPOL=""
IF $PIECE($GET(^AUPNMCR(DFN,0)),U)
SET AGPOL=$PIECE($GET(^DPT($PIECE($GET(^AUPNMCR(DFN,0)),U),0)),"^")
+16 ;Relationship
SET AGREL=""
+17 ;Date of last update
SET AGUPDT=$$DATE^INHUT($PIECE($GET(^AUPNMCR(DFN,0)),U,7))
+18 ;Insurer name cmi/maw 6/30/2004 missing insurer causes sbscr
SET AGINS=$SELECT($PIECE($GET(^AUPNMCR(DFN,0)),U,2):$PIECE($GET(^AUTNINS($PIECE($GET(^AUPNMCR(DFN,0)),U,2),0)),U),1:"")
+19 ;Policy Prefix/Suffix
IF $PIECE($GET(^AUPNMCR(DFN,0)),U,4)'=""
SET AGPRE=$PIECE(^AUTTMCS($PIECE($GET(^AUPNMCR(DFN,0)),U,4),0),"^")
+20 SET AGD1=0
+21 FOR
SET AGD1=$ORDER(^AUPNMCR(DFN,11,AGD1))
IF AGD1=""
QUIT
Begin DoDot:1
+22 ;Coverage Type
SET AGCOV=$PIECE($GET(^AUPNMCR(DFN,11,AGD1,0)),U,3)
+23 ;Begin date
SET AGBEG=$$DATE^INHUT($PIECE($GET(^AUPNMCR(DFN,11,AGD1,0)),U,1))
+24 ;End date
SET AGEND=$$DATE^INHUT($PIECE($GET(^AUPNMCR(DFN,11,AGD1,0)),U,2))
+25 ;write the p5 record to the array
DO P5REC
End DoDot:1
+26 QUIT
+27 ;
RAIL ; Create p5 record - railroad eligibility
+1 NEW AGLID,AGDTM,AGCAT,AGCOV,AGBEG,AGPOLN,AGMCDST,AGMCDPLN
+2 NEW AGINS,AGEND,AGEIN,AGPRE,AGPOL,AGREL,AGUPDT,AGCNT
+3 NEW AGD1,AGMDT
+4 SET AGCNT=1
+5 IF '$DATA(^AUPNRRE(DFN))
QUIT
+6 ;local ID
SET AGLID=DFN
+7 SET AGMDT=""
+8 ;Date/Time of mods
IF $DATA(^AUPNDWAF(DFN))
SET AGDTM=$$DATE^INHUT($PIECE(^AUPNDWAF(DFN,0),U,11))
+9 ;Ins. Category
SET AGCAT="RRE"
+10 ;policy number
SET AGPOLN=$PIECE($GET(^AUPNRRE(DFN,0)),U,4)
+11 ;MCD state
SET AGMCDST=""
+12 ;MCD plan
SET AGMCDPLN=""
+13 ;Insurer pointer
SET AGINS=$PIECE($GET(^AUPNRRE(DFN,0)),U,2)
+14 IF AGINS=""
QUIT
+15 ;Insurer name
SET AGINS=$PIECE($GET(^AUTNINS(AGINS,0)),U)
+16 ;Insurer EIN
SET AGEIN=$SELECT($PIECE($GET(^AUPNRRE(DFN,0)),U,2):$PIECE($GET(^AUTNINS($PIECE($GET(^AUPNRRE(DFN,0)),U,2),0)),U,7),1:"")
+17 ;Policy Prefix/Suffix
IF $PIECE($GET(^AUPNRRE(DFN,0)),U,3)'=""
SET AGPRE=$PIECE(^AUTTRRP($PIECE($GET(^AUPNRRE(DFN,0)),U,3),0),"^")
+18 IF '$TEST
SET AGPRE=""
+19 ;Policy Holder
SET AGPOL=""
+20 ;Relationship
SET AGREL=""
+21 ;Date of last update
SET AGUPDT=$$DATE^INHUT($PIECE($GET(^AUPNRRE(DFN,0)),U,7))
+22 ;IHS/SD/lwj 5/3/04 chged from ""
SET AGD1=0
+23 FOR
SET AGD1=$ORDER(^AUPNRRE(DFN,11,AGD1))
IF AGD1=""
QUIT
Begin DoDot:1
+24 ;Coverage Type
SET AGCOV=$PIECE($GET(^AUPNRRE(DFN,11,AGD1,0)),U,3)
+25 ;Begin date
SET AGBEG=$$DATE^INHUT($PIECE($GET(^AUPNRRE(DFN,11,AGD1,0)),U,1))
+26 ;End date
SET AGEND=$$DATE^INHUT($PIECE($GET(^AUPNRRE(DFN,11,AGD1,0)),U,2))
+27 ;write the p5 record to the array
DO P5REC
End DoDot:1
+28 QUIT
+29 ;
CAID ; Create p5 record - medicaid eligibility
+1 NEW AGLID,AGDTM,AGCAT,AGCOV,AGBEG,AGPOLN,AGMCDST,AGMCDPLN
+2 NEW AGINS,AGEND,AGEIN,AGPRE,AGPOL,AGREL,AGUPDT,AGCNT
+3 NEW AGIEN,AGD1
+4 SET AGCNT=1
+5 SET AGDTM=""
+6 SET AGIEN=0
+7 FOR
SET AGIEN=$ORDER(^AUPNMCD("B",DFN,AGIEN))
IF AGIEN=""
QUIT
Begin DoDot:1
+8 ;local ID
SET AGLID=AGIEN
+9 ;Date/Time of mods
IF $DATA(^AUPNDWAF(DFN))
SET AGDTM=$$DATE^INHUT($PIECE(^AUPNDWAF(DFN,0),U,11))
+10 ;Ins. Category
SET AGCAT="MCD"
+11 ;policy number
SET AGPOLN=$PIECE($GET(^AUPNMCD(AGIEN,0)),"^",3)
+12 SET AGMCDST=""
+13 ;MCD stateIHS/CMI/LAB - changed piece 2 to piece 3 for state code
IF $PIECE($GET(^AUPNMCD(AGIEN,0)),U,4)
SET AGMCDST=$PIECE($GET(^DIC(5,$PIECE($GET(^AUPNMCD(AGIEN,0)),U,4),0)),U,3)
+14 ;MCD plan
SET AGMCDPLN=$SELECT($PIECE($GET(^AUPNMCD(AGIEN,0)),U,10):$PIECE($GET(^AUTNINS($PIECE($GET(^AUPNMCD(AGIEN,0)),U,10),0)),U),1:"")
+15 ;Insurer name
SET AGINS=$SELECT($PIECE($GET(^AUPNMCD(AGIEN,0)),U,2):$PIECE($GET(^AUTNINS($PIECE($GET(^AUPNMCD(AGIEN,0)),U,2),0)),U),1:"")
+16 ;Insurer EIN
SET AGEIN=$SELECT($PIECE($GET(^AUPNMCD(AGIEN,0)),U,2):$PIECE($GET(^AUTNINS($PIECE($GET(^AUPNMCD(AGIEN,0)),U,2),0)),U,7),1:"")
+17 ;Policy Prefix/Suffix
SET AGPRE=""
+18 ;Date of last update
SET AGUPDT=$$DATE^INHUT($PIECE($GET(^AUPNMCD(AGIEN,0)),U,8))
+19 ;Policy Holder
SET AGPOL=$SELECT($PIECE($GET(^AUPNMCD(AGIEN,0)),U,9):$PIECE($GET(^DPT($PIECE($GET(^AUPNMCD(AGIEN,0)),U,9),0)),U),1:$PIECE($GET(^AUPNMCD(AGIEN,0)),U,5))
+20 ;Relationship
SET AGREL=$SELECT($PIECE($GET(^AUPNMCD(AGIEN,0)),U,6):$PIECE($GET(^AUTTRLSH($PIECE($GET(^AUPNMCD(AGIEN,0)),U,6),0)),U),1:"")
+21 SET AGD1=0
+22 FOR
SET AGD1=$ORDER(^AUPNMCD(AGIEN,11,AGD1))
IF AGD1=""
QUIT
Begin DoDot:2
+23 ;Coverage Type
SET AGCOV=$PIECE($GET(^AUPNMCD(AGIEN,11,AGD1,0)),U,3)
+24 ;Begin date
SET AGBEG=$$DATE^INHUT($PIECE($GET(^AUPNMCD(AGIEN,11,AGD1,0)),U,1))
+25 ;End date
SET AGEND=$$DATE^INHUT($PIECE($GET(^AUPNMCD(AGIEN,11,AGD1,0)),U,2))
+26 ;write the p5 record out to the array
DO P5REC
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
PI ; Create p5 record - private eligibility
+1 NEW AGLID,AGDTM,AGCAT,AGCOV,AGBEG,AGPOLN,AGMCDST,AGMCDPLN
+2 NEW AGINS,AGEND,AGEIN,AGPRE,AGPOL,AGREL,AGUPDT,AGCNT
+3 NEW AGPOLI,AGD1,AGPOL0
+4 SET AGCNT=1
+5 IF '$DATA(^AUPNPRVT(DFN))
QUIT
+6 SET AGD1=0
+7 FOR
SET AGD1=$ORDER(^AUPNPRVT(DFN,11,AGD1))
IF AGD1=""!(+AGD1=0)
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPRVT(DFN,11,AGD1,0),U)=""
QUIT
+9 SET (AGPOL,AGCOV,AGPOLN,AGDTM)=""
+10 ;local ID
SET AGLID=AGD1
+11 ;Date/Time of mods
IF $DATA(^AUPNDWAF(DFN))
SET AGDTM=$$DATE^INHUT($PIECE(^AUPNDWAF(DFN,0),U,11))
+12 ;Ins. Category
SET AGCAT="PVT"
+13 ;Begin dt
SET AGBEG=$$DATE^INHUT($PIECE($GET(^AUPNPRVT(DFN,11,AGD1,0)),U,6))
+14 ;Policy Hldr
SET AGPOLI=$PIECE($GET(^AUPNPRVT(DFN,11,AGD1,0)),U,8)
+15 IF $GET(AGPOLI)
Begin DoDot:2
+16 ;policy hldr file
SET AGPOL0=$GET(^AUPN3PPH(AGPOLI,0))
+17 SET AGPOL=$PIECE(AGPOL0,U)
+18 ;policy #
SET AGPOLN=$PIECE(AGPOL0,U,4)
+19 ;covg type pntr
SET AGCOV=$PIECE(AGPOL0,U,5)
+20 ;Covg Type
IF AGCOV'=""
SET AGCOV=$PIECE($GET(^AUTTPIC(AGCOV,0)),U)
End DoDot:2
+21 ;MCD state
SET AGMCDST=""
+22 ;MCD plan
SET AGMCDPLN=""
+23 ;Insurer name
SET AGINS=$PIECE($GET(^AUTNINS($PIECE($GET(^AUPNPRVT(DFN,11,AGD1,0)),U,1),0)),U)
+24 ;End date
SET AGEND=$$DATE^INHUT($PIECE($GET(^AUPNPRVT(DFN,11,AGD1,0)),U,7))
+25 ;Insurer EIN
SET AGEIN=$SELECT($PIECE($GET(^AUPNPRVT(DFN,11,AGD1,0)),U):$PIECE($GET(^AUTNINS($PIECE($GET(^AUPNPRVT(DFN,11,AGD1,0)),U),0)),U,7),1:"")
+26 ;Policy Prefix/Suffix
SET AGPRE=""
+27 ;Relationship
SET AGREL=$SELECT($PIECE($GET(^AUPNPRVT(DFN,11,AGD1,0)),U,5):$PIECE($GET(^AUTTRLSH($PIECE($GET(^AUPNPRVT(DFN,11,AGD1,0)),U,5),0)),U),1:"")
+28 ;Date of last update
SET AGUPDT=""
+29 ;write the p5 record to the array
DO P5REC
End DoDot:1
+30 QUIT
+31 ;
P5REC ; write the eligibility data to the p5 record in the array
+1 ; P5^Unique ID^Modification Date^Category^Coverage Type
+2 ; ^Begin Date^Policy Number^Medicaid State^Plan^Insurer
+3 ; ^End Date^Insurer EIN^Prefix/Suffix^Policy Holder
+4 ; ^Relationship^Last Updated
+5 SET AG(DFN,"P5",AGCAT_AGCNT_AGD1)="P5^"_AGUID_"^"_$GET(AGDTM)_"^"_AGCAT_"^"_AGCOV_"^"_AGBEG
+6 SET AG(DFN,"P5",AGCAT_AGCNT_AGD1)=$GET(AG(DFN,"P5",AGCAT_AGCNT_AGD1))_"^"_AGPOLN_"^"_AGMCDST_"^"_AGMCDPLN
+7 SET AG(DFN,"P5",AGCAT_AGCNT_AGD1)=$GET(AG(DFN,"P5",AGCAT_AGCNT_AGD1))_"^"_AGINS_"^"_AGEND_"^"_AGEIN
+8 SET AG(DFN,"P5",AGCAT_AGCNT_AGD1)=$GET(AG(DFN,"P5",AGCAT_AGCNT_AGD1))_"^"_AGPRE_"^"_AGPOL_"^"_AGREL_"^"_AGUPDT
+9 SET AGCNT=AGCNT+1
+10 QUIT
+11 ;
SAVE ; save the p1 and p2 array entries to the temp global
+1 NEW AGTMP,AGTMP1,AGTMP2
+2 SET AGTMP=""
+3 FOR AGTMP="P1","P2"
Begin DoDot:1
+4 SET ^BDWDWPX($JOB,DFN,AGTMP)=$GET(AG(DFN,AGTMP))
+5 KILL AG(DFN,AGTMP)
End DoDot:1
+6 QUIT
+7 ;
SAVE2 ; save the p3, p4 and p5 array entries (which may be multiples)
+1 ; to the temp global
+2 NEW AGTMP1,AGTMP2
+3 SET (AGTMP1,AGTMP2)=""
+4 FOR AGTMP1="P3","P4","P5"
Begin DoDot:1
+5 SET AGTMP2=0
+6 FOR
SET AGTMP2=$ORDER(AG(DFN,AGTMP1,AGTMP2))
IF AGTMP2=""
QUIT
Begin DoDot:2
+7 SET ^BDWDWPX($JOB,DFN,AGTMP1,AGTMP2)=$GET(AG(DFN,AGTMP1,AGTMP2))
End DoDot:2
End DoDot:1
+8 KILL AG(DFN)
+9 QUIT
