BWMDET1 ;CMI/THL - NEW METHOD TO EXPORT CBE/MAM DATA - BWMDET CON'T;30-May-2003 15:26;DKM
;;2.0;WOMEN'S HEALTH;**5,6,7,8**;MAY 16, 1996
;; CDC EXPORT, BUILDS ASCII FIXED LENGTH RECORDS FOR EXPORT.
;IHS/CMI/THL - patch 5 new routine for new cdc format
;;
;; BWTCBE(35) = CDC DX CODE
;; BWTCBE(36) = DX WORKUP PLANNED CODE
;; Each of the BWTCBE(n) variables corresponds to the 67 field of the
;; CDC exprt record per version 2.4
;EVALUATE EACH PROCEDURE FOR CDC EXPORT
LASTCBE ;EP;FIND LAST CBE
D CBEARRAY:'$D(^TMP("CBEARRAY",$J,BWTPATDA))
Q:'$D(^TMP("CBEARRAY",$J,BWTPATDA))
K BWTQUIT
N BWTX,BWTDATX
S BWTZ=""
;CHECK FOR CBE ON SAME DAY UP IEN
S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDAT,BWTPCDDA))
I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)) S BWTZ=BWTX,BWTDATX=BWTDAT D Q:'$D(BWTQUIT)
.D INTV
.I BWTINTV>60 D Q
..S BWTQUIT=""
..;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
..;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
.S BWTZ=BWTX
.D L1
K XMINUS
;CHECK FOR CBE ON SAME DAY BACK IEN
S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDAT,BWTPCDDA),-1)
I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)) S BWTZ=BWTX,BWTDATX=BWTDAT D Q:'$D(BWTQUIT)
.D INTV
.I BWTINTV>60 D Q
..S BWTQUIT=""
..;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
..;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
.K XMINUS
.S BWTZ=BWTX
.D L1
K XMINUS
;CHECK FOR CBE ON PREVIOUS VISIT DAY FOR UP TO 2 VISITS ON THAT DATE
S BWTDATX=$O(^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDAT),-1)
I 'BWTDATX D L0 Q
S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,0))
I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)) D Q:'$D(BWTQUIT)&'$D(XMINUS) K BWTQUIT
.D INTV
.I BWTINTV>60 D Q
..S:'$D(XMINUS) BWTQUIT=""
..;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
..;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
.K XMINUS
.S BWTZ=BWTX
.D L1
K XMINUS
S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX))
I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)) D Q:'$D(BWTQUIT) K BWTQUIT
.D INTV
.I BWTINTV>60 D Q
..S BWTQUIT=""
..;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
..;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
.S BWTZ=BWTX
.D L1
K XMINUS
;CHECK FOR CBE ON NEXT VISIT DAY FOR UP TO 2 VISITS ON THAT DATE
S BWTDATX=$O(^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDAT))
I 'BWTDATX D L0 Q
S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,0))
I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)) D Q:'$D(BWTQUIT) K BWTQUIT
.D INTV
.I BWTINTV>60 D Q
..S BWTQUIT=""
..;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
..;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
.S BWTZ=BWTX
.D L1
K XMINUS
S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX))
I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)) D Q:'$D(BWTQUIT) K BWTQUIT
.D INTV
.I BWTINTV>60 D Q
..S BWTQUIT=""
..;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
..;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
.S BWTZ=BWTX
.D L1
K XMINUS
L0 I 'BWTZ S BWTZ=BWTPCDDA,BWTDATX=BWTDAT
L1 D ENDATE
Q:$D(BWTQUIT)
S ^TMP("BWTPCD",$J,BWTZ)=""
K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTZ)
S X=$G(^BWPCD(BWTZ,0))
I $P(X,U,5)=8!($P(X,U,5)=63)!'$P(X,U,5) Q:$P(X,U,4)'=27 S BWTDAT=BWTDATX G LASTCBE
S BWT("CBE RESULT POINTER")=$P($G(^BWDIAG(+$P(X,U,5),0)),U,27)
S:$P($G(^BWCBE(+BWT("CBE RESULT POINTER"),0)),U,2) BWTCBE(21)=$P($G(^BWCBE(+BWT("CBE RESULT POINTER"),0)),U,2)
K BWTCBE("CBE PAID")
I BWTCBE(21),BWTCBE(21)<3 S BWTCBE("CBE PAID")=1
S BWTDATX=$P(X,U,12)
S BWTDAT=$P(BWTDAT,".")
N XX,YY
S XX=BWTDATX
S YY=22
D F1^BWMDET:BWTCBE(21)<3
D INTV
Q
INTV ;EP;CALCULATE INTERVAL BETWEEN EVENTS
S X1=BWTDAT
S X2=BWTDATX
D ^%DTC
S:X<0 XMINUS=X,X=X*-1
S BWTINTV=X
Q
CBEARRAY ;EP;CREATE ARRAY OF ALL VISITS FOR A PATIENT
Q:$D(^TMP("CBEARRAY",$J,BWTPATDA))
N X,Y,Z
S X=0
F S X=$O(^BWPCD("C",BWTPATDA,X)) Q:'X D
.S Y=$G(^BWPCD(X,0))
.Q:'$P(Y,U,12)
.Q:"^27^28^29^25^26^30^31^32^33^34^38^"'[(U_$P(Y,U,4)_U) ;PATCH 8
.I $P(Y,U,5)=8!($P(Y,U,5)=63)!'$P(Y,U,5) Q
.S Z=$P(Y,U,12)
.Q:Z<2950101
.S ^TMP("CBEARRAY",$J,BWTPATDA,Z,X)=$P(Y,U,1,12)
.S:$P(Y,U,4)=27 ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",Z,X)=$P(Y,U,1,12)
Q
ENDATE ;EP;CHECK ENROLLMENT DATE
N BWTDAT,BWTDATX
S X1=$P($G(^BWP(BWTPATDA,0)),U,21)
S X2=$P($G(^BWPCD(+$G(BWTPCDDA),0)),U,12)
Q:'X1!'X2!(X1-1<X2)
D ^%DTC
I X>59 S BWTQUIT="" D USED^BWMDET
Q
SEL ;EP;TO SELECT PATIENTS TO EXPORT ;PATCH 8
F D S1 Q:$D(BWQUIT)
K BWQUIT
Q:'$D(BWTSEL)
D ^BWMDE
Q
S1 S DIC="^BWP("
S DIC(0)="AEMQZ"
S DIC("A")="Name of Patient to Export: "
W !
D ^DIC
K DIC
I +Y<1 S BWQUIT="" Q
S BWTSEL(+Y)=""
Q
MCARE ;EP;EVALUATE MEDICARE ELIGIBILITY; PATCH 8
Q:'$D(^AUPNMCR("B",BWDFN))
K BWQUIT
N D,X,Y,Z
S X=0
F S X=$O(^AUPNMCR(BWDFN,11,X)) Q:'X!$D(BWQUIT) D
.S Y=$G(^AUPNMCR(BWDFN,11,X,0)),D=$P(Y,U,2)
.I $P(Y,U,3)="B",BWDT>+Y,BWDT<D!'D S BWQUIT="" Q
Q
PAID ;EP;
Q:"^1665^1860^1861^"'[(U_DUZ(2)_U)
I DUZ(2)=1665,$P(BWTP0,U,3)<2990401 S BWTCBE(38)=1 Q
I DUZ(2)=1860!(DUZ(2)=1861),$P(BWTP0,U,3)<2991001 S BWTCBE(38)=1 Q
NEW AGE
I $G(BWTCBE(35))>8 D Q ;IHS/CMI/THL PATCH 8
.I BWTCBE(35)<12 S BWTCBE(38)=""
.E S BWTCBE(38)=2
S AGE=$P($G(^DPT(+$P(BWTP0,U,2),0)),U,3)
S AGE=$E(DT,1,3)-$E(AGE,1,3)
I AGE<50!(AGE>65) S AGE=$R(100)
E S AGE=1
I AGE<26 S BWTCBE(38)=1
E S BWTCBE(38)=2
Q
RACE(DATE) ;EP;FIND RACE FOR SELECTED SITES AFTER SELECTED DATES
;IHS/CIM/THL PATCH 8
K BWQUIT
Q:$G(DATE)=""
Q:DUZ(2)'=1665
Q:$E(DATE,5,8)<1999
Q:$E(DATE,1,2)<10
S ZZ="" ;$$RACE^BWMDE2
Q:ZZ=4
S BWQUIT=""
Q
FILE ;FILE NEW EXPORT RECORD
K BWQUIT
D RACE(BWTCBE(37)):DUZ(2)=1665
I $D(BWQUIT) K BWQUIT Q ;IHS/CIM/THL PATCH 8
D MCARE
I $D(BWQUIT) K BWQUIT Q ;IHS/CIM/THL PATCH 8
;S BWTTOT=BWTTOT+1
D ^BWUTL5,PCDVARS^BWUTL3(BWIEN,0,1)
I '$D(NEW) I BWTCBE(21)>2 S BWTCBE(22)="",BWTCBE(23)=3 ;IHS/CMI/THL PATCH 8
I '$D(NEW) I BWTCBE(21)<3,'$G(BWTCBE(22)) I BWTCBE(37) S BWTCBE(22)=BWTCBE(37),BWTCBE(23)=1 ;IHS/CMI/THL PATCH 8
S BWMAM=1
S BWPAP=0
S $E(BWCDC(BWIEN),1)=$$STSCR^BWMDE2
S $E(BWCDC(BWIEN),3)=$$CNTYSCR^BWMDE2
S $E(BWCDC(BWIEN),6)=$E($P($G(^AUTTLOC(DUZ(2),0)),U,13),1,15)
S $E(BWCDC(BWIEN),21)=$J($P(BW0,U,10),5)
S:BWPAP $E(BWCDC(BWIEN),26)=$J($P(BW0,U,10),5)
S:BWMAM $E(BWCDC(BWIEN),31)=$J($P(BW0,U,10),5)
S $E(BWCDC(BWIEN),40)=$$PATID^BWMDE2
S $E(BWCDC(BWIEN),55)=$$RECID^BWMDE2
S $E(BWCDC(BWIEN),61)=2
S $E(BWCDC(BWIEN),62)=$$CNTYRES^BWMDE2
S $E(BWCDC(BWIEN),65)=$$STRES^BWMDE2
S $E(BWCDC(BWIEN),67)=$$ZIP^BWMDE2
S $E(BWCDC(BWIEN),72)=$$DOB^BWMDE2
S $E(BWCDC(BWIEN),80)="" ;$$RACE^BWMDE2
S $E(BWCDC(BWIEN),81)=2
S $E(BWCDC(BWIEN),88)=$G(BWTCBE(20))
S $E(BWCDC(BWIEN),89)=$G(BWTCBE(21))
S $E(BWCDC(BWIEN),90)=$G(BWTCBE(22))
I $G(BWTCBE(21)),BWTCBE(21)<3 S BWTCBE("CBE PAID")=1
I $G(BWTCBE(21)),BWTCBE(21)>2 S BWTCBE("CBE PAID")=""
S $E(BWCDC(BWIEN),98)=$G(BWTCBE("CBE PAID"))
S $E(BWCDC(BWIEN),99)=3
S $E(BWCDC(BWIEN),107)=" 9"
S $E(BWCDC(BWIEN),129)=2
S $E(BWCDC(BWIEN),139)=$G(BWTCBE(32))
S $E(BWCDC(BWIEN),140)=$G(BWTCBE(33))
S $E(BWCDC(BWIEN),146)=$S($L($G(BWTCBE(35)))=1:"0",1:"")_$G(BWTCBE(35))
S $E(BWCDC(BWIEN),148)=$G(BWTCBE(36))
S $E(BWCDC(BWIEN),149)=$G(BWTCBE(37))
I BWTCBE(35)<9 S BWTCBE(38)=1 ;IHS/CMI/THL PATCH 8
E I BWTCBE(35)<12 S BWTCBE(38)=""
E S BWTCBE(38)=2
D PAID
S $E(BWCDC(BWIEN),157)=$G(BWTCBE(38))
I BWTCBE(38)'=1 S ^TMP("BWTEST",$J,BWTPCDDA)=BWTCBE(38)
S $E(BWCDC(BWIEN),158)=41
I $E(BWCDC(BWIEN),148)=1 D
.S $E(BWCDC(BWIEN),243)=$G(BWTCBE(52))
.S $E(BWCDC(BWIEN),244)=$G(BWTCBE(53))
.S $E(BWCDC(BWIEN),245)=$G(BWTCBE(54))
.S $E(BWCDC(BWIEN),246)=$G(BWTCBE(55))
.S $E(BWCDC(BWIEN),247)=$G(BWTCBE(56))
.S $E(BWCDC(BWIEN),248)=$S($G(BWTCBE(57)):BWTCBE(57),BWTCBE(36)=1:2,1:"")
.S BWTCBE(58)=$TR($G(BWTCBE(58)),",",";")
.S $E(BWCDC(BWIEN),249)=$G(BWTCBE(58))
.S BWTCBE(59)=$TR($G(BWTCBE(59)),",",";")
.S $E(BWCDC(BWIEN),269)=$G(BWTCBE(59))
.S X=$E(BWCDC(BWIEN),243,248)
.F J=1:1:6 I $E(X,J)=1 S $E(BWCDC(BWIEN),288)=1 Q
.I X=222222 S $E(BWCDC(BWIEN),288)=2
.S $E(BWCDC(BWIEN),289)=$G(BWTCBE(60))
.S $E(BWCDC(BWIEN),290)=$G(BWTCBE(61))
.S $E(BWCDC(BWIEN),291)=$G(BWTCBE(62))
.I $G(BWTCBE(63)) S $E(BWCDC(BWIEN),292)=$G(BWTCBE(63))
.E I X=222222 S $E(BWCDC(BWIEN),292)=2
.S $E(BWCDC(BWIEN),293)=$G(BWTCBE(64))
.S $E(BWCDC(BWIEN),301)=$G(BWTCBE(65))
.S $E(BWCDC(BWIEN),302)=$G(BWTCBE(66))
S $E(BWCDC(BWIEN),310)=$$EOR^BWMDE21
S ^BWTMP($J,BWDFN,BWIEN)=BWCDC(BWIEN)
;S ^TMP("BWEXPORT",$J,BWDFN,BWIEN)=BWCDC(BWIEN)
I '$D(BWSILENT) U IO(0) W "." ;IHS/CIM/THL PATCH 8
K BWCDC(BWIEN),BWTCBE
Q
SETUP ;EP;
S BWTCBE(20)=2
S BWTCBE(21)=1
S BWTCBE(23)=3
S BWTCBE(27)=" 9"
S BWTCBE(29)=2
S BWTCBE(32)=2
S BWTCBE(35)="01"
;S BWTCBE(35)="1" ;IHS/CMI/THL PATCH 7
S BWTCBE(36)=2
Q
BWMDET1 ;CMI/THL - NEW METHOD TO EXPORT CBE/MAM DATA - BWMDET CON'T;30-May-2003 15:26;DKM
+1 ;;2.0;WOMEN'S HEALTH;**5,6,7,8**;MAY 16, 1996
+2 ;; CDC EXPORT, BUILDS ASCII FIXED LENGTH RECORDS FOR EXPORT.
+3 ;IHS/CMI/THL - patch 5 new routine for new cdc format
+4 ;;
+5 ;; BWTCBE(35) = CDC DX CODE
+6 ;; BWTCBE(36) = DX WORKUP PLANNED CODE
+7 ;; Each of the BWTCBE(n) variables corresponds to the 67 field of the
+8 ;; CDC exprt record per version 2.4
+9 ;EVALUATE EACH PROCEDURE FOR CDC EXPORT
LASTCBE ;EP;FIND LAST CBE
+1 IF '$DATA(^TMP("CBEARRAY",$JOB,BWTPATDA))
DO CBEARRAY
+2 IF '$DATA(^TMP("CBEARRAY",$JOB,BWTPATDA))
QUIT
+3 KILL BWTQUIT
+4 NEW BWTX,BWTDATX
+5 SET BWTZ=""
+6 ;CHECK FOR CBE ON SAME DAY UP IEN
+7 SET BWTX=$ORDER(^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",BWTDAT,BWTPCDDA))
+8 IF BWTX
IF '$DATA(^TMP("BWTPCD",$JOB,BWTX))
SET BWTZ=BWTX
SET BWTDATX=BWTDAT
Begin DoDot:1
+9 DO INTV
+10 IF BWTINTV>60
Begin DoDot:2
+11 SET BWTQUIT=""
+12 ;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
+13 ;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
End DoDot:2
QUIT
+14 SET BWTZ=BWTX
+15 DO L1
End DoDot:1
IF '$DATA(BWTQUIT)
QUIT
+16 KILL XMINUS
+17 ;CHECK FOR CBE ON SAME DAY BACK IEN
+18 SET BWTX=$ORDER(^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",BWTDAT,BWTPCDDA),-1)
+19 IF BWTX
IF '$DATA(^TMP("BWTPCD",$JOB,BWTX))
SET BWTZ=BWTX
SET BWTDATX=BWTDAT
Begin DoDot:1
+20 DO INTV
+21 IF BWTINTV>60
Begin DoDot:2
+22 SET BWTQUIT=""
+23 ;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
+24 ;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
End DoDot:2
QUIT
+25 KILL XMINUS
+26 SET BWTZ=BWTX
+27 DO L1
End DoDot:1
IF '$DATA(BWTQUIT)
QUIT
+28 KILL XMINUS
+29 ;CHECK FOR CBE ON PREVIOUS VISIT DAY FOR UP TO 2 VISITS ON THAT DATE
+30 SET BWTDATX=$ORDER(^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",BWTDAT),-1)
+31 IF 'BWTDATX
DO L0
QUIT
+32 SET BWTX=$ORDER(^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",BWTDATX,0))
+33 IF BWTX
IF '$DATA(^TMP("BWTPCD",$JOB,BWTX))
Begin DoDot:1
+34 DO INTV
+35 IF BWTINTV>60
Begin DoDot:2
+36 IF '$DATA(XMINUS)
SET BWTQUIT=""
+37 ;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
+38 ;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
End DoDot:2
QUIT
+39 KILL XMINUS
+40 SET BWTZ=BWTX
+41 DO L1
End DoDot:1
IF '$DATA(BWTQUIT)&'$DATA(XMINUS)
QUIT
KILL BWTQUIT
+42 KILL XMINUS
+43 SET BWTX=$ORDER(^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",BWTDATX,BWTX))
+44 IF BWTX
IF '$DATA(^TMP("BWTPCD",$JOB,BWTX))
Begin DoDot:1
+45 DO INTV
+46 IF BWTINTV>60
Begin DoDot:2
+47 SET BWTQUIT=""
+48 ;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
+49 ;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
End DoDot:2
QUIT
+50 SET BWTZ=BWTX
+51 DO L1
End DoDot:1
IF '$DATA(BWTQUIT)
QUIT
KILL BWTQUIT
+52 KILL XMINUS
+53 ;CHECK FOR CBE ON NEXT VISIT DAY FOR UP TO 2 VISITS ON THAT DATE
+54 SET BWTDATX=$ORDER(^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",BWTDAT))
+55 IF 'BWTDATX
DO L0
QUIT
+56 SET BWTX=$ORDER(^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",BWTDATX,0))
+57 IF BWTX
IF '$DATA(^TMP("BWTPCD",$JOB,BWTX))
Begin DoDot:1
+58 DO INTV
+59 IF BWTINTV>60
Begin DoDot:2
+60 SET BWTQUIT=""
+61 ;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
+62 ;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
End DoDot:2
QUIT
+63 SET BWTZ=BWTX
+64 DO L1
End DoDot:1
IF '$DATA(BWTQUIT)
QUIT
KILL BWTQUIT
+65 KILL XMINUS
+66 SET BWTX=$ORDER(^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",BWTDATX,BWTX))
+67 IF BWTX
IF '$DATA(^TMP("BWTPCD",$JOB,BWTX))
Begin DoDot:1
+68 DO INTV
+69 IF BWTINTV>60
Begin DoDot:2
+70 SET BWTQUIT=""
+71 ;S ^TMP("BWTPCD",$J,BWTX)="" ;PATCH 8
+72 ;K ^TMP("CBEARRAY",$J,BWTPATDA,"CBE",BWTDATX,BWTX) ;PATCH 8
End DoDot:2
QUIT
+73 SET BWTZ=BWTX
+74 DO L1
End DoDot:1
IF '$DATA(BWTQUIT)
QUIT
KILL BWTQUIT
+75 KILL XMINUS
L0 IF 'BWTZ
SET BWTZ=BWTPCDDA
SET BWTDATX=BWTDAT
L1 DO ENDATE
+1 IF $DATA(BWTQUIT)
QUIT
+2 SET ^TMP("BWTPCD",$JOB,BWTZ)=""
+3 KILL ^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",BWTDATX,BWTZ)
+4 SET X=$GET(^BWPCD(BWTZ,0))
+5 IF $PIECE(X,U,5)=8!($PIECE(X,U,5)=63)!'$PIECE(X,U,5)
IF $PIECE(X,U,4)'=27
QUIT
SET BWTDAT=BWTDATX
GOTO LASTCBE
+6 SET BWT("CBE RESULT POINTER")=$PIECE($GET(^BWDIAG(+$PIECE(X,U,5),0)),U,27)
+7 IF $PIECE($GET(^BWCBE(+BWT("CBE RESULT POINTER"),0)),U,2)
SET BWTCBE(21)=$PIECE($GET(^BWCBE(+BWT("CBE RESULT POINTER"),0)),U,2)
+8 KILL BWTCBE("CBE PAID")
+9 IF BWTCBE(21)
IF BWTCBE(21)<3
SET BWTCBE("CBE PAID")=1
+10 SET BWTDATX=$PIECE(X,U,12)
+11 SET BWTDAT=$PIECE(BWTDAT,".")
+12 NEW XX,YY
+13 SET XX=BWTDATX
+14 SET YY=22
+15 IF BWTCBE(21)<3
DO F1^BWMDET
+16 DO INTV
+17 QUIT
INTV ;EP;CALCULATE INTERVAL BETWEEN EVENTS
+1 SET X1=BWTDAT
+2 SET X2=BWTDATX
+3 DO ^%DTC
+4 IF X<0
SET XMINUS=X
SET X=X*-1
+5 SET BWTINTV=X
+6 QUIT
CBEARRAY ;EP;CREATE ARRAY OF ALL VISITS FOR A PATIENT
+1 IF $DATA(^TMP("CBEARRAY",$JOB,BWTPATDA))
QUIT
+2 NEW X,Y,Z
+3 SET X=0
+4 FOR
SET X=$ORDER(^BWPCD("C",BWTPATDA,X))
IF 'X
QUIT
Begin DoDot:1
+5 SET Y=$GET(^BWPCD(X,0))
+6 IF '$PIECE(Y,U,12)
QUIT
+7 ;PATCH 8
IF "^27^28^29^25^26^30^31^32^33^34^38^"'[(U_$PIECE(Y,U,4)_U)
QUIT
+8 IF $PIECE(Y,U,5)=8!($PIECE(Y,U,5)=63)!'$PIECE(Y,U,5)
QUIT
+9 SET Z=$PIECE(Y,U,12)
+10 IF Z<2950101
QUIT
+11 SET ^TMP("CBEARRAY",$JOB,BWTPATDA,Z,X)=$PIECE(Y,U,1,12)
+12 IF $PIECE(Y,U,4)=27
SET ^TMP("CBEARRAY",$JOB,BWTPATDA,"CBE",Z,X)=$PIECE(Y,U,1,12)
End DoDot:1
+13 QUIT
ENDATE ;EP;CHECK ENROLLMENT DATE
+1 NEW BWTDAT,BWTDATX
+2 SET X1=$PIECE($GET(^BWP(BWTPATDA,0)),U,21)
+3 SET X2=$PIECE($GET(^BWPCD(+$GET(BWTPCDDA),0)),U,12)
+4 IF 'X1!'X2!(X1-1<X2)
QUIT
+5 DO ^%DTC
+6 IF X>59
SET BWTQUIT=""
DO USED^BWMDET
+7 QUIT
SEL ;EP;TO SELECT PATIENTS TO EXPORT ;PATCH 8
+1 FOR
DO S1
IF $DATA(BWQUIT)
QUIT
+2 KILL BWQUIT
+3 IF '$DATA(BWTSEL)
QUIT
+4 DO ^BWMDE
+5 QUIT
S1 SET DIC="^BWP("
+1 SET DIC(0)="AEMQZ"
+2 SET DIC("A")="Name of Patient to Export: "
+3 WRITE !
+4 DO ^DIC
+5 KILL DIC
+6 IF +Y<1
SET BWQUIT=""
QUIT
+7 SET BWTSEL(+Y)=""
+8 QUIT
MCARE ;EP;EVALUATE MEDICARE ELIGIBILITY; PATCH 8
+1 IF '$DATA(^AUPNMCR("B",BWDFN))
QUIT
+2 KILL BWQUIT
+3 NEW D,X,Y,Z
+4 SET X=0
+5 FOR
SET X=$ORDER(^AUPNMCR(BWDFN,11,X))
IF 'X!$DATA(BWQUIT)
QUIT
Begin DoDot:1
+6 SET Y=$GET(^AUPNMCR(BWDFN,11,X,0))
SET D=$PIECE(Y,U,2)
+7 IF $PIECE(Y,U,3)="B"
IF BWDT>+Y
IF BWDT<D!'D
SET BWQUIT=""
QUIT
End DoDot:1
+8 QUIT
PAID ;EP;
+1 IF "^1665^1860^1861^"'[(U_DUZ(2)_U)
QUIT
+2 IF DUZ(2)=1665
IF $PIECE(BWTP0,U,3)<2990401
SET BWTCBE(38)=1
QUIT
+3 IF DUZ(2)=1860!(DUZ(2)=1861)
IF $PIECE(BWTP0,U,3)<2991001
SET BWTCBE(38)=1
QUIT
+4 NEW AGE
+5 ;IHS/CMI/THL PATCH 8
IF $GET(BWTCBE(35))>8
Begin DoDot:1
+6 IF BWTCBE(35)<12
SET BWTCBE(38)=""
+7 IF '$TEST
SET BWTCBE(38)=2
End DoDot:1
QUIT
+8 SET AGE=$PIECE($GET(^DPT(+$PIECE(BWTP0,U,2),0)),U,3)
+9 SET AGE=$EXTRACT(DT,1,3)-$EXTRACT(AGE,1,3)
+10 IF AGE<50!(AGE>65)
SET AGE=$RANDOM(100)
+11 IF '$TEST
SET AGE=1
+12 IF AGE<26
SET BWTCBE(38)=1
+13 IF '$TEST
SET BWTCBE(38)=2
+14 QUIT
RACE(DATE) ;EP;FIND RACE FOR SELECTED SITES AFTER SELECTED DATES
+1 ;IHS/CIM/THL PATCH 8
+2 KILL BWQUIT
+3 IF $GET(DATE)=""
QUIT
+4 IF DUZ(2)'=1665
QUIT
+5 IF $EXTRACT(DATE,5,8)<1999
QUIT
+6 IF $EXTRACT(DATE,1,2)<10
QUIT
+7 ;$$RACE^BWMDE2
SET ZZ=""
+8 IF ZZ=4
QUIT
+9 SET BWQUIT=""
+10 QUIT
FILE ;FILE NEW EXPORT RECORD
+1 KILL BWQUIT
+2 IF DUZ(2)=1665
DO RACE(BWTCBE(37))
+3 ;IHS/CIM/THL PATCH 8
IF $DATA(BWQUIT)
KILL BWQUIT
QUIT
+4 DO MCARE
+5 ;IHS/CIM/THL PATCH 8
IF $DATA(BWQUIT)
KILL BWQUIT
QUIT
+6 ;S BWTTOT=BWTTOT+1
+7 DO ^BWUTL5
DO PCDVARS^BWUTL3(BWIEN,0,1)
+8 ;IHS/CMI/THL PATCH 8
IF '$DATA(NEW)
IF BWTCBE(21)>2
SET BWTCBE(22)=""
SET BWTCBE(23)=3
+9 ;IHS/CMI/THL PATCH 8
IF '$DATA(NEW)
IF BWTCBE(21)<3
IF '$GET(BWTCBE(22))
IF BWTCBE(37)
SET BWTCBE(22)=BWTCBE(37)
SET BWTCBE(23)=1
+10 SET BWMAM=1
+11 SET BWPAP=0
+12 SET $EXTRACT(BWCDC(BWIEN),1)=$$STSCR^BWMDE2
+13 SET $EXTRACT(BWCDC(BWIEN),3)=$$CNTYSCR^BWMDE2
+14 SET $EXTRACT(BWCDC(BWIEN),6)=$EXTRACT($PIECE($GET(^AUTTLOC(DUZ(2),0)),U,13),1,15)
+15 SET $EXTRACT(BWCDC(BWIEN),21)=$JUSTIFY($PIECE(BW0,U,10),5)
+16 IF BWPAP
SET $EXTRACT(BWCDC(BWIEN),26)=$JUSTIFY($PIECE(BW0,U,10),5)
+17 IF BWMAM
SET $EXTRACT(BWCDC(BWIEN),31)=$JUSTIFY($PIECE(BW0,U,10),5)
+18 SET $EXTRACT(BWCDC(BWIEN),40)=$$PATID^BWMDE2
+19 SET $EXTRACT(BWCDC(BWIEN),55)=$$RECID^BWMDE2
+20 SET $EXTRACT(BWCDC(BWIEN),61)=2
+21 SET $EXTRACT(BWCDC(BWIEN),62)=$$CNTYRES^BWMDE2
+22 SET $EXTRACT(BWCDC(BWIEN),65)=$$STRES^BWMDE2
+23 SET $EXTRACT(BWCDC(BWIEN),67)=$$ZIP^BWMDE2
+24 SET $EXTRACT(BWCDC(BWIEN),72)=$$DOB^BWMDE2
+25 ;$$RACE^BWMDE2
SET $EXTRACT(BWCDC(BWIEN),80)=""
+26 SET $EXTRACT(BWCDC(BWIEN),81)=2
+27 SET $EXTRACT(BWCDC(BWIEN),88)=$GET(BWTCBE(20))
+28 SET $EXTRACT(BWCDC(BWIEN),89)=$GET(BWTCBE(21))
+29 SET $EXTRACT(BWCDC(BWIEN),90)=$GET(BWTCBE(22))
+30 IF $GET(BWTCBE(21))
IF BWTCBE(21)<3
SET BWTCBE("CBE PAID")=1
+31 IF $GET(BWTCBE(21))
IF BWTCBE(21)>2
SET BWTCBE("CBE PAID")=""
+32 SET $EXTRACT(BWCDC(BWIEN),98)=$GET(BWTCBE("CBE PAID"))
+33 SET $EXTRACT(BWCDC(BWIEN),99)=3
+34 SET $EXTRACT(BWCDC(BWIEN),107)=" 9"
+35 SET $EXTRACT(BWCDC(BWIEN),129)=2
+36 SET $EXTRACT(BWCDC(BWIEN),139)=$GET(BWTCBE(32))
+37 SET $EXTRACT(BWCDC(BWIEN),140)=$GET(BWTCBE(33))
+38 SET $EXTRACT(BWCDC(BWIEN),146)=$SELECT($LENGTH($GET(BWTCBE(35)))=1:"0",1:"")_$GET(BWTCBE(35))
+39 SET $EXTRACT(BWCDC(BWIEN),148)=$GET(BWTCBE(36))
+40 SET $EXTRACT(BWCDC(BWIEN),149)=$GET(BWTCBE(37))
+41 ;IHS/CMI/THL PATCH 8
IF BWTCBE(35)<9
SET BWTCBE(38)=1
+42 IF '$TEST
IF BWTCBE(35)<12
SET BWTCBE(38)=""
+43 IF '$TEST
SET BWTCBE(38)=2
+44 DO PAID
+45 SET $EXTRACT(BWCDC(BWIEN),157)=$GET(BWTCBE(38))
+46 IF BWTCBE(38)'=1
SET ^TMP("BWTEST",$JOB,BWTPCDDA)=BWTCBE(38)
+47 SET $EXTRACT(BWCDC(BWIEN),158)=41
+48 IF $EXTRACT(BWCDC(BWIEN),148)=1
Begin DoDot:1
+49 SET $EXTRACT(BWCDC(BWIEN),243)=$GET(BWTCBE(52))
+50 SET $EXTRACT(BWCDC(BWIEN),244)=$GET(BWTCBE(53))
+51 SET $EXTRACT(BWCDC(BWIEN),245)=$GET(BWTCBE(54))
+52 SET $EXTRACT(BWCDC(BWIEN),246)=$GET(BWTCBE(55))
+53 SET $EXTRACT(BWCDC(BWIEN),247)=$GET(BWTCBE(56))
+54 SET $EXTRACT(BWCDC(BWIEN),248)=$SELECT($GET(BWTCBE(57)):BWTCBE(57),BWTCBE(36)=1:2,1:"")
+55 SET BWTCBE(58)=$TRANSLATE($GET(BWTCBE(58)),",",";")
+56 SET $EXTRACT(BWCDC(BWIEN),249)=$GET(BWTCBE(58))
+57 SET BWTCBE(59)=$TRANSLATE($GET(BWTCBE(59)),",",";")
+58 SET $EXTRACT(BWCDC(BWIEN),269)=$GET(BWTCBE(59))
+59 SET X=$EXTRACT(BWCDC(BWIEN),243,248)
+60 FOR J=1:1:6
IF $EXTRACT(X,J)=1
SET $EXTRACT(BWCDC(BWIEN),288)=1
QUIT
+61 IF X=222222
SET $EXTRACT(BWCDC(BWIEN),288)=2
+62 SET $EXTRACT(BWCDC(BWIEN),289)=$GET(BWTCBE(60))
+63 SET $EXTRACT(BWCDC(BWIEN),290)=$GET(BWTCBE(61))
+64 SET $EXTRACT(BWCDC(BWIEN),291)=$GET(BWTCBE(62))
+65 IF $GET(BWTCBE(63))
SET $EXTRACT(BWCDC(BWIEN),292)=$GET(BWTCBE(63))
+66 IF '$TEST
IF X=222222
SET $EXTRACT(BWCDC(BWIEN),292)=2
+67 SET $EXTRACT(BWCDC(BWIEN),293)=$GET(BWTCBE(64))
+68 SET $EXTRACT(BWCDC(BWIEN),301)=$GET(BWTCBE(65))
+69 SET $EXTRACT(BWCDC(BWIEN),302)=$GET(BWTCBE(66))
End DoDot:1
+70 SET $EXTRACT(BWCDC(BWIEN),310)=$$EOR^BWMDE21
+71 SET ^BWTMP($JOB,BWDFN,BWIEN)=BWCDC(BWIEN)
+72 ;S ^TMP("BWEXPORT",$J,BWDFN,BWIEN)=BWCDC(BWIEN)
+73 ;IHS/CIM/THL PATCH 8
IF '$DATA(BWSILENT)
USE IO(0)
WRITE "."
+74 KILL BWCDC(BWIEN),BWTCBE
+75 QUIT
SETUP ;EP;
+1 SET BWTCBE(20)=2
+2 SET BWTCBE(21)=1
+3 SET BWTCBE(23)=3
+4 SET BWTCBE(27)=" 9"
+5 SET BWTCBE(29)=2
+6 SET BWTCBE(32)=2
+7 SET BWTCBE(35)="01"
+8 ;S BWTCBE(35)="1" ;IHS/CMI/THL PATCH 7
+9 SET BWTCBE(36)=2
+10 QUIT
