BDWBHL1 ; IHS/CMI/LAB - BDW Populate Various DW1 HL7 Segments ;
;;1.0;IHS DATA WAREHOUSE;**2,4**;JAN 23, 2006;Build 24
;
;
BULL ;EP - called from BDWBHL to send bulletin
NEW XMSUB,XMDUZ,XMTEXT,XMY,BDWC,BDWBUL
KILL BDWBUL
S XMY(BDWUSER)=""
D WRITEMSG
SUBJECT S XMSUB="* DATA WAREHOUSE PROCESSING COMPLETE *"
SENDER S XMDUZ="Data Warehouse Export System"
S XMTEXT="BDWBUL("
D ^XMD
KILL BDWBUL
Q
;
WRITEMSG ;
S BDWC=0
S X="*********** DATA WAREHOUSE EXPORT SYSTEM *************" D SET
S X="This message is to inform you that the process has completed" D SET
S X="and the file has been written to the export directory for" D SET
S X=BDWDESC D SET
S X=" " D SET
I $G(BDWSFLG) D
.S X="The autoftp to the data warehouse FAILED." D SET
.S X="You will need to manually ftp the file named "_BDWPAFN D SET
.S X="to the data warehouse." D SET
Q
;;
SET ;
S BDWC=BDWC+1
S BDWBUL(BDWC)=X
Q
RESETFLG(BDW1DEST,BDW1LOG,BDW1PIEN) ;EP
;loop through all messages in ^BDWTMP
;if it is a reg message then reset flags in ZRB, ZRL, ZRC, ZRD, ZIN as stored in log
NEW BDWX,BDWM,BDWZ,BDWY
S BDWX=0 F S BDWX=$O(^BDWXLOG(BDWPIEN,41,BDWX)) Q:BDWX'=+BDWX D
.S BDWM=$P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,7)
.Q:BDWM=""
.S BDWM=$O(^INTHU("AT",BDWM,0))
.Q:'BDWM
.Q:'$D(^INTHU(BDWM,0))
.S BDWY=0 F S BDWY=$O(^INTHU(BDWM,3,BDWY)) Q:BDWY'=+BDWY D
..I $P(^INTHU(BDWM,3,BDWY,0),"|")="ZRB" S $P(^INTHU(BDWM,3,BDWY,0),"|",4)=$P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,8) I $P(^INTHU(BDWM,3,BDWY,0),"|",2)="" S $P(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,2),1)
..I $P(^INTHU(BDWM,3,BDWY,0),"|")="ZRL" S $P(^INTHU(BDWM,3,BDWY,0),"|",4)=$P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,9) I $P(^INTHU(BDWM,3,BDWY,0),"|",2)="" S $P(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,4),1)
..I $P(^INTHU(BDWM,3,BDWY,0),"|")="ZRC" S $P(^INTHU(BDWM,3,BDWY,0),"|",4)=$P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,10) I $P(^INTHU(BDWM,3,BDWY,0),"|",2)="" S $P(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,5),1)
..I $P(^INTHU(BDWM,3,BDWY,0),"|")="ZRD" S $P(^INTHU(BDWM,3,BDWY,0),"|",4)=$P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,11) I $P(^INTHU(BDWM,3,BDWY,0),"|",2)="" S $P(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,3),1)
..I $P(^INTHU(BDWM,3,BDWY,0),"|")="ZIN" S $P(^INTHU(BDWM,3,BDWY,0),"|",4)=$P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,12) I $P(^INTHU(BDWM,3,BDWY,0),"|",2)="" S $P(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($P(^BDWXLOG(BDWPIEN,41,BDWX,0),U,6),1)
..Q
.Q
Q
;
;
AUTOSEND ;EP
S BDWSFLG=$$SENDTO1^ZISHMSMU("DATA WAREHOUSE SEND",BDWPAFN)
S BDWSFLG(1)=$P(BDWSFLG,"^",2)
S BDWSFLG=+BDWSFLG
Q:$D(ZTQUEUED)
I BDWSFLG'=0 D
. W:'$D(ZTQUEUED) !,"DW HL7 file was NOT successfully transferred to the data warehouse",!,"you will need to manually ftp it.",!
. W:'$D(ZTQUEUED) !,BDWSFLG(1),!!
;
Q
SKT ;EP
K SKT
;S BDWCNT=0
D ST^BDWUTIL1(.SKT,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(SKT(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(SKT(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("SKT",BDWCNT)=""
. S INA("BDW1SKT1",BDWCNT)=BDWCNT
. S INA("BDW1SKT2",BDWCNT)="SKT"
. S INA("BDW1SKT3",BDWCNT)=$P(BDWDATA,U)
. S INA("BDW1SKT5",BDWCNT)=$P(BDWDATA,U,2)_U_$P(BDWDATA,U,3)
K BDWDA,BDWDATA,PED
Q
IFC ;EP p5 ALPMR
K IFC
;S BDWCNT=0
D IFC^BDWUTIL1(.IFC,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(IFC(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(IFC(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("IFC",BDWCNT)=""
. S INA("BDW1IFC1",BDWCNT)=BDWCNT
. S INA("BDW1IFC2",BDWCNT)="IFC"
. ;S INA("BDW1IFC3",BDWCNT)=$P(BDWDATA,U)
. S INA("BDW1IFC5",BDWCNT)=$P(BDWDATA,U)_"^"_$P(BDWDATA,U,2)
K BDWDA,BDWDATA,PED
Q
PED ;EP
K PED
;S BDWCNT=0
D PED^BDWUTIL(.PED,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(PED(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(PED(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("PED",BDWCNT)=""
. S INA("BDW1PED1",BDWCNT)=BDWCNT
. S INA("BDW1PED2",BDWCNT)="PED"
. S INA("BDW1PED3",BDWCNT)=$P(BDWDATA,U)
. S INA("BDW1PED5",BDWCNT)=$P(BDWDATA,U,2)
. S INA("BDW1PED13",BDWCNT)=$P(BDWDATA,U,3)
K BDWDA,BDWDATA,PED
Q
;
LAB ;EP
K LAB
;S BDWCNT=0
D LAB^BDWUTIL(.LAB,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(LAB(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(LAB(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("LAB",BDWCNT)=""
. S INA("BDW1LAB1",BDWCNT)=BDWCNT
. S INA("BDW1LAB2",BDWCNT)="LAB"
. S INA("BDW1LAB3",BDWCNT)=$P(BDWDATA,U)_U_$P(BDWDATA,U,2)
. S INA("BDW1LAB5",BDWCNT)=$P(BDWDATA,U,3)
. S INA("BDW1LAB6",BDWCNT)=$P(BDWDATA,U,4)
. S INA("BDW1LAB7",BDWCNT)=$P(BDWDATA,U,5)_U_$P(BDWDATA,U,6)
K BDWDA,BDWDATA,LAB
Q
CPT ;EP
K CPT,AUPNCPT
;S BDWCNT=0
D CPT^BDWUTIL(.CPT,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(CPT(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(CPT(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("CPT",BDWCNT)=""
. S INA("BDW1CPT1",BDWCNT)=BDWCNT
. S INA("BDW1CPT2",BDWCNT)="CPT"
. S INA("BDW1CPT3",BDWCNT)=$P(BDWDATA,U)
. S INA("BDW1CPT5",BDWCNT)=$P(BDWDATA,U,2)
. S INA("BDW1CPT13",BDWCNT)=$TR($P(BDWDATA,U,3),"!","^")
K BDWDA,BDWDATA,CPT
Q
;
XAM ;EP
K XAM
;S BDWCNT=0
D EXAM^BDWUTIL(.XAM,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(XAM(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(XAM(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("XAM",BDWCNT)=""
. S INA("BDW1XAM1",BDWCNT)=BDWCNT
. S INA("BDW1XAM2",BDWCNT)="XAM"
. S INA("BDW1XAM3",BDWCNT)=$P(BDWDATA,U)
K BDWDA,BDWDATA,XAM
Q
;
MSR ;EP
K MSR
;S BDWCNT=0
D MEAS^BDWUTIL(.MSR,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(MSR(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(MSR(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("MSR",BDWCNT)=""
. S INA("BDW1MSR1",BDWCNT)=BDWCNT
. S INA("BDW1MSR2",BDWCNT)="MSR"
. S INA("BDW1MSR3",BDWCNT)=$P(BDWDATA,U)
. S INA("BDW1MSR5",BDWCNT)=$P(BDWDATA,U,2)
K BDWDA,BDWDATA,MSR
Q
HF ;EP
K HEF
S BDWCNT=0
D MC^BDWUTIL1(.HEF,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(HEF(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(HEF(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("HEF",BDWCNT)=""
. S INA("BDW1HEF1",BDWCNT)=BDWCNT
. S INA("BDW1HEF2",BDWCNT)="HF"
. S INA("BDW1HEF3",BDWCNT)=$P(BDWDATA,U,3)_U_$P(BDWDATA,U,2)
. S INA("BDW1HEF4",BDWCNT)=$P(BDWDATA,U,5)_U_$P(BDWDATA,U,4)
K BDWDA,BDWDATA,HEF
Q
;
ZIM ;EP - populate the dw1 ZIM segment
K IMM
S BDWCNT=0
D IMM^BDWUTIL1(.IMM,BHLVIEN)
S BDWDA=0 F S BDWDA=$O(IMM(BDWDA)) Q:'BDWDA D
. S BDWDATA=$G(IMM(BDWDA))
. S BDWCNT=BDWCNT+1
. S INDA("ZIM",BDWCNT)=""
. S INA("BDW1ZIM1",BDWCNT)=BDWCNT
. S INA("BDW1ZIM2",BDWCNT)=$P(BDWDATA,U,3) ;cmi/anch/maw 3/25/2008 for CVX codeset
. S INA("BDW1ZIM3",BDWCNT)=$P(BDWDATA,U,2)
. ;S INA("BDW1ZIM4",BDWCNT)=$P(BDWDATA,U,3) ;cmi/anch/maw 4/16/2008 no longer wanted per Lisa Hunt email
. S INA("BDW1ZIM5",BDWCNT)=$P(BDWDATA,U,4)
. S INA("BDW1ZIM6",BDWCNT)=$P(BDWDATA,U,5)
K BDWCNT,BDWDA,BDWDATA,IMM
Q
;
DW1ALPMR(BHLPAT) ;-- generate an A08 for dw1 alpmr patient centric
I 'BHLPAT Q $$MSG^BHLEVENT("PAT")
S INDA=BHLPAT
I $G(INA) S INA("BACKLOAD")=1
D ^INHF("HL IHS DW1ALPMR A08 OUT PARENT",.INDA,.INA)
D EOJ^BHLEVENT
Q $P($$MSG^BHLEVENT(INHF),U)
;
BDWBHL1 ; IHS/CMI/LAB - BDW Populate Various DW1 HL7 Segments ;
+1 ;;1.0;IHS DATA WAREHOUSE;**2,4**;JAN 23, 2006;Build 24
+2 ;
+3 ;
BULL ;EP - called from BDWBHL to send bulletin
+1 NEW XMSUB,XMDUZ,XMTEXT,XMY,BDWC,BDWBUL
+2 KILL BDWBUL
+3 SET XMY(BDWUSER)=""
+4 DO WRITEMSG
SUBJECT SET XMSUB="* DATA WAREHOUSE PROCESSING COMPLETE *"
SENDER SET XMDUZ="Data Warehouse Export System"
+1 SET XMTEXT="BDWBUL("
+2 DO ^XMD
+3 KILL BDWBUL
+4 QUIT
+5 ;
WRITEMSG ;
+1 SET BDWC=0
+2 SET X="*********** DATA WAREHOUSE EXPORT SYSTEM *************"
DO SET
+3 SET X="This message is to inform you that the process has completed"
DO SET
+4 SET X="and the file has been written to the export directory for"
DO SET
+5 SET X=BDWDESC
DO SET
+6 SET X=" "
DO SET
+7 IF $GET(BDWSFLG)
Begin DoDot:1
+8 SET X="The autoftp to the data warehouse FAILED."
DO SET
+9 SET X="You will need to manually ftp the file named "_BDWPAFN
DO SET
+10 SET X="to the data warehouse."
DO SET
End DoDot:1
+11 QUIT
+12 ;;
SET ;
+1 SET BDWC=BDWC+1
+2 SET BDWBUL(BDWC)=X
+3 QUIT
RESETFLG(BDW1DEST,BDW1LOG,BDW1PIEN) ;EP
+1 ;loop through all messages in ^BDWTMP
+2 ;if it is a reg message then reset flags in ZRB, ZRL, ZRC, ZRD, ZIN as stored in log
+3 NEW BDWX,BDWM,BDWZ,BDWY
+4 SET BDWX=0
FOR
SET BDWX=$ORDER(^BDWXLOG(BDWPIEN,41,BDWX))
IF BDWX'=+BDWX
QUIT
Begin DoDot:1
+5 SET BDWM=$PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,7)
+6 IF BDWM=""
QUIT
+7 SET BDWM=$ORDER(^INTHU("AT",BDWM,0))
+8 IF 'BDWM
QUIT
+9 IF '$DATA(^INTHU(BDWM,0))
QUIT
+10 SET BDWY=0
FOR
SET BDWY=$ORDER(^INTHU(BDWM,3,BDWY))
IF BDWY'=+BDWY
QUIT
Begin DoDot:2
+11 IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|")="ZRB"
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",4)=$PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,8)
IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=""
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,2),1)
+12 IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|")="ZRL"
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",4)=$PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,9)
IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=""
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,4),1)
+13 IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|")="ZRC"
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",4)=$PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,10)
IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=""
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,5),1)
+14 IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|")="ZRD"
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",4)=$PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,11)
IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=""
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,3),1)
+15 IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|")="ZIN"
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",4)=$PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,12)
IF $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=""
SET $PIECE(^INTHU(BDWM,3,BDWY,0),"|",2)=$$DATE^INHUT($PIECE(^BDWXLOG(BDWPIEN,41,BDWX,0),U,6),1)
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
+20 ;
AUTOSEND ;EP
+1 SET BDWSFLG=$$SENDTO1^ZISHMSMU("DATA WAREHOUSE SEND",BDWPAFN)
+2 SET BDWSFLG(1)=$PIECE(BDWSFLG,"^",2)
+3 SET BDWSFLG=+BDWSFLG
+4 IF $DATA(ZTQUEUED)
QUIT
+5 IF BDWSFLG'=0
Begin DoDot:1
+6 IF '$DATA(ZTQUEUED)
WRITE !,"DW HL7 file was NOT successfully transferred to the data warehouse",!,"you will need to manually ftp it.",!
+7 IF '$DATA(ZTQUEUED)
WRITE !,BDWSFLG(1),!!
End DoDot:1
+8 ;
+9 QUIT
SKT ;EP
+1 KILL SKT
+2 ;S BDWCNT=0
+3 DO ST^BDWUTIL1(.SKT,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(SKT(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(SKT(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("SKT",BDWCNT)=""
+8 SET INA("BDW1SKT1",BDWCNT)=BDWCNT
+9 SET INA("BDW1SKT2",BDWCNT)="SKT"
+10 SET INA("BDW1SKT3",BDWCNT)=$PIECE(BDWDATA,U)
+11 SET INA("BDW1SKT5",BDWCNT)=$PIECE(BDWDATA,U,2)_U_$PIECE(BDWDATA,U,3)
End DoDot:1
+12 KILL BDWDA,BDWDATA,PED
+13 QUIT
IFC ;EP p5 ALPMR
+1 KILL IFC
+2 ;S BDWCNT=0
+3 DO IFC^BDWUTIL1(.IFC,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(IFC(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(IFC(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("IFC",BDWCNT)=""
+8 SET INA("BDW1IFC1",BDWCNT)=BDWCNT
+9 SET INA("BDW1IFC2",BDWCNT)="IFC"
+10 ;S INA("BDW1IFC3",BDWCNT)=$P(BDWDATA,U)
+11 SET INA("BDW1IFC5",BDWCNT)=$PIECE(BDWDATA,U)_"^"_$PIECE(BDWDATA,U,2)
End DoDot:1
+12 KILL BDWDA,BDWDATA,PED
+13 QUIT
PED ;EP
+1 KILL PED
+2 ;S BDWCNT=0
+3 DO PED^BDWUTIL(.PED,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(PED(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(PED(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("PED",BDWCNT)=""
+8 SET INA("BDW1PED1",BDWCNT)=BDWCNT
+9 SET INA("BDW1PED2",BDWCNT)="PED"
+10 SET INA("BDW1PED3",BDWCNT)=$PIECE(BDWDATA,U)
+11 SET INA("BDW1PED5",BDWCNT)=$PIECE(BDWDATA,U,2)
+12 SET INA("BDW1PED13",BDWCNT)=$PIECE(BDWDATA,U,3)
End DoDot:1
+13 KILL BDWDA,BDWDATA,PED
+14 QUIT
+15 ;
LAB ;EP
+1 KILL LAB
+2 ;S BDWCNT=0
+3 DO LAB^BDWUTIL(.LAB,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(LAB(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(LAB(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("LAB",BDWCNT)=""
+8 SET INA("BDW1LAB1",BDWCNT)=BDWCNT
+9 SET INA("BDW1LAB2",BDWCNT)="LAB"
+10 SET INA("BDW1LAB3",BDWCNT)=$PIECE(BDWDATA,U)_U_$PIECE(BDWDATA,U,2)
+11 SET INA("BDW1LAB5",BDWCNT)=$PIECE(BDWDATA,U,3)
+12 SET INA("BDW1LAB6",BDWCNT)=$PIECE(BDWDATA,U,4)
+13 SET INA("BDW1LAB7",BDWCNT)=$PIECE(BDWDATA,U,5)_U_$PIECE(BDWDATA,U,6)
End DoDot:1
+14 KILL BDWDA,BDWDATA,LAB
+15 QUIT
CPT ;EP
+1 KILL CPT,AUPNCPT
+2 ;S BDWCNT=0
+3 DO CPT^BDWUTIL(.CPT,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(CPT(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(CPT(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("CPT",BDWCNT)=""
+8 SET INA("BDW1CPT1",BDWCNT)=BDWCNT
+9 SET INA("BDW1CPT2",BDWCNT)="CPT"
+10 SET INA("BDW1CPT3",BDWCNT)=$PIECE(BDWDATA,U)
+11 SET INA("BDW1CPT5",BDWCNT)=$PIECE(BDWDATA,U,2)
+12 SET INA("BDW1CPT13",BDWCNT)=$TRANSLATE($PIECE(BDWDATA,U,3),"!","^")
End DoDot:1
+13 KILL BDWDA,BDWDATA,CPT
+14 QUIT
+15 ;
XAM ;EP
+1 KILL XAM
+2 ;S BDWCNT=0
+3 DO EXAM^BDWUTIL(.XAM,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(XAM(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(XAM(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("XAM",BDWCNT)=""
+8 SET INA("BDW1XAM1",BDWCNT)=BDWCNT
+9 SET INA("BDW1XAM2",BDWCNT)="XAM"
+10 SET INA("BDW1XAM3",BDWCNT)=$PIECE(BDWDATA,U)
End DoDot:1
+11 KILL BDWDA,BDWDATA,XAM
+12 QUIT
+13 ;
MSR ;EP
+1 KILL MSR
+2 ;S BDWCNT=0
+3 DO MEAS^BDWUTIL(.MSR,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(MSR(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(MSR(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("MSR",BDWCNT)=""
+8 SET INA("BDW1MSR1",BDWCNT)=BDWCNT
+9 SET INA("BDW1MSR2",BDWCNT)="MSR"
+10 SET INA("BDW1MSR3",BDWCNT)=$PIECE(BDWDATA,U)
+11 SET INA("BDW1MSR5",BDWCNT)=$PIECE(BDWDATA,U,2)
End DoDot:1
+12 KILL BDWDA,BDWDATA,MSR
+13 QUIT
HF ;EP
+1 KILL HEF
+2 SET BDWCNT=0
+3 DO MC^BDWUTIL1(.HEF,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(HEF(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(HEF(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("HEF",BDWCNT)=""
+8 SET INA("BDW1HEF1",BDWCNT)=BDWCNT
+9 SET INA("BDW1HEF2",BDWCNT)="HF"
+10 SET INA("BDW1HEF3",BDWCNT)=$PIECE(BDWDATA,U,3)_U_$PIECE(BDWDATA,U,2)
+11 SET INA("BDW1HEF4",BDWCNT)=$PIECE(BDWDATA,U,5)_U_$PIECE(BDWDATA,U,4)
End DoDot:1
+12 KILL BDWDA,BDWDATA,HEF
+13 QUIT
+14 ;
ZIM ;EP - populate the dw1 ZIM segment
+1 KILL IMM
+2 SET BDWCNT=0
+3 DO IMM^BDWUTIL1(.IMM,BHLVIEN)
+4 SET BDWDA=0
FOR
SET BDWDA=$ORDER(IMM(BDWDA))
IF 'BDWDA
QUIT
Begin DoDot:1
+5 SET BDWDATA=$GET(IMM(BDWDA))
+6 SET BDWCNT=BDWCNT+1
+7 SET INDA("ZIM",BDWCNT)=""
+8 SET INA("BDW1ZIM1",BDWCNT)=BDWCNT
+9 ;cmi/anch/maw 3/25/2008 for CVX codeset
SET INA("BDW1ZIM2",BDWCNT)=$PIECE(BDWDATA,U,3)
+10 SET INA("BDW1ZIM3",BDWCNT)=$PIECE(BDWDATA,U,2)
+11 ;S INA("BDW1ZIM4",BDWCNT)=$P(BDWDATA,U,3) ;cmi/anch/maw 4/16/2008 no longer wanted per Lisa Hunt email
+12 SET INA("BDW1ZIM5",BDWCNT)=$PIECE(BDWDATA,U,4)
+13 SET INA("BDW1ZIM6",BDWCNT)=$PIECE(BDWDATA,U,5)
End DoDot:1
+14 KILL BDWCNT,BDWDA,BDWDATA,IMM
+15 QUIT
+16 ;
DW1ALPMR(BHLPAT) ;-- generate an A08 for dw1 alpmr patient centric
+1 IF 'BHLPAT
QUIT $$MSG^BHLEVENT("PAT")
+2 SET INDA=BHLPAT
+3 IF $GET(INA)
SET INA("BACKLOAD")=1
+4 DO ^INHF("HL IHS DW1ALPMR A08 OUT PARENT",.INDA,.INA)
+5 DO EOJ^BHLEVENT
+6 QUIT $PIECE($$MSG^BHLEVENT(INHF),U)
+7 ;
