BWMDET ;CMI/THL - NEW METHOD TO EXPORT CBE/MAM DATA;30-Oct-2003 12:00;PLS
;;2.0;WOMEN'S HEALTH;**5,6,7,8,9**;MAY 16, 1996
;; CDC EXPORT, BUILDS ASCII FIXED LENGTH RECORDS FOR EXPORT.
;IHS/CMI/THL - patch 5 new routine for new cdc format
;IHS/CMI/THL - patch 8 extensive rewrite for new cdc specifications
;;
;; 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
EN D EN1
EXIT K BWTPN,BWTPNDA,BWTPCDDA,BWTPATDA,BWTI,BWTJ,BWTPDAX,BWTDATE,BWTDAT,BWT0,BWT2,BWTDATX,BWTCBE,BWTP2,XMINUS
K ^TMP("BWTBW2",$J)
K ^TMP("BWTPCD",$J)
K ^TMP("CBEARRAY",$J)
Q
EN1 ;REVIEW ALL MAMMS AND CBE'S
D EXIT
F BWPNDA=25,26 D
.S BWTPCDDA=0
.F S BWTPCDDA=$O(^BWPCD("APCD",BWPNDA,BWTPCDDA)) Q:'BWTPCDDA D:'$D(^TMP("BWTPCD",$J,BWTPCDDA))
..Q:$P($G(^BWPCD(BWTPCDDA,3)),U,2)
..Q:$G(^BWPCD(BWTPCDDA,2))="" S BWTP2=^(2)
..S BW0=^BWPCD(BWTPCDDA,0)
..Q:$P(BW0,U,12)<BWBEGDT!($P(BW0,U,12)>BWENDDT)
..D PT(BWTPCDDA)
Q
PT(BWTPCDDA) ;EVALUATE ALL MAMM'S AND CBE'S FOR EACH PATIENT
S X=BW0
S BWTPATDA=$P(X,U,2)
Q:'BWTPATDA
S BWDFN=BWTPATDA
I $D(BWTSEL) Q:'$D(BWTSEL(+BWDFN)) ;EXPORT FOR SELECTED PATIENTS
Q:'$$INCCHK^BWMDE(BWDFN,$P(BW0,U,12))
Q:$P(X,U,3)<BWBEGDT
Q:$P(X,U,3)>BWENDDT
I $G(BWCUTF),BWCUTF>$P($$AGE^BWUTL1(BWTPATDA),"y") Q
I $G(BWCUTO),BWCUTO<$P($$AGE^BWUTL1(BWTPATDA),"y") Q
I $E($G(^DPT(BWTPATDA,0)),1,5)="DEMO," U 0 W !,BWTPATDA,?10,$P(^DPT(BWTPATDA,0),U)," disregarded." Q
EVAL ;EVALUATE MAMMOGRAM
K BWTQUIT
D ENDATE
I $D(BWTQUIT) K BWTQUIT Q
K BWT
S X=BW0
I $P(X,U,5)=8!($P(X,U,5)=63)!'$P(X,U,5) D USED Q
I $P($G(^BWDIAG(+$P(X,U,5),0)),U,25)>6 D USED Q
D SETUP
S BWTDAT=$P(BW0,U,12)
I BWTDAT<2950101 D USED Q
S BWTCBE(35)=$P($G(^BWDIAG(+$P(BW0,U,5),0)),U,25)
Q:BWTCBE(35)=9!'BWTCBE(35)
N XX,YY
S XX=BWTDAT
S YY=37
D F1
D USED
D PAGE2
S BWIEN=BWTPCDDA
D FILE
K BWTP2,BWTINTV,XMINUS
Q
PAGE2 ;SET PAGE 2 VALUES
S BWTCBE(61)=$P(BW0,U,31)
K BWTQUIT
N J,X
F J=20:1:35 Q:$D(BWTQUIT) S X=$P(BWTP2,U,J) D:X]""
.I J=20 S BWTCBE(36)=X I X=1 D DXWU
.I J=20,X=2 D Q
..S BWTCBE(21)=$P($G(^BWCBE(+$P(BWTP2,U,32),0)),U,2)
..S X=$P(BWTP2,U,33)
..S XX=X
..S YY=22
..D F1:BWTCBE(21)<3
..F K=52:1:66 S BWTCBE(K)=""
..S BWTQUIT=""
.I J=21 S BWTCBE(57)=1,BWTCBE(58)=$E(X,1,20),BWTCBE(59)=$E(X,21,40) Q
.I J=22 S BWTCBE(63)=X,BWTCBE(64)="" Q
.I J=23,BWTCBE(63)=1 S XX=X,YY=64 D F1 Q
.I J=24 S BWTCBE(65)=X Q
.I J=25 S XX=X,YY=66 D F1 Q
.I J=26,X S BWTCBE(53)=X Q
.I J=27,X S BWTCBE(54)=X Q
.I J=28,X S BWTCBE(55)=X Q
.I J=29,X S BWTCBE(56)=X Q
.I J=30 S BWTCBE(60)=X S:X>2 BWTCBE(65)="" Q
.I J=31 S BWTCBE(62)=X Q
.I J=32 D Q
..S BWTCBE(21)=$P($G(^BWCBE(+X,0)),U,2)
.I J=33,X,BWTCBE(21)<3 S XX=X,YY=22 D F1 Q
.I J=34 S BWTCBE(52)=X Q
.I J=35 S BWTCBE(20)=X
I $P(BWTP2,U,32)>2 S BWTCBE(22)=""
K BWTQUIT
Q
F1 ; EP
Q:'$G(XX)!'$G(YY)
Q:XX'?7N
S:XX<2950101 XX=2950101
S BWTCBE(YY)=$E(XX,4,7)_($E(XX,1,3)+1700)
Q
DXWU ;DIAGNOSTIC WORKUP PLANNED
S BWTCBE(36)=1
F X=52:1:57,63 S:$G(BWTCBE(X))="" BWTCBE(X)=2
Q
USED ;EP;ENTRY EVALUATED AND SHOULD NOT BE USED AGAIN
S ^TMP("BWTPCD",$J,BWTPCDDA)=""
Q
MCARE ;EP;EVALUATE MEDICARE ELIGIBILITY; PATCH 8
Q:BWDT<3000401!'$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<Y!'Y S BWQUIT="" Q
Q
PAID ;EP; PATCH 8
Q:"^1665^1860^1861^"'[(U_DUZ(2)_U)
I '$E(BWCDC(BWIEN),149,156) S BWTCBE(38)="" Q
I DUZ(2)=1665,$P(BW0,U,3)<2990401 S BWTCBE(38)=1 Q
I DUZ(2)=1860!(DUZ(2)=1861),$P(BW0,U,3)<2991001 S BWTCBE(38)=1 Q
N AGE,BW
S BW=$E(BWCDC(BWIEN),146,147)
I $E(BW,2)'?1N S BWTCBE(38)="" Q
S BW=$S($E(BW)'?1N:$E(BW,2),1:BW)
I BW>8 D Q
.I BW<12 S BWTCBE(38)=""
.E S BWTCBE(38)=2
S AGE=$P($G(^DPT(+$P(BW0,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
; Default to American Indian or Alaskan Native
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
S BWDT=$P(BW0,U,12)
D MCARE
I $D(BWQUIT) K BWQUIT Q ;IHS/CIM/THL PATCH 8
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)=$S($G(BWTCBE(38)):BWTCBE(38),$E(BWCDC(BWIEN),149,156):1,1:"")
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 "."
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
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
BWMDET ;CMI/THL - NEW METHOD TO EXPORT CBE/MAM DATA;30-Oct-2003 12:00;PLS
+1 ;;2.0;WOMEN'S HEALTH;**5,6,7,8,9**;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 ;IHS/CMI/THL - patch 8 extensive rewrite for new cdc specifications
+5 ;;
+6 ;; BWTCBE(35) = CDC DX CODE
+7 ;; BWTCBE(36) = DX WORKUP PLANNED CODE
+8 ;; Each of the BWTCBE(n) variables corresponds to the 67 field of the
+9 ;; CDC exprt record per version 2.4
+10 ;EVALUATE EACH PROCEDURE FOR CDC EXPORT
EN DO EN1
EXIT KILL BWTPN,BWTPNDA,BWTPCDDA,BWTPATDA,BWTI,BWTJ,BWTPDAX,BWTDATE,BWTDAT,BWT0,BWT2,BWTDATX,BWTCBE,BWTP2,XMINUS
+1 KILL ^TMP("BWTBW2",$JOB)
+2 KILL ^TMP("BWTPCD",$JOB)
+3 KILL ^TMP("CBEARRAY",$JOB)
+4 QUIT
EN1 ;REVIEW ALL MAMMS AND CBE'S
+1 DO EXIT
+2 FOR BWPNDA=25,26
Begin DoDot:1
+3 SET BWTPCDDA=0
+4 FOR
SET BWTPCDDA=$ORDER(^BWPCD("APCD",BWPNDA,BWTPCDDA))
IF 'BWTPCDDA
QUIT
IF '$DATA(^TMP("BWTPCD",$JOB,BWTPCDDA))
Begin DoDot:2
+5 IF $PIECE($GET(^BWPCD(BWTPCDDA,3)),U,2)
QUIT
+6 IF $GET(^BWPCD(BWTPCDDA,2))=""
QUIT
SET BWTP2=^(2)
+7 SET BW0=^BWPCD(BWTPCDDA,0)
+8 IF $PIECE(BW0,U,12)<BWBEGDT!($PIECE(BW0,U,12)>BWENDDT)
QUIT
+9 DO PT(BWTPCDDA)
End DoDot:2
End DoDot:1
+10 QUIT
PT(BWTPCDDA) ;EVALUATE ALL MAMM'S AND CBE'S FOR EACH PATIENT
+1 SET X=BW0
+2 SET BWTPATDA=$PIECE(X,U,2)
+3 IF 'BWTPATDA
QUIT
+4 SET BWDFN=BWTPATDA
+5 ;EXPORT FOR SELECTED PATIENTS
IF $DATA(BWTSEL)
IF '$DATA(BWTSEL(+BWDFN))
QUIT
+6 IF '$$INCCHK^BWMDE(BWDFN,$PIECE(BW0,U,12))
QUIT
+7 IF $PIECE(X,U,3)<BWBEGDT
QUIT
+8 IF $PIECE(X,U,3)>BWENDDT
QUIT
+9 IF $GET(BWCUTF)
IF BWCUTF>$PIECE($$AGE^BWUTL1(BWTPATDA),"y")
QUIT
+10 IF $GET(BWCUTO)
IF BWCUTO<$PIECE($$AGE^BWUTL1(BWTPATDA),"y")
QUIT
+11 IF $EXTRACT($GET(^DPT(BWTPATDA,0)),1,5)="DEMO,"
USE 0
WRITE !,BWTPATDA,?10,$PIECE(^DPT(BWTPATDA,0),U)," disregarded."
QUIT
EVAL ;EVALUATE MAMMOGRAM
+1 KILL BWTQUIT
+2 DO ENDATE
+3 IF $DATA(BWTQUIT)
KILL BWTQUIT
QUIT
+4 KILL BWT
+5 SET X=BW0
+6 IF $PIECE(X,U,5)=8!($PIECE(X,U,5)=63)!'$PIECE(X,U,5)
DO USED
QUIT
+7 IF $PIECE($GET(^BWDIAG(+$PIECE(X,U,5),0)),U,25)>6
DO USED
QUIT
+8 DO SETUP
+9 SET BWTDAT=$PIECE(BW0,U,12)
+10 IF BWTDAT<2950101
DO USED
QUIT
+11 SET BWTCBE(35)=$PIECE($GET(^BWDIAG(+$PIECE(BW0,U,5),0)),U,25)
+12 IF BWTCBE(35)=9!'BWTCBE(35)
QUIT
+13 NEW XX,YY
+14 SET XX=BWTDAT
+15 SET YY=37
+16 DO F1
+17 DO USED
+18 DO PAGE2
+19 SET BWIEN=BWTPCDDA
+20 DO FILE
+21 KILL BWTP2,BWTINTV,XMINUS
+22 QUIT
PAGE2 ;SET PAGE 2 VALUES
+1 SET BWTCBE(61)=$PIECE(BW0,U,31)
+2 KILL BWTQUIT
+3 NEW J,X
+4 FOR J=20:1:35
IF $DATA(BWTQUIT)
QUIT
SET X=$PIECE(BWTP2,U,J)
IF X]""
Begin DoDot:1
+5 IF J=20
SET BWTCBE(36)=X
IF X=1
DO DXWU
+6 IF J=20
IF X=2
Begin DoDot:2
+7 SET BWTCBE(21)=$PIECE($GET(^BWCBE(+$PIECE(BWTP2,U,32),0)),U,2)
+8 SET X=$PIECE(BWTP2,U,33)
+9 SET XX=X
+10 SET YY=22
+11 IF BWTCBE(21)<3
DO F1
+12 FOR K=52:1:66
SET BWTCBE(K)=""
+13 SET BWTQUIT=""
End DoDot:2
QUIT
+14 IF J=21
SET BWTCBE(57)=1
SET BWTCBE(58)=$EXTRACT(X,1,20)
SET BWTCBE(59)=$EXTRACT(X,21,40)
QUIT
+15 IF J=22
SET BWTCBE(63)=X
SET BWTCBE(64)=""
QUIT
+16 IF J=23
IF BWTCBE(63)=1
SET XX=X
SET YY=64
DO F1
QUIT
+17 IF J=24
SET BWTCBE(65)=X
QUIT
+18 IF J=25
SET XX=X
SET YY=66
DO F1
QUIT
+19 IF J=26
IF X
SET BWTCBE(53)=X
QUIT
+20 IF J=27
IF X
SET BWTCBE(54)=X
QUIT
+21 IF J=28
IF X
SET BWTCBE(55)=X
QUIT
+22 IF J=29
IF X
SET BWTCBE(56)=X
QUIT
+23 IF J=30
SET BWTCBE(60)=X
IF X>2
SET BWTCBE(65)=""
QUIT
+24 IF J=31
SET BWTCBE(62)=X
QUIT
+25 IF J=32
Begin DoDot:2
+26 SET BWTCBE(21)=$PIECE($GET(^BWCBE(+X,0)),U,2)
End DoDot:2
QUIT
+27 IF J=33
IF X
IF BWTCBE(21)<3
SET XX=X
SET YY=22
DO F1
QUIT
+28 IF J=34
SET BWTCBE(52)=X
QUIT
+29 IF J=35
SET BWTCBE(20)=X
End DoDot:1
+30 IF $PIECE(BWTP2,U,32)>2
SET BWTCBE(22)=""
+31 KILL BWTQUIT
+32 QUIT
F1 ; EP
+1 IF '$GET(XX)!'$GET(YY)
QUIT
+2 IF XX'?7N
QUIT
+3 IF XX<2950101
SET XX=2950101
+4 SET BWTCBE(YY)=$EXTRACT(XX,4,7)_($EXTRACT(XX,1,3)+1700)
+5 QUIT
DXWU ;DIAGNOSTIC WORKUP PLANNED
+1 SET BWTCBE(36)=1
+2 FOR X=52:1:57,63
IF $GET(BWTCBE(X))=""
SET BWTCBE(X)=2
+3 QUIT
USED ;EP;ENTRY EVALUATED AND SHOULD NOT BE USED AGAIN
+1 SET ^TMP("BWTPCD",$JOB,BWTPCDDA)=""
+2 QUIT
MCARE ;EP;EVALUATE MEDICARE ELIGIBILITY; PATCH 8
+1 IF BWDT<3000401!'$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<Y!'Y
SET BWQUIT=""
QUIT
End DoDot:1
+8 QUIT
PAID ;EP; PATCH 8
+1 IF "^1665^1860^1861^"'[(U_DUZ(2)_U)
QUIT
+2 IF '$EXTRACT(BWCDC(BWIEN),149,156)
SET BWTCBE(38)=""
QUIT
+3 IF DUZ(2)=1665
IF $PIECE(BW0,U,3)<2990401
SET BWTCBE(38)=1
QUIT
+4 IF DUZ(2)=1860!(DUZ(2)=1861)
IF $PIECE(BW0,U,3)<2991001
SET BWTCBE(38)=1
QUIT
+5 NEW AGE,BW
+6 SET BW=$EXTRACT(BWCDC(BWIEN),146,147)
+7 IF $EXTRACT(BW,2)'?1N
SET BWTCBE(38)=""
QUIT
+8 SET BW=$SELECT($EXTRACT(BW)'?1N:$EXTRACT(BW,2),1:BW)
+9 IF BW>8
Begin DoDot:1
+10 IF BW<12
SET BWTCBE(38)=""
+11 IF '$TEST
SET BWTCBE(38)=2
End DoDot:1
QUIT
+12 SET AGE=$PIECE($GET(^DPT(+$PIECE(BW0,U,2),0)),U,3)
+13 SET AGE=$EXTRACT(DT,1,3)-$EXTRACT(AGE,1,3)
+14 IF AGE<50!(AGE>65)
SET AGE=$RANDOM(100)
+15 IF '$TEST
SET AGE=1
+16 IF AGE<26
SET BWTCBE(38)=1
+17 IF '$TEST
SET BWTCBE(38)=2
+18 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 ; Default to American Indian or Alaskan Native
+8 ;$$RACE^BWMDE2
SET ZZ=""
+9 IF ZZ=4
QUIT
+10 SET BWQUIT=""
+11 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 SET BWDT=$PIECE(BW0,U,12)
+5 DO MCARE
+6 ;IHS/CIM/THL PATCH 8
IF $DATA(BWQUIT)
KILL BWQUIT
QUIT
+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)=$SELECT($GET(BWTCBE(38)):BWTCBE(38),$EXTRACT(BWCDC(BWIEN),149,156):1,1:"")
+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 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
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
