BDWBHL ; IHS/CMI/LAB - BDW Populate Various DW1 HL7 Segments ; [ 04/05/2007 2:56 PM ]
;;1.0;IHS DATA WAREHOUSE;**1,2,4**;JAN 23, 2006;Build 24
;
;this routine will set up all of the necessary variables to populate varios DW1 HL7 segments
;
;cmi/anch/maw 4/5/2007 added hard code of EXO in HDR
;
MAIN ;EP - this is the main routine driver
S INQUE=1
D ZVP,DG1,PR1,ZDN,ZIM,ZMD,HF,MSR,XAM,CPT,LAB,PED,SKT,IFC
Q
;
ZVP ;EP - populate the dw1 ZVP segment
K PRV
S BDWCNT=0
D PROV^BDWUTIL1(.PRV,BHLVIEN)
I $G(PRV(1))="" D
. S BDWCNT=1,INDA("ZVP",BDWCNT)="",INA("BDW1ZVP1",BDWCNT)=BDWCNT
S BDWDA=0 F S BDWDA=$O(PRV(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(PRV(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("ZVP",BDWCNT)=""
. S INA("BDW1ZVP1",BDWCNT)=BDWCNT
. S INA("BDW1ZVP2",BDWCNT)=$P(BDWDATA,U,3)
. S INA("BDW1ZVP3",BDWCNT)=$P(BDWDATA,U,4)
. S INA("BDW1ZVP4",BDWCNT)=$P(BDWDATA,U,6)
. S INA("BDW1ZVP5",BDWCNT)=$P(BDWDATA,U,7)
. S INA("BDW1ZVP6",BDWCNT)=$P(BDWDATA,U,8)
. S INA("BDW1ZVP7",BDWCNT)=$P(BDWDATA,U,5)
K BDWDA,BDWCNT,BDWDATA,PRV
Q
;
DG1 ;EP - populate the dw1 DG1 and ZDX segments
K POV
S BDWCNT=0
D POVS^BDWUTIL(.POV,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(POV(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(POV(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("DG1",BDWCNT)=""
. S INA("BDW1DG11",BDWCNT)=BDWCNT
. ;ihs/cmi/maw 06/10/2014 p5 ALPMR added provider narrative to DG1-3
. S INA("BDW1DG13",BDWCNT)=$P(BDWDATA,U)_U_U_$P(BDWDATA,U,10) ;ihs/cmi/maw 10/17/2012 patch 4 icd10
. S INA("BDW1ZDX1",BDWCNT,1)=$P(BDWDATA,U,12)
. S INA("BDW1ZDX4",BDWCNT,1)=$P(BDWDATA,U,2)
. S INA("BDW1ZDX6",BDWCNT,1)=$P(BDWDATA,U,3)_U_U_$P(BDWDATA,U,11) ;ihs/cmi/maw 10/17/2012 patch 4 icd10
. S INA("BDW1ZDX7",BDWCNT,1)=$P(BDWDATA,U,4)
S INDA("ZDX",1)=""
K BDWCNT,BDWDA,BDWDATA,POV
Q
;
PR1 ;EP - populate the dw1 PR1 and ZPR segments
K PRC
N PFLG
S BDWCNT=0
D PROC^BDWUTIL1(.PRC,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(PRC(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(PRC(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("PR1",BDWCNT)=""
. S INA("BDW1PR11",BDWCNT)=BDWCNT
. S INA("BDW1PR13",BDWCNT)=$P(BDWDATA,U)_U_U_$P(BDWDATA,U,10) ;ihs/cmi/maw 10/17/2012 patch 4 icd10
. S INA("BDW1PR15",BDWCNT)=$$DATE^INHUT($P(BDWDATA,U,2))
. S INA("BDW1PR111",BDWCNT)=$P(BDWDATA,U,4)
. S INA("BDW1ZPR5",BDWCNT,1)=$P(BDWDATA,U,3)
. S INA("BDW1ZPR8",BDWCNT,1)=$P(BDWDATA,U,6)
. S INA("BDW1ZPR9",BDWCNT,1)=$P(BDWDATA,U,5)
. S INA("BDW1ZPR10",BDWCNT,1)=$P(BDWDATA,U,7)
. S INA("BDW1ZPR11",BDWCNT,1)=$P(BDWDATA,U,8)
. S INA("BDW1ZPR12",BDWCNT,1)=$P(BDWDATA,U,9)
. S INA("BDW1ZPR13",BDWCNT,1)=$P(BDWDATA,U,13)
. S PFLG=$$CHKPFLG(BDWDATA)
. S INA("BDW1ZPR13",BDWCNT,1)=$TR(INA("BDW1ZPR13",BDWCNT,1),"!","^")
. I $G(PFLG) S INDA("ZPR",BDWCNT,1)="",INDA("ZPR",BDWCNT)=""
K BDWCNT,BDWDA,BDWDATA,PRC
Q
;
CHKPFLG(DATA) ;check to see if we do a ZPR segment
N I,FL
S FL=0
F I=3,5,6,7,8,9,13 D
. I $P(DATA,U,I)]"" S FL=1
Q FL
;
ZDN ;EP - populate the dw1 ZDN and ZDP segments
K DEN
S BDWCNT=0
D DENT^BDWUTIL(.DEN,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(DEN(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(DEN(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("ZDN",BDWCNT)=""
. S INDA("ZDP",BDWCNT)=""
. S INA("BDW1ZDN1",BDWCNT)=BDWCNT
. S INA("BDW1ZDN2",BDWCNT)=$P(BDWDATA,U)
. S INA("BDW1ZDN3",BDWCNT)=$P(BDWDATA,U,2)
. S INA("BDW1ZDN4",BDWCNT)=$P(BDWDATA,U,3)
. S INA("BDW1ZDN5",BDWCNT)=$P(BDWDATA,U,4)
. S INA("BDW1ZDN6",BDWCNT)=$P(BDWDATA,U,8)
. S INA("BDW1ZDN7",BDWCNT)=$P(BDWDATA,U,5)
. S INA("BDW1ZDP1",BDWCNT)=BDWCNT
. S INA("BDW1ZDP2",BDWCNT)=$P(BDWDATA,U,6)
. S INA("BDW1ZDP3",BDWCNT)=$P(BDWDATA,U,7)
K BDWCNT,BDWDA,BDWDATA,DEN
Q
;
ZIM ;EP - populate the dw1 ZIM segment
D ZIM^BDWBHL1
Q
;
ZMD ;EP - populate the dw1 ZMD segment
K MED
S BDWCNT=0
D MED^BDWUTIL1(.MED,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(MED(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(MED(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("ZMD",BDWCNT)=""
. S INA("BDW1ZMD1",BDWCNT)=BDWCNT
. S INA("BDW1ZMD2",BDWCNT)=$P(BDWDATA,U)
. S INA("BDW1ZMD3",BDWCNT)=$P(BDWDATA,U,3)
. S INA("BDW1ZMD4",BDWCNT)=$P(BDWDATA,U,4)
. S INA("BDW1ZMD5",BDWCNT)=$P(BDWDATA,U,2)
K BDWCNT,BDWDA,BDWDATA,MED
Q
;
HF ;EP - populate the dw1 OBX health factors segment
D HF^BDWBHL1
Q
;
MSR ;EP - populate the dw1 OBX measurement segment
D MSR^BDWBHL1
Q
;
XAM ;EP - populate the dw1 OBX exam segment
D XAM^BDWBHL1
Q
;
CPT ;-- populate the dw1 CPT exam segment
D CPT^BDWBHL1
Q
;
LAB ;-- populate the dw1 OBX lab segment
D LAB^BDWBHL1
Q
;
PED ;EP - populate the dw1 OBX patient education segment
D PED^BDWBHL1
Q
;
SKT ;EP - populate the dw1 OBX skin test segment
D SKT^BDWBHL1
Q
;
IFC ;EP - populate the dw1 OBX infant feeding choice segment
D IFC^BDWBHL1
Q
;
ZRC ;EP - generate ZRC segment
S INQUE=1
K INDA("ZRC")
S BDWCNT=0
S BDWDA=0 F S BDWDA=$O(^AUPNPAT(DFN,41,BDWDA)) Q:'BDWDA D
. S BDWCNT=BDWCNT+1
. S BDWDATA=$G(^AUPNPAT(DFN,41,BDWDA,0))
. I $P(BDWDATA,U)="" S BDWDATA=BDWDA_BDWDATA
. Q:$P($G(^AGFAC($P(BDWDATA,U),0)),U,21)'="Y"
. S INDA("ZRC",BDWCNT)=""
. S INA("BDW1ZRC6",BDWCNT)=$S($P(BDWDATA,U):$P($G(^AUTTLOC($P(BDWDATA,U),0)),U,10),1:"")
. S INA("BDW1ZRC7",BDWCNT)=$P(BDWDATA,U,2)
. S INA("BDW1ZRC8",BDWCNT)=$P(BDWDATA,U,5)
K BDWCNT,BDWDA
Q
;
ZRL ;EP - generate ZRL segment
K INDA("ZRL")
S BDWCNT=0
S BDWDA=0 F S BDWDA=$O(^DPT(DFN,.01,BDWDA)) Q:'BDWDA D
. S BDWDATA=$P($G(^DPT(DFN,.01,BDWDA,0)),U)
. S BDWCNT=BDWCNT+1
. S BDWALNM=$P(BDWDATA,",")
. S BDWAFNM=$P($P(BDWDATA,",",2)," ")
. S BDWAMI=$P($P(BDWDATA,",",2)," ",2)
. S BDWASTR=BDWALNM_U_BDWAFNM_U_BDWAMI
. S INDA("ZRL",BDWCNT)=""
. S INA("BDW1ZRL6",BDWCNT)=BDWASTR
K BDWDA,BDWCNT,BDWALNM,BDWAFNM,BDWAMI,BDWASTR
Q
;
HDR ;-- generate the header record
S INQUE=1
NEW BDWDEST S BDWDEST=$O(^INRHD("B","HL IHS DW1 IE",0)) K ^INLHDEST(BDWDEST) ;IHS/CMI/LAB - kill at beginning of each batch
;cmi/anch/maw 3/7/2007 added the following 3 lines for common header vars
S INA("BDW1ZHS4")="HL7"
I $G(INA("FILE")) S INA("BDW1ZHS5")="EXO^"_$$GET1^DIQ(INA("FILE"),INDA,.23) ;cmi/anch/maw 3/7/2007 for desc of option ran
S INA("BDW1ZHS6")="2.4" ;change this when version changes
I INA("FILE")=90215 D Q
. S INA("BDW1BHS7")=$$DATE^INHUT($$GET1^DIQ(90215,INDA,.01),1)
. S INA("BDW1BHS9")=INDA
. S INA("BDW1BHS11")=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)_INDA
. S (INA("BDW1ZHS1"),INA("BDW1ZHS2"))=$$DATE^INHUT($$GET1^DIQ(90215,INDA,.01,"I"))
. S INA("BDW1ZHS3")=INDA
I INA("FILE")=90213 D Q
. S INA("BDW1BHS7")=$$DATE^INHUT($$GET1^DIQ(90213,INDA,.01,"I"),1)
. S INA("BDW1BHS9")=INDA
. S INA("BDW1BHS11")=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)_INDA
. S INA("BDW1ZHS1")=$$DATE^INHUT($$GET1^DIQ(90213,INDA,.01,"I"))
. S INA("BDW1ZHS2")=$$DATE^INHUT($$GET1^DIQ(90213,INDA,.02,"I"))
. S INA("BDW1ZHS3")=INDA
. S INA("BDW1ZHS3")=INDA
I INA("FILE")=90214 D Q
. S INA("BDW1BHS7")=$$DATE^INHUT($$GET1^DIQ(90214,INDA,.03,"I"),1)
. S INA("BDW1BHS9")=INDA
. S INA("BDW1BHS11")=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)_INDA
. S INA("BDW1ZHS1")=$$DATE^INHUT($$GET1^DIQ(90214,INDA,.01,"I"))
. S INA("BDW1ZHS2")=$$DATE^INHUT($$GET1^DIQ(90214,INDA,.02,"I"))
. S INA("BDW1ZHS3")=INDA
Q
;
TRL ;-- generate the trailer record
S INQUE=1
I INA("FILE")=90214 D Q
. S INA("BDW1ZTS1")=$$GET1^DIQ(90214,INDA,.18)
. S INA("BDW1ZTS2")=$$GET1^DIQ(90214,INDA,.05)
. S INA("BDW1ZTS3")=(INA("BDW1ZTS2")-$$GET1^DIQ(90214,INDA,3101))
. S INA("BDW1ZTS4")=$$GET1^DIQ(90214,INDA,3101)
. S INA("BDW1ZTS5")=$$GET1^DIQ(90214,INDA,.06)+2
. S INA("BDW1BTS1")=$$GET1^DIQ(90214,INDA,.06)
. S INA("BDW1BTS2")=$P($G(^DIC(4,$P(^AUTTSITE(1,0),U),0)),U)
. S INA("BDW1BTS3")=1
. D HFS ;task to host file
I INA("FILE")=90213 D Q
. S INA("BDW1ZTS1")=$$GET1^DIQ(90213,INDA,.18)
. S INA("BDW1ZTS2")=$$GET1^DIQ(90213,INDA,.05)
. S INA("BDW1ZTS3")=(INA("BDW1ZTS2")-$$GET1^DIQ(90213,INDA,3101))
. S INA("BDW1ZTS4")=$$GET1^DIQ(90213,INDA,3101)
. S INA("BDW1ZTS5")=$$GET1^DIQ(90213,INDA,.06)+2
. S INA("BDW1BTS1")=$$GET1^DIQ(90213,INDA,.06)
. S INA("BDW1BTS2")=$P($G(^DIC(4,$P(^AUTTSITE(1,0),U),0)),U)
. S INA("BDW1BTS3")=1
. N BDWDA,BDWC S BDWC=0
. S BDWDA=0 F S BDWDA=$O(^BDWXLOG(INDA,99,BDWDA)) Q:'BDWDA D
.. S BDWC=BDWC+1
.. S INDA("NTE",BDWC)=""
.. S INA("BDW1NTE3",BDWC)=$G(^BDWXLOG(INDA,99,BDWDA,0))
. D HFS ;task to host file
I INA("FILE")=90215 D Q
. S INA("BDW1ZTS5")=$$GET1^DIQ(90215,INDA,.05)+2
. S INA("BDW1BTS1")=$$GET1^DIQ(90215,INDA,.05)
. S INA("BDW1BTS2")=$P($G(^DIC(4,$P(^AUTTSITE(1,0),U),0)),U)
. S INA("BDW1BTS3")=1
. D HFS ;task to host file
Q
;
BQ(BHLP) ;-- return blood quantum
K BHLPVAL
N BHLX,BHLY
S (BHLX,BHLY)=""
S BHLPVAL=""
S BHLPVAL=$P($G(^AUPNPAT(BHLP,11)),U,10)
I +BHLPVAL>0 S BHLX=$P(BHLPVAL,"/",1)/$P(BHLPVAL,"/",2)
S BHLY=$S((BHLPVAL="FULL"!(BHLX=1)):1,BHLPVAL="NONE":5,BHLPVAL="UNSPECIFIED":6,BHLPVAL="UNKNOWN":7,+BHLPVAL'>0:7,1:BHLY)
I BHLY]"" Q $G(BHLY)
S BHLY=$S(BHLX'<.5:2,BHLX'<.25:3,BHLX'<.125:4,BHLX<.125:4,1:BHLY)
Q $G(BHLY)
;
FLG(BDWSEG,BDWIEN) ;EP -- return status flag based on segment
I $G(INA("BACKLOAD")) Q "A"
NEW G,X
S G=0 F X=1:1:5 I $P($G(^AUPNPAT(BDWIEN,4)),U,X)]"" S G=1
I 'G Q "A"
N BDWFLG
S BDWCD="N",BDWFLG=0
I '$G(^AUPNPAT(BDWIEN,4)) S BDWFLG=1
I BDWSEG="ZRB" D Q $G(BDWCD)
. I $P($G(^AUPNPAT(BDWIEN,4)),U)="" S BDWFLG=1
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,2)]"",BDWFLG=1 S BDWCD="A"
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,2)]"",BDWFLG=0 S BDWCD="Y"
I BDWSEG="ZRL" D Q $G(BDWCD)
. I $P($G(^AUPNPAT(BDWIEN,4)),U)="",$P($G(^AUPNPAT(BDWIEN,4)),U,3)="" S BDWFLG=1
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,6)]"",BDWFLG=1 S BDWCD="A"
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,6)]"",BDWFLG=0 S BDWCD="Y"
I BDWSEG="ZRC" D Q $G(BDWCD)
. I $P($G(^AUPNPAT(BDWIEN,4)),U)="",$P($G(^AUPNPAT(BDWIEN,4)),U,4)="" S BDWFLG=1
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,8)]"",BDWFLG=1 S BDWCD="A"
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,8)]"",BDWFLG=0 S BDWCD="Y"
I BDWSEG="ZRD" D Q $G(BDWCD)
. I $P($G(^AUPNPAT(BDWIEN,4)),U)="",$P($G(^AUPNPAT(BDWIEN,4)),U,2)="" S BDWFLG=1
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,4)]"",BDWFLG=1 S BDWCD="A"
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,4)]"",BDWFLG=0 S BDWCD="Y"
I BDWSEG="ZIN" D Q $G(BDWCD)
. I $P($G(^AUPNPAT(BDWIEN,4)),U)="",$P($G(^AUPNPAT(BDWIEN,4)),U,5)="" S BDWFLG=1
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,11)]"",BDWFLG=1 S BDWCD="A"
. I $P($G(^AUPNDWAF(BDWIEN,0)),U,11)]"",BDWFLG=0 S BDWCD="Y"
Q BDWCD
;
GETDIR ;get export directory
S BDWHDIR=$S($P($G(^AUTTSITE(1,1)),U,2)]"":$P(^AUTTSITE(1,1),U,2),1:$G(^XTV(8989.3,1,"DEV")))
I $G(BDWHDIR)="" S BDWHDIR="/usr/spool/uucppublic/"
Q
HFSA(DEST,BHLHDIR,BHLHFNM) ;EP - export from this destination
S Y=$$OPEN^%ZISH(BHLHDIR,BHLHFNM,"W")
Q:Y
S BHLX=0 F S BHLX=$O(^BDWTMP(DEST,BHLX)) Q:'BHLX D
. S BHLU=$O(^INTHU("AT",BHLX,0))
. Q:'BHLU ;cmi/maw 6/28/2004 added for null node
. D LPINTHU(BHLU)
D ^%ZISC
;*****LORI PUT SENDTO HERE WHEN READY
I $P($G(^AUTTSITE(1,0)),U,21)=1 S BDWSLASH="/" I 1
E S BDWSLASH="\"
S BDWNOSLA=1 I $E(BDWHDIR,$L(BDWHDIR))="/"!($E(BDWHDIR,$L(BDWHDIR))="\") S BDWNOSLA=0
S BDWPAFN=BHLHDIR_$S(BDWNOSLA:BDWSLASH,1:"")_BHLHFNM
;now loop through and delete them
S BHLX=0 F S BHLX=$O(^BDWTMP(DEST,BHLX)) Q:'BHLX D
.S BHLU=$O(^INTHU("AT",BHLX,0))
.Q:'BHLU ;cmi/maw 6/28/2004 added for null node
.S DA=BHLU,DIE="^INTHU(",DR=".03////C" D ^DIE K DIE,DA,DR
.Q
K ^BDWTMP(DEST)
D AUTOSEND^BDWBHL1
FTP ;
;PUT FTP TO DW MACHINE HERE
BULL ;now send mailman message to user who queued the job
D BULL^BDWBHL1
Q
;
LPINTHU(BHLUIEN) ;EP - loop through UIF and set to file
S BHLUDA=0 F S BHLUDA=$O(^INTHU(BHLUIEN,3,BHLUDA)) Q:'BHLUDA D
. U IO W $P($G(^INTHU(BHLUIEN,3,BHLUDA,0)),"|CR|"),!
Q
;
DELAY(IDA,IA) ;-- determine the delay based on records
I IA=90215 Q 60
N BDWRCNT
S BDWRCNT=$$GET1^DIQ(IA,IDA,.06)
I BDWRCNT>10000 Q 30
I BDWRCNT>40000 Q 60
I BDWRCNT>60000 Q 90
Q 15
;
HFS ;-- task the file to the host system
NEW BDWUSER,BDWDESC,F,BDWPFL,BDWPIEN
S BDWUSER=$$VALI^XBDIQ1(INA("FILE"),INDA,8801)
S BDWPFL=$G(INA("FILE")) ;maw added 4/7/2005 for ZTS-6
S BDWPIEN=$G(INDA) ;maw added 4/7/2005 for ZTS-6
I INA("FILE")=90213 S BDWDESC="Data Warehouse Export for: "_$$VAL^XBDIQ1(90213,INDA,.01)_" to "_$$VAL^XBDIQ1(90213,INDA,.02)
I INA("FILE")=90214 S BDWDESC="Data Warehouse Visit Backload for: "_$$VAL^XBDIQ1(90214,INDA,.01)_" to "_$$VAL^XBDIQ1(90214,INDA,.02)
I INA("FILE")=90215 S BDWDESC="Full Registration Backload to the Data Warehouse"
S ZTRTN="HFS1^BDWBHL"
S ZTIO="",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,$$DELAY(INDA,INA("FILE"))),ZTDESC="DW DATA WAREHOUSE HFS CREATION" S ZTSAVE("BDW*")=""
D ^%ZTLOAD
Q
HFS1 ;EP - called from taskman
N BDWDEST,BDWHDIR,BDWHFNM
S BDWDEST=$O(^INRHD("B","HL IHS DW1 IE",0))
Q:'BDWDEST
K ^INLHDEST(BDWDEST) ;kill off inlhdest
N BDWQCNT
S BDWQCNT=$$QCNT(BDWDEST) ;4/7/05 maw quick count of records to put in ZTS-6
D SETZTS6(BDWPFL,BDWPIEN,BDWQCNT)
;before saving off, reset AUPNDWAF and 4 node in AUPNPAT
I BDWPFL=90213,'$P($G(^BDWXLOG(BDWPIEN,0)),U,22) D RST4AF^BDWRDR(BDWPIEN)
I BDWPFL=90213,$P($G(^BDWXLOG(BDWPIEN,0)),U,22) D RESETFLG^BDWBHL1(BDWDEST,BDWPFL,BDWPIEN)
;
D GETDIR
Q:BDWHDIR=""
N BDWASU
S BDWASU=$P($G(^AUTTLOC($P($G(^AUTTSITE(1,0)),U),0)),U,10)
D NOW^%DTC
N BDWDTS
S BDWDTS=$TR(%,".")
S BDWHFNM=BDWASU_BDWDTS_".BDW"
D HFSA(BDWDEST,BDWHDIR,BDWHFNM)
S ZTREQ="@"
Q
;
QCNT(DEST) ;-- let's loop through and get a quick count of records
N BDWDA,BDWCNT
S BDWCNT=0
S BDWDA=0 F S BDWDA=$O(^BDWTMP(DEST,BDWDA)) Q:'BDWDA D
. Q:'$O(^INTHU("AT",BDWDA,0))
. ;cmi/anch/maw 12/7/2007 filter out A40's?
. S BDWCNT=BDWCNT+1
Q +$G(BDWCNT)
;
SETZTS6(PFL,PIEN,QCNT) ;-- set ZTS-6 with actual counts
N TRL
I PFL=90213 D
. S TRL=$P($G(^BDWXLOG(PIEN,0)),U,14)
. Q:'TRL
. S TRL=$O(^INTHU("AT",TRL,0))
I PFL=90214 D
. S TRL=$P($G(^BDWBLOG(PIEN,0)),U,14)
. Q:'TRL
. S TRL=$O(^INTHU("AT",TRL,0))
I PFL=90215 D
. S TRL=$P($G(^BDWRBLOG(PIEN,0)),U,8)
. Q:'TRL
. S TRL=$O(^INTHU("AT",TRL,0))
Q:'$G(TRL)
N LDA
S LDA=0 F S LDA=$O(^INTHU(TRL,3,LDA)) Q:'LDA D
. I $E($G(^INTHU(TRL,3,LDA,0)),1,3)="ZTS" D
.. S $P(^INTHU(TRL,3,LDA,0),"|",7)=QCNT_"|CR"
Q
BDWBHL ; IHS/CMI/LAB - BDW Populate Various DW1 HL7 Segments ; [ 04/05/2007 2:56 PM ]
+1 ;;1.0;IHS DATA WAREHOUSE;**1,2,4**;JAN 23, 2006;Build 24
+2 ;
+3 ;this routine will set up all of the necessary variables to populate varios DW1 HL7 segments
+4 ;
+5 ;cmi/anch/maw 4/5/2007 added hard code of EXO in HDR
+6 ;
MAIN ;EP - this is the main routine driver
+1 SET INQUE=1
+2 DO ZVP
DO DG1
DO PR1
DO ZDN
DO ZIM
DO ZMD
DO HF
DO MSR
DO XAM
DO CPT
DO LAB
DO PED
DO SKT
DO IFC
+3 QUIT
+4 ;
ZVP ;EP - populate the dw1 ZVP segment
+1 KILL PRV
+2 SET BDWCNT=0
+3 DO PROV^BDWUTIL1(.PRV,BHLVIEN)
+4 IF $GET(PRV(1))=""
Begin DoDot:1
+5 SET BDWCNT=1
SET INDA("ZVP",BDWCNT)=""
SET INA("BDW1ZVP1",BDWCNT)=BDWCNT
End DoDot:1
+6 SET BDWDA=0
FOR
SET BDWDA=$ORDER(PRV(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+7 SET BDWDATA=$GET(PRV(BDWDA))
+8 SET BDWCNT=BDWCNT+1
+9 SET INDA("ZVP",BDWCNT)=""
+10 SET INA("BDW1ZVP1",BDWCNT)=BDWCNT
+11 SET INA("BDW1ZVP2",BDWCNT)=$PIECE(BDWDATA,U,3)
+12 SET INA("BDW1ZVP3",BDWCNT)=$PIECE(BDWDATA,U,4)
+13 SET INA("BDW1ZVP4",BDWCNT)=$PIECE(BDWDATA,U,6)
+14 SET INA("BDW1ZVP5",BDWCNT)=$PIECE(BDWDATA,U,7)
+15 SET INA("BDW1ZVP6",BDWCNT)=$PIECE(BDWDATA,U,8)
+16 SET INA("BDW1ZVP7",BDWCNT)=$PIECE(BDWDATA,U,5)
End DoDot:1
+17 KILL BDWDA,BDWCNT,BDWDATA,PRV
+18 QUIT
+19 ;
DG1 ;EP - populate the dw1 DG1 and ZDX segments
+1 KILL POV
+2 SET BDWCNT=0
+3 DO POVS^BDWUTIL(.POV,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(POV(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(POV(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("DG1",BDWCNT)=""
+8 SET INA("BDW1DG11",BDWCNT)=BDWCNT
+9 ;ihs/cmi/maw 06/10/2014 p5 ALPMR added provider narrative to DG1-3
+10 ;ihs/cmi/maw 10/17/2012 patch 4 icd10
SET INA("BDW1DG13",BDWCNT)=$PIECE(BDWDATA,U)_U_U_$PIECE(BDWDATA,U,10)
+11 SET INA("BDW1ZDX1",BDWCNT,1)=$PIECE(BDWDATA,U,12)
+12 SET INA("BDW1ZDX4",BDWCNT,1)=$PIECE(BDWDATA,U,2)
+13 ;ihs/cmi/maw 10/17/2012 patch 4 icd10
SET INA("BDW1ZDX6",BDWCNT,1)=$PIECE(BDWDATA,U,3)_U_U_$PIECE(BDWDATA,U,11)
+14 SET INA("BDW1ZDX7",BDWCNT,1)=$PIECE(BDWDATA,U,4)
End DoDot:1
+15 SET INDA("ZDX",1)=""
+16 KILL BDWCNT,BDWDA,BDWDATA,POV
+17 QUIT
+18 ;
PR1 ;EP - populate the dw1 PR1 and ZPR segments
+1 KILL PRC
+2 NEW PFLG
+3 SET BDWCNT=0
+4 DO PROC^BDWUTIL1(.PRC,BHLVIEN)
+5 SET BDWDA=0
FOR
SET BDWDA=$ORDER(PRC(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+6 SET BDWDATA=$GET(PRC(BDWDA))
+7 SET BDWCNT=BDWCNT+1
+8 SET INDA("PR1",BDWCNT)=""
+9 SET INA("BDW1PR11",BDWCNT)=BDWCNT
+10 ;ihs/cmi/maw 10/17/2012 patch 4 icd10
SET INA("BDW1PR13",BDWCNT)=$PIECE(BDWDATA,U)_U_U_$PIECE(BDWDATA,U,10)
+11 SET INA("BDW1PR15",BDWCNT)=$$DATE^INHUT($PIECE(BDWDATA,U,2))
+12 SET INA("BDW1PR111",BDWCNT)=$PIECE(BDWDATA,U,4)
+13 SET INA("BDW1ZPR5",BDWCNT,1)=$PIECE(BDWDATA,U,3)
+14 SET INA("BDW1ZPR8",BDWCNT,1)=$PIECE(BDWDATA,U,6)
+15 SET INA("BDW1ZPR9",BDWCNT,1)=$PIECE(BDWDATA,U,5)
+16 SET INA("BDW1ZPR10",BDWCNT,1)=$PIECE(BDWDATA,U,7)
+17 SET INA("BDW1ZPR11",BDWCNT,1)=$PIECE(BDWDATA,U,8)
+18 SET INA("BDW1ZPR12",BDWCNT,1)=$PIECE(BDWDATA,U,9)
+19 SET INA("BDW1ZPR13",BDWCNT,1)=$PIECE(BDWDATA,U,13)
+20 SET PFLG=$$CHKPFLG(BDWDATA)
+21 SET INA("BDW1ZPR13",BDWCNT,1)=$TRANSLATE(INA("BDW1ZPR13",BDWCNT,1),"!","^")
+22 IF $GET(PFLG)
SET INDA("ZPR",BDWCNT,1)=""
SET INDA("ZPR",BDWCNT)=""
End DoDot:1
+23 KILL BDWCNT,BDWDA,BDWDATA,PRC
+24 QUIT
+25 ;
CHKPFLG(DATA) ;check to see if we do a ZPR segment
+1 NEW I,FL
+2 SET FL=0
+3 FOR I=3,5,6,7,8,9,13
Begin DoDot:1
+4 IF $PIECE(DATA,U,I)]""
SET FL=1
End DoDot:1
+5 QUIT FL
+6 ;
ZDN ;EP - populate the dw1 ZDN and ZDP segments
+1 KILL DEN
+2 SET BDWCNT=0
+3 DO DENT^BDWUTIL(.DEN,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(DEN(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(DEN(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("ZDN",BDWCNT)=""
+8 SET INDA("ZDP",BDWCNT)=""
+9 SET INA("BDW1ZDN1",BDWCNT)=BDWCNT
+10 SET INA("BDW1ZDN2",BDWCNT)=$PIECE(BDWDATA,U)
+11 SET INA("BDW1ZDN3",BDWCNT)=$PIECE(BDWDATA,U,2)
+12 SET INA("BDW1ZDN4",BDWCNT)=$PIECE(BDWDATA,U,3)
+13 SET INA("BDW1ZDN5",BDWCNT)=$PIECE(BDWDATA,U,4)
+14 SET INA("BDW1ZDN6",BDWCNT)=$PIECE(BDWDATA,U,8)
+15 SET INA("BDW1ZDN7",BDWCNT)=$PIECE(BDWDATA,U,5)
+16 SET INA("BDW1ZDP1",BDWCNT)=BDWCNT
+17 SET INA("BDW1ZDP2",BDWCNT)=$PIECE(BDWDATA,U,6)
+18 SET INA("BDW1ZDP3",BDWCNT)=$PIECE(BDWDATA,U,7)
End DoDot:1
+19 KILL BDWCNT,BDWDA,BDWDATA,DEN
+20 QUIT
+21 ;
ZIM ;EP - populate the dw1 ZIM segment
+1 DO ZIM^BDWBHL1
+2 QUIT
+3 ;
ZMD ;EP - populate the dw1 ZMD segment
+1 KILL MED
+2 SET BDWCNT=0
+3 DO MED^BDWUTIL1(.MED,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(MED(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(MED(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("ZMD",BDWCNT)=""
+8 SET INA("BDW1ZMD1",BDWCNT)=BDWCNT
+9 SET INA("BDW1ZMD2",BDWCNT)=$PIECE(BDWDATA,U)
+10 SET INA("BDW1ZMD3",BDWCNT)=$PIECE(BDWDATA,U,3)
+11 SET INA("BDW1ZMD4",BDWCNT)=$PIECE(BDWDATA,U,4)
+12 SET INA("BDW1ZMD5",BDWCNT)=$PIECE(BDWDATA,U,2)
End DoDot:1
+13 KILL BDWCNT,BDWDA,BDWDATA,MED
+14 QUIT
+15 ;
HF ;EP - populate the dw1 OBX health factors segment
+1 DO HF^BDWBHL1
+2 QUIT
+3 ;
MSR ;EP - populate the dw1 OBX measurement segment
+1 DO MSR^BDWBHL1
+2 QUIT
+3 ;
XAM ;EP - populate the dw1 OBX exam segment
+1 DO XAM^BDWBHL1
+2 QUIT
+3 ;
CPT ;-- populate the dw1 CPT exam segment
+1 DO CPT^BDWBHL1
+2 QUIT
+3 ;
LAB ;-- populate the dw1 OBX lab segment
+1 DO LAB^BDWBHL1
+2 QUIT
+3 ;
PED ;EP - populate the dw1 OBX patient education segment
+1 DO PED^BDWBHL1
+2 QUIT
+3 ;
SKT ;EP - populate the dw1 OBX skin test segment
+1 DO SKT^BDWBHL1
+2 QUIT
+3 ;
IFC ;EP - populate the dw1 OBX infant feeding choice segment
+1 DO IFC^BDWBHL1
+2 QUIT
+3 ;
ZRC ;EP - generate ZRC segment
+1 SET INQUE=1
+2 KILL INDA("ZRC")
+3 SET BDWCNT=0
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(^AUPNPAT(DFN,41,BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWCNT=BDWCNT+1
+6 SET BDWDATA=$GET(^AUPNPAT(DFN,41,BDWDA,0))
+7 IF $PIECE(BDWDATA,U)=""
SET BDWDATA=BDWDA_BDWDATA
+8 IF $PIECE($GET(^AGFAC($PIECE(BDWDATA,U),0)),U,21)'="Y"
QUIT
+9 SET INDA("ZRC",BDWCNT)=""
+10 SET INA("BDW1ZRC6",BDWCNT)=$SELECT($PIECE(BDWDATA,U):$PIECE($GET(^AUTTLOC($PIECE(BDWDATA,U),0)),U,10),1:"")
+11 SET INA("BDW1ZRC7",BDWCNT)=$PIECE(BDWDATA,U,2)
+12 SET INA("BDW1ZRC8",BDWCNT)=$PIECE(BDWDATA,U,5)
End DoDot:1
+13 KILL BDWCNT,BDWDA
+14 QUIT
+15 ;
ZRL ;EP - generate ZRL segment
+1 KILL INDA("ZRL")
+2 SET BDWCNT=0
+3 SET BDWDA=0
FOR
SET BDWDA=$ORDER(^DPT(DFN,.01,BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+4 SET BDWDATA=$PIECE($GET(^DPT(DFN,.01,BDWDA,0)),U)
+5 SET BDWCNT=BDWCNT+1
+6 SET BDWALNM=$PIECE(BDWDATA,",")
+7 SET BDWAFNM=$PIECE($PIECE(BDWDATA,",",2)," ")
+8 SET BDWAMI=$PIECE($PIECE(BDWDATA,",",2)," ",2)
+9 SET BDWASTR=BDWALNM_U_BDWAFNM_U_BDWAMI
+10 SET INDA("ZRL",BDWCNT)=""
+11 SET INA("BDW1ZRL6",BDWCNT)=BDWASTR
End DoDot:1
+12 KILL BDWDA,BDWCNT,BDWALNM,BDWAFNM,BDWAMI,BDWASTR
+13 QUIT
+14 ;
HDR ;-- generate the header record
+1 SET INQUE=1
+2 ;IHS/CMI/LAB - kill at beginning of each batch
NEW BDWDEST
SET BDWDEST=$ORDER(^INRHD("B","HL IHS DW1 IE",0))
KILL ^INLHDEST(BDWDEST)
+3 ;cmi/anch/maw 3/7/2007 added the following 3 lines for common header vars
+4 SET INA("BDW1ZHS4")="HL7"
+5 ;cmi/anch/maw 3/7/2007 for desc of option ran
IF $GET(INA("FILE"))
SET INA("BDW1ZHS5")="EXO^"_$$GET1^DIQ(INA("FILE"),INDA,.23)
+6 ;change this when version changes
SET INA("BDW1ZHS6")="2.4"
+7 IF INA("FILE")=90215
Begin DoDot:1
+8 SET INA("BDW1BHS7")=$$DATE^INHUT($$GET1^DIQ(90215,INDA,.01),1)
+9 SET INA("BDW1BHS9")=INDA
+10 SET INA("BDW1BHS11")=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)_INDA
+11 SET (INA("BDW1ZHS1"),INA("BDW1ZHS2"))=$$DATE^INHUT($$GET1^DIQ(90215,INDA,.01,"I"))
+12 SET INA("BDW1ZHS3")=INDA
End DoDot:1
QUIT
+13 IF INA("FILE")=90213
Begin DoDot:1
+14 SET INA("BDW1BHS7")=$$DATE^INHUT($$GET1^DIQ(90213,INDA,.01,"I"),1)
+15 SET INA("BDW1BHS9")=INDA
+16 SET INA("BDW1BHS11")=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)_INDA
+17 SET INA("BDW1ZHS1")=$$DATE^INHUT($$GET1^DIQ(90213,INDA,.01,"I"))
+18 SET INA("BDW1ZHS2")=$$DATE^INHUT($$GET1^DIQ(90213,INDA,.02,"I"))
+19 SET INA("BDW1ZHS3")=INDA
+20 SET INA("BDW1ZHS3")=INDA
End DoDot:1
QUIT
+21 IF INA("FILE")=90214
Begin DoDot:1
+22 SET INA("BDW1BHS7")=$$DATE^INHUT($$GET1^DIQ(90214,INDA,.03,"I"),1)
+23 SET INA("BDW1BHS9")=INDA
+24 SET INA("BDW1BHS11")=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)_INDA
+25 SET INA("BDW1ZHS1")=$$DATE^INHUT($$GET1^DIQ(90214,INDA,.01,"I"))
+26 SET INA("BDW1ZHS2")=$$DATE^INHUT($$GET1^DIQ(90214,INDA,.02,"I"))
+27 SET INA("BDW1ZHS3")=INDA
End DoDot:1
QUIT
+28 QUIT
+29 ;
TRL ;-- generate the trailer record
+1 SET INQUE=1
+2 IF INA("FILE")=90214
Begin DoDot:1
+3 SET INA("BDW1ZTS1")=$$GET1^DIQ(90214,INDA,.18)
+4 SET INA("BDW1ZTS2")=$$GET1^DIQ(90214,INDA,.05)
+5 SET INA("BDW1ZTS3")=(INA("BDW1ZTS2")-$$GET1^DIQ(90214,INDA,3101))
+6 SET INA("BDW1ZTS4")=$$GET1^DIQ(90214,INDA,3101)
+7 SET INA("BDW1ZTS5")=$$GET1^DIQ(90214,INDA,.06)+2
+8 SET INA("BDW1BTS1")=$$GET1^DIQ(90214,INDA,.06)
+9 SET INA("BDW1BTS2")=$PIECE($GET(^DIC(4,$PIECE(^AUTTSITE(1,0),U),0)),U)
+10 SET INA("BDW1BTS3")=1
+11 ;task to host file
DO HFS
End DoDot:1
QUIT
+12 IF INA("FILE")=90213
Begin DoDot:1
+13 SET INA("BDW1ZTS1")=$$GET1^DIQ(90213,INDA,.18)
+14 SET INA("BDW1ZTS2")=$$GET1^DIQ(90213,INDA,.05)
+15 SET INA("BDW1ZTS3")=(INA("BDW1ZTS2")-$$GET1^DIQ(90213,INDA,3101))
+16 SET INA("BDW1ZTS4")=$$GET1^DIQ(90213,INDA,3101)
+17 SET INA("BDW1ZTS5")=$$GET1^DIQ(90213,INDA,.06)+2
+18 SET INA("BDW1BTS1")=$$GET1^DIQ(90213,INDA,.06)
+19 SET INA("BDW1BTS2")=$PIECE($GET(^DIC(4,$PIECE(^AUTTSITE(1,0),U),0)),U)
+20 SET INA("BDW1BTS3")=1
+21 NEW BDWDA,BDWC
SET BDWC=0
+22 SET BDWDA=0
FOR
SET BDWDA=$ORDER(^BDWXLOG(INDA,99,BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:2
+23 SET BDWC=BDWC+1
+24 SET INDA("NTE",BDWC)=""
+25 SET INA("BDW1NTE3",BDWC)=$GET(^BDWXLOG(INDA,99,BDWDA,0))
End DoDot:2
+26 ;task to host file
DO HFS
End DoDot:1
QUIT
+27 IF INA("FILE")=90215
Begin DoDot:1
+28 SET INA("BDW1ZTS5")=$$GET1^DIQ(90215,INDA,.05)+2
+29 SET INA("BDW1BTS1")=$$GET1^DIQ(90215,INDA,.05)
+30 SET INA("BDW1BTS2")=$PIECE($GET(^DIC(4,$PIECE(^AUTTSITE(1,0),U),0)),U)
+31 SET INA("BDW1BTS3")=1
+32 ;task to host file
DO HFS
End DoDot:1
QUIT
+33 QUIT
+34 ;
BQ(BHLP) ;-- return blood quantum
+1 KILL BHLPVAL
+2 NEW BHLX,BHLY
+3 SET (BHLX,BHLY)=""
+4 SET BHLPVAL=""
+5 SET BHLPVAL=$PIECE($GET(^AUPNPAT(BHLP,11)),U,10)
+6 IF +BHLPVAL>0
SET BHLX=$PIECE(BHLPVAL,"/",1)/$PIECE(BHLPVAL,"/",2)
+7 SET BHLY=$SELECT((BHLPVAL="FULL"!(BHLX=1)):1,BHLPVAL="NONE":5,BHLPVAL="UNSPECIFIED":6,BHLPVAL="UNKNOWN":7,+BHLPVAL'>0:7,1:BHLY)
+8 IF BHLY]""
QUIT $GET(BHLY)
+9 SET BHLY=$SELECT(BHLX'<.5:2,BHLX'<.25:3,BHLX'<.125:4,BHLX<.125:4,1:BHLY)
+10 QUIT $GET(BHLY)
+11 ;
FLG(BDWSEG,BDWIEN) ;EP -- return status flag based on segment
+1 IF $GET(INA("BACKLOAD"))
QUIT "A"
+2 NEW G,X
+3 SET G=0
FOR X=1:1:5
IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U,X)]""
SET G=1
+4 IF 'G
QUIT "A"
+5 NEW BDWFLG
+6 SET BDWCD="N"
SET BDWFLG=0
+7 IF '$GET(^AUPNPAT(BDWIEN,4))
SET BDWFLG=1
+8 IF BDWSEG="ZRB"
Begin DoDot:1
+9 IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U)=""
SET BDWFLG=1
+10 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,2)]""
IF BDWFLG=1
SET BDWCD="A"
+11 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,2)]""
IF BDWFLG=0
SET BDWCD="Y"
End DoDot:1
QUIT $GET(BDWCD)
+12 IF BDWSEG="ZRL"
Begin DoDot:1
+13 IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U)=""
IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U,3)=""
SET BDWFLG=1
+14 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,6)]""
IF BDWFLG=1
SET BDWCD="A"
+15 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,6)]""
IF BDWFLG=0
SET BDWCD="Y"
End DoDot:1
QUIT $GET(BDWCD)
+16 IF BDWSEG="ZRC"
Begin DoDot:1
+17 IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U)=""
IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U,4)=""
SET BDWFLG=1
+18 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,8)]""
IF BDWFLG=1
SET BDWCD="A"
+19 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,8)]""
IF BDWFLG=0
SET BDWCD="Y"
End DoDot:1
QUIT $GET(BDWCD)
+20 IF BDWSEG="ZRD"
Begin DoDot:1
+21 IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U)=""
IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U,2)=""
SET BDWFLG=1
+22 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,4)]""
IF BDWFLG=1
SET BDWCD="A"
+23 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,4)]""
IF BDWFLG=0
SET BDWCD="Y"
End DoDot:1
QUIT $GET(BDWCD)
+24 IF BDWSEG="ZIN"
Begin DoDot:1
+25 IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U)=""
IF $PIECE($GET(^AUPNPAT(BDWIEN,4)),U,5)=""
SET BDWFLG=1
+26 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,11)]""
IF BDWFLG=1
SET BDWCD="A"
+27 IF $PIECE($GET(^AUPNDWAF(BDWIEN,0)),U,11)]""
IF BDWFLG=0
SET BDWCD="Y"
End DoDot:1
QUIT $GET(BDWCD)
+28 QUIT BDWCD
+29 ;
GETDIR ;get export directory
+1 SET BDWHDIR=$SELECT($PIECE($GET(^AUTTSITE(1,1)),U,2)]"":$PIECE(^AUTTSITE(1,1),U,2),1:$GET(^XTV(8989.3,1,"DEV")))
+2 IF $GET(BDWHDIR)=""
SET BDWHDIR="/usr/spool/uucppublic/"
+3 QUIT
HFSA(DEST,BHLHDIR,BHLHFNM) ;EP - export from this destination
+1 SET Y=$$OPEN^%ZISH(BHLHDIR,BHLHFNM,"W")
+2 IF Y
QUIT
+3 SET BHLX=0
FOR
SET BHLX=$ORDER(^BDWTMP(DEST,BHLX))
IF 'BHLX
QUIT
Begin DoDot:1
+4 SET BHLU=$ORDER(^INTHU("AT",BHLX,0))
+5 ;cmi/maw 6/28/2004 added for null node
IF 'BHLU
QUIT
+6 DO LPINTHU(BHLU)
End DoDot:1
+7 DO ^%ZISC
+8 ;*****LORI PUT SENDTO HERE WHEN READY
+9 IF $PIECE($GET(^AUTTSITE(1,0)),U,21)=1
SET BDWSLASH="/"
IF 1
+10 IF '$TEST
SET BDWSLASH="\"
+11 SET BDWNOSLA=1
IF $EXTRACT(BDWHDIR,$LENGTH(BDWHDIR))="/"!($EXTRACT(BDWHDIR,$LENGTH(BDWHDIR))="\")
SET BDWNOSLA=0
+12 SET BDWPAFN=BHLHDIR_$SELECT(BDWNOSLA:BDWSLASH,1:"")_BHLHFNM
+13 ;now loop through and delete them
+14 SET BHLX=0
FOR
SET BHLX=$ORDER(^BDWTMP(DEST,BHLX))
IF 'BHLX
QUIT
Begin DoDot:1
+15 SET BHLU=$ORDER(^INTHU("AT",BHLX,0))
+16 ;cmi/maw 6/28/2004 added for null node
IF 'BHLU
QUIT
+17 SET DA=BHLU
SET DIE="^INTHU("
SET DR=".03////C"
DO ^DIE
KILL DIE,DA,DR
+18 QUIT
End DoDot:1
+19 KILL ^BDWTMP(DEST)
+20 DO AUTOSEND^BDWBHL1
FTP ;
+1 ;PUT FTP TO DW MACHINE HERE
BULL ;now send mailman message to user who queued the job
+1 DO BULL^BDWBHL1
+2 QUIT
+3 ;
LPINTHU(BHLUIEN) ;EP - loop through UIF and set to file
+1 SET BHLUDA=0
FOR
SET BHLUDA=$ORDER(^INTHU(BHLUIEN,3,BHLUDA))
IF 'BHLUDA
QUIT
Begin DoDot:1
+2 USE IO
WRITE $PIECE($GET(^INTHU(BHLUIEN,3,BHLUDA,0)),"|CR|"),!
End DoDot:1
+3 QUIT
+4 ;
DELAY(IDA,IA) ;-- determine the delay based on records
+1 IF IA=90215
QUIT 60
+2 NEW BDWRCNT
+3 SET BDWRCNT=$$GET1^DIQ(IA,IDA,.06)
+4 IF BDWRCNT>10000
QUIT 30
+5 IF BDWRCNT>40000
QUIT 60
+6 IF BDWRCNT>60000
QUIT 90
+7 QUIT 15
+8 ;
HFS ;-- task the file to the host system
+1 NEW BDWUSER,BDWDESC,F,BDWPFL,BDWPIEN
+2 SET BDWUSER=$$VALI^XBDIQ1(INA("FILE"),INDA,8801)
+3 ;maw added 4/7/2005 for ZTS-6
SET BDWPFL=$GET(INA("FILE"))
+4 ;maw added 4/7/2005 for ZTS-6
SET BDWPIEN=$GET(INDA)
+5 IF INA("FILE")=90213
SET BDWDESC="Data Warehouse Export for: "_$$VAL^XBDIQ1(90213,INDA,.01)_" to "_$$VAL^XBDIQ1(90213,INDA,.02)
+6 IF INA("FILE")=90214
SET BDWDESC="Data Warehouse Visit Backload for: "_$$VAL^XBDIQ1(90214,INDA,.01)_" to "_$$VAL^XBDIQ1(90214,INDA,.02)
+7 IF INA("FILE")=90215
SET BDWDESC="Full Registration Backload to the Data Warehouse"
+8 SET ZTRTN="HFS1^BDWBHL"
+9 SET ZTIO=""
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,$$DELAY(INDA,INA("FILE")))
SET ZTDESC="DW DATA WAREHOUSE HFS CREATION"
SET ZTSAVE("BDW*")=""
+10 DO ^%ZTLOAD
+11 QUIT
HFS1 ;EP - called from taskman
+1 NEW BDWDEST,BDWHDIR,BDWHFNM
+2 SET BDWDEST=$ORDER(^INRHD("B","HL IHS DW1 IE",0))
+3 IF 'BDWDEST
QUIT
+4 ;kill off inlhdest
KILL ^INLHDEST(BDWDEST)
+5 NEW BDWQCNT
+6 ;4/7/05 maw quick count of records to put in ZTS-6
SET BDWQCNT=$$QCNT(BDWDEST)
+7 DO SETZTS6(BDWPFL,BDWPIEN,BDWQCNT)
+8 ;before saving off, reset AUPNDWAF and 4 node in AUPNPAT
+9 IF BDWPFL=90213
IF '$PIECE($GET(^BDWXLOG(BDWPIEN,0)),U,22)
DO RST4AF^BDWRDR(BDWPIEN)
+10 IF BDWPFL=90213
IF $PIECE($GET(^BDWXLOG(BDWPIEN,0)),U,22)
DO RESETFLG^BDWBHL1(BDWDEST,BDWPFL,BDWPIEN)
+11 ;
+12 DO GETDIR
+13 IF BDWHDIR=""
QUIT
+14 NEW BDWASU
+15 SET BDWASU=$PIECE($GET(^AUTTLOC($PIECE($GET(^AUTTSITE(1,0)),U),0)),U,10)
+16 DO NOW^%DTC
+17 NEW BDWDTS
+18 SET BDWDTS=$TRANSLATE(%,".")
+19 SET BDWHFNM=BDWASU_BDWDTS_".BDW"
+20 DO HFSA(BDWDEST,BDWHDIR,BDWHFNM)
+21 SET ZTREQ="@"
+22 QUIT
+23 ;
QCNT(DEST) ;-- let's loop through and get a quick count of records
+1 NEW BDWDA,BDWCNT
+2 SET BDWCNT=0
+3 SET BDWDA=0
FOR
SET BDWDA=$ORDER(^BDWTMP(DEST,BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+4 IF '$ORDER(^INTHU("AT",BDWDA,0))
QUIT
+5 ;cmi/anch/maw 12/7/2007 filter out A40's?
+6 SET BDWCNT=BDWCNT+1
End DoDot:1
+7 QUIT +$GET(BDWCNT)
+8 ;
SETZTS6(PFL,PIEN,QCNT) ;-- set ZTS-6 with actual counts
+1 NEW TRL
+2 IF PFL=90213
Begin DoDot:1
+3 SET TRL=$PIECE($GET(^BDWXLOG(PIEN,0)),U,14)
+4 IF 'TRL
QUIT
+5 SET TRL=$ORDER(^INTHU("AT",TRL,0))
End DoDot:1
+6 IF PFL=90214
Begin DoDot:1
+7 SET TRL=$PIECE($GET(^BDWBLOG(PIEN,0)),U,14)
+8 IF 'TRL
QUIT
+9 SET TRL=$ORDER(^INTHU("AT",TRL,0))
End DoDot:1
+10 IF PFL=90215
Begin DoDot:1
+11 SET TRL=$PIECE($GET(^BDWRBLOG(PIEN,0)),U,8)
+12 IF 'TRL
QUIT
+13 SET TRL=$ORDER(^INTHU("AT",TRL,0))
End DoDot:1
+14 IF '$GET(TRL)
QUIT
+15 NEW LDA
+16 SET LDA=0
FOR
SET LDA=$ORDER(^INTHU(TRL,3,LDA))
IF 'LDA
QUIT
Begin DoDot:1
+17 IF $EXTRACT($GET(^INTHU(TRL,3,LDA,0)),1,3)="ZTS"
Begin DoDot:2
+18 SET $PIECE(^INTHU(TRL,3,LDA,0),"|",7)=QCNT_"|CR"
End DoDot:2
End DoDot:1
+19 QUIT
