BWMDE1 ;IHS/ANMC/MWR - COMPILED MDE EXPORT ROUTINE.;10-Apr-2003 13:10;PLS
;;2.0;WOMEN'S HEALTH;**5,7,8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CDC EXPORT, BUILDS ASCII FIXED LENGTH RECORDS FOR EXPORT.
;
;IHS/CMI/THL - new cdc format patch 5
;IHS/CMI/THL - removed historic reference to old format - patch 7
;IHS/CMI/THL - use new routine BWMDE21 where appropriate - patch 7
;
BUILD(BWIEN,BWCDCV) ; EP
; Call with BWIEN = ien of entry in file
; BWCDCV = CDC MDE version number (4.1, 5.0)
;
N BWBSU,BWCBE,BWCDC,BWQUIT,BWRACE,BWX,I,J,X
F I=0,.3,2 S BWIEN(I)=$G(^BWPCD(BWIEN,I))
;
D MCARE^BWMDET1 ;IHS/CIM/THL PATCH 8
I $D(BWQUIT) Q
;
D ^BWUTL5,PCDVARS^BWUTL3(BWIEN,0,1)
I 'BWMAM,'BWPAP Q
;
; Bethesda System Used
S BWBSU=$$BSU^BWMDEU($P(BWIEN(0),"^",12),DUZ(2))
;
S $E(BWCDC,1)=$$STSCR^BWMDE2(+DUZ(2))
S $E(BWCDC,3)=$$CNTYSCR^BWMDE2(+DUZ(2))
S $E(BWCDC,6)=$E($P($G(^AUTTLOC(DUZ(2),0)),U,13),1,15)
S BWX=$P(BWIEN(0),U,10)
I BWX'="" D
. S BWX=$$RJ^XLFSTR(BWX,5,"0")
. S $E(BWCDC,21)=BWX
. I BWPAP S $E(BWCDC,26)=BWX
. I BWMAM S $E(BWCDC,31)=BWX
S $E(BWCDC,40)=$$PATID^BWMDE2
S $E(BWCDC,55)=$$RECID^BWMDE2
S $E(BWCDC,61)=2
S $E(BWCDC,65)=$$STRES^BWMDE2
S $E(BWCDC,67)=$$ZIP^BWMDE2
S $E(BWCDC,72)=$$DOB^BWMDE2
;
; Code race and Hispanic/Latino origin based on MDE version
; If MDE v4.1 then return single race in position 80
; If MDE v5.0 then return up to 6 races in positions 82-87
; Hispanic origin returned in position 81
D RACE^BWMDEU(BWDFN,BWCDCV,.BWRACE)
I BWCDCV=41 D
. S I=$O(BWRACE(0)) Q:'I
. S $E(BWCDC,80)=BWRACE(I)
S $E(BWCDC,81)=$$HISP^BWMDEU(BWDFN)
I BWCDCV=50 D
. S (I,J)=0
. F S I=$O(BWRACE(I)) Q:'I S J=J+1,$E(BWCDC,J+81)=BWRACE(I) Q:J>6
;
; IHS/CIM/THL PATCH 8
I DUZ(2)=1665,BWPAP,$P(BWIEN(0),"^",12)>2990930 D Q:$D(BWQUIT)
. K BWQUIT
. I BWCDCV=41 S:$E(BWCDC,80)'=4 BWQUIT="" Q
. I BWCDCV=50,$E(BWCDC,82,87)'["5" S BWQUIT=""
;
S $E(BWCDC,88)=$$BRSYMP^BWMDE2
S BWCBE=$$CBE^BWMDE2
S $E(BWCDC,89)=BWCBE
S $E(BWCDC,90)=$S(BWCBE&(BWCBE<3):$$CBEDT^BWMDE2,1:"")
S $E(BWCDC,98)=$S(BWCBE&(BWCBE<3):1,1:"")
S $E(BWCDC,99)=$$PPREV^BWMDE2
;
I BWPAP D
. N BWPDT,BWPPAY,BWPRESLT,BWPRTEXT,BWPWKUP,BWSAPT
. S BWPRESLT=$$PRESLT^BWMDEU(BWIEN,BWBSU)
. S BWPRTEXT=$$POTHR^BWMDEU(BWIEN,BWBSU,BWPRESLT)
. S BWPDT=$$PSCRDT^BWMDEU($P(BWIEN(0),"^",12),BWBSU,BWPRESLT)
. S BWPPAY=$$PPAY^BWMDEU(BWBSU,BWPRESLT)
. S BWPWKUP=$$PWKUP^BWMDEU(BWIEN,BWBSU,BWPRESLT)
. S BWSAPT=$$SAPT^BWMDEU(BWIEN,BWBSU,BWCDCV)
. S $E(BWCDC,100,105)=$$PPREVDT^BWMDE2
. I BWCDCV=50 D Q
. . S $E(BWCDC,106)=BWBSU
. . S $E(BWCDC,107)=BWSAPT
. . I BWBSU=1 S $E(BWCDC,108,109)=BWPRESLT
. . S $E(BWCDC,110)=$P(BWIEN(.3),"^",2)
. . I BWBSU=2 S $E(BWCDC,111,112)=BWPRESLT
. . S $E(BWCDC,113,132)=BWPRTEXT
. . S $E(BWCDC,133)=BWPWKUP
. . S $E(BWCDC,134,141)=BWPDT
. . S $E(BWCDC,142)=BWPPAY
. . S $E(BWCDC,143)=3
. . S $E(BWCDC,150,151)="08"
. . S $E(BWCDC,152)=2
. I BWCDCV=41 D
. . S $E(BWCDC,106)=BWSAPT
. . S $E(BWCDC,107,108)=BWPRESLT
. . S $E(BWCDC,109,128)=BWPRTEXT
. . S $E(BWCDC,129)=BWPWKUP
. . S $E(BWCDC,130,137)=BWPDT
. . S $E(BWCDC,138)=BWPPAY
. . S $E(BWCDC,139)=3
. . S $E(BWCDC,146,147)="08"
. . S $E(BWCDC,148)=2
;
I BWMAM D
. N BWMDT,BWMRESLT,BWMWKUP,BWPAID,BWPMAMDT
. S BWPMAMDT=$$MPREVDT^BWMDEU(BWIEN)
. S BWMRESLT=$$MRESLT^BWMDEU2
. S BWMWKUP=$$MWKUP^BWMDEU2
. S BWMDT=$$MSCRDT^BWMDEU($P(BWIEN(0),"^",12),BWMRESLT)
. S BWPAID=$$PAID^BWMDEU(BWDFN,$P(BWIEN(0),U,3),BWMDT,BWMRESLT,+DUZ(2))
. I BWCDCV=50 D Q
. . S $E(BWCDC,106)=BWBSU
. . I BWBSU=1 S $E(BWCDC,108,109)="09"
. . I BWBSU=2 S $E(BWCDC,111,112)="09"
. . S $E(BWCDC,133)=2
. . S $E(BWCDC,143)=$S(BWPMAMDT<1:3,1:1)
. . I $E(BWCDC,143)=1 S $E(BWCDC,144,149)=BWPMAMDT
. . S $E(BWCDC,150,151)=BWMRESLT
. . S $E(BWCDC,152)=BWMWKUP
. . S $E(BWCDC,153,160)=BWMDT
. . S $E(BWCDC,161)=BWPAID
. I BWCDCV=41 D
. . S $E(BWCDC,107)="09"
. . S $E(BWCDC,129)=2
. . S $E(BWCDC,139)=$S(BWPMAMDT<1:3,1:1)
. . I $E(BWCDC,139)=1 S $E(BWCDC,140,145)=BWPMAMDT
. . S $E(BWCDC,146,147)=BWMRESLT
. . S $E(BWCDC,148)=BWMWKUP
. . S $E(BWCDC,149,156)=BWMDT
. . S $E(BWCDC,157)=BWPAID
;
; Abnormal Pap smear/Diagnostic workup section
I BWPAP D
. I BWCDCV=50,$E(BWCDC,133)='1 Q
. I BWCDCV=41,$E(BWCDC,129)'=1 Q
. N BWCDBX,BWCDXPAY,BWCWOBX,BWPABN,BWPFDXDT,BWPFNDX,BWPSTFDX,BWPSTGDX,BWPSTTX,BWPSTXDT
. S BWPABN=$$PABN^BWMDEU(BWBSU,$S(BWBSU=50:$E(BWCDC,111,112),BWBSU=41:$E(BWCDC,108,109),1:""))
. S BWCWOBX=$$CONOBX^BWMDEU2
. S BWCDBX=$$COLPBX^BWMDEU2
. S BWCDXPAY=$$CDXPAID^BWMDEU2
. S BWPFNDX=$$PFNDX^BWMDEU2
. S BWPSTGDX=$$PSTGDX^BWMDEU2(BWPFNDX,BWC0)
. S BWPSTGDX(1)=$$PFNDXO^BWMDEU2
. S BWPSTFDX=$P(BWIEN(2),"^",22)
. S BWPFDXDT=$$CDCDT^BWMDEU2($P(BWIEN(2),"^",23))
. S BWPSTTX=$P(BWIEN(2),"^",24)
. S BWPSTXDT=$$CDCDT^BWMDEU2($P(BWIEN(2),"^",25))
. I BWCDCV=50,$E(BWCDC,133)=1 D Q
. . S $E(BWCDC,169)=BWCWOBX
. . S $E(BWCDC,170)=BWCDBX
. . S $E(BWCDC,171)=$S($P(BWIEN(2),"^",21)="":2,1:1)
. . S $E(BWCDC,172,191)=$E($P(BWIEN(2),"^",21),1,20)
. . S $E(BWCDC,192,210)=""
. . S $E(BWCDC,211)=BWCDXPAY
. . S $E(BWCDC,212)=BWPFNDX
. . S $E(BWCDC,213)=BWPSTGDX
. . S $E(BWCDC,214,233)=BWPSTGDX(1)
. . S $E(BWCDC,234)=BWPSTFDX
. . S $E(BWCDC,235,242)=BWPFDXDT
. . S $E(BWCDC,243)=BWPSTTX
. . S $E(BWCDC,244,251)=BWPSTXDT
. I BWCDCV=41,$E(BWCDC,129)=1 D
. . S $E(BWCDC,160)=BWCWOBX
. . S $E(BWCDC,161)=BWCDBX
. . S $E(BWCDC,162)=$S($P(BWIEN(2),"^",21)="":2,1:1)
. . S $E(BWCDC,163)=$E($P(BWIEN(2),"^",21),1,20)
. . S $E(BWCDC,183)=""
. . S $E(BWCDC,202)=BWCDXPAY
. . S $E(BWCDC,203)=BWPFNDX
. . S $E(BWCDC,204)=BWPSTGDX
. . S $E(BWCDC,205)=BWPSTGDX(1)
. . S $E(BWCDC,225)=BWPSTFDX
. . S $E(BWCDC,226)=BWPFDXDT
. . S $E(BWCDC,234)=BWPSTTX
. . S $E(BWCDC,235)=BWPSTXDT
;
; Abnormal Initial Mammogram or CLinical Breast Exam/Diagnostic workup section
I BWMAM D
. I BWCDCV=50,$E(BWCDC,152)'=1 Q
. I BWCDCV=41,$E(BWCDC,148)'=1 Q
. N BWBDXPAY,BWMFDXDT,BWMFINDL,BWMFNDX,BWMFUDXV,BWMLUMP,BWMRBREX,BWMSTFDX,BWMSTGDX,BWMULTRA,BWSRGDX,BWMSTTX,BWMSTXDT,BWMTMRSZ
. S BWMFUDXV=$P(BWIEN(2),"^",34)
. S BWMRBREX=$P(BWIEN(2),"^",26)
. S BWMULTRA=$P(BWIEN(2),"^",27)
. S BWMLUMP=$P(BWIEN(2),"^",28)
. S BWMFINDL=$P(BWIEN(2),"^",29)
. S BWBDXPAY=$$BDXPAID^BWMDEU2
. S BWMFNDX=$P(BWIEN(2),"^",30)
. S BWMSTGDX=$P(BWIEN(0),"^",31)
. S BWMTMRSZ=$P(BWIEN(2),"^",31)
. S BWMSTFDX=$P(BWIEN(2),"^",22)
. S BWMFDXDT=$$CDCDT^BWMDEU2($P(BWIEN(2),"^",23))
. S BWMSTTX=$P(BWIEN(2),"^",24)
. S BWMSTXDT=$$CDCDT^BWMDEU2($P(BWIEN(2),"^",25))
. I BWCDCV=50,$E(BWCDC,152)=1 D Q
. . S $E(BWCDC,257)=BWMFUDXV
. . S $E(BWCDC,258)=BWMRBREX
. . S $E(BWCDC,259)=BWMULTRA
. . S $E(BWCDC,260)=BWMLUMP
. . S $E(BWCDC,261)=BWMFINDL
. . S $E(BWCDC,262)=$S($P(BWIEN(2),"^",21)="":2,1:1)
. . S $E(BWCDC,263,282)=$E($P(BWIEN(2),"^",21),1,20)
. . S $E(BWCDC,282,301)=""
. . S $E(BWCDC,302)=BWBDXPAY
. . S $E(BWCDC,303)=BWMFNDX
. . S $E(BWCDC,304)=BWMSTGDX
. . S $E(BWCDC,305)=BWMTMRSZ
. . S $E(BWCDC,306)=BWMSTFDX
. . S $E(BWCDC,307,314)=BWMFDXDT
. . S $E(BWCDC,315)=BWMSTTX
. . S $E(BWCDC,316,323)=BWMSTXDT
. I BWCDCV=41,$E(BWCDC,148)=1 D
. . S $E(BWCDC,243)=BWMFUDXV
. . S $E(BWCDC,244)=BWMRBREX
. . S $E(BWCDC,245)=BWMULTRA
. . S $E(BWCDC,246)=BWMLUMP
. . S $E(BWCDC,247)=BWMFINDL
. . S $E(BWCDC,248)=$S($P(BWIEN(2),"^",21)="":2,1:1)
. . S $E(BWCDC,249,268)=$E($P(BWIEN(2),"^",21),1,20)
. . S $E(BWCDC,269,287)=""
. . S $E(BWCDC,288)=BWBDXPAY
. . S $E(BWCDC,289)=BWMFNDX
. . S $E(BWCDC,290)=BWMSTGDX
. . S $E(BWCDC,291)=BWMTMRSZ
. . S $E(BWCDC,292)=BWMSTFDX
. . S $E(BWCDC,293)=BWMFDXDT
. . S $E(BWCDC,301)=BWMSTTX
. . S $E(BWCDC,302)=BWMSTXDT
;
I BWCDCV=41 D
. S $E(BWCDC,158,159)=BWCDCV
. S $E(BWCDC,310,311)=$$EOR^BWMDE21
I BWCDCV=50 D
. S $E(BWCDC,162,163)=BWCDCV
. S $E(BWCDC,329,330)=$$EOR^BWMDE21
S ^BWTMP($J,BWDFN,BWIEN)=BWCDC
;
I '$D(BWSILENT),'$D(ZTQUEUED) U IO(0) W "."
Q
BWMDE1 ;IHS/ANMC/MWR - COMPILED MDE EXPORT ROUTINE.;10-Apr-2003 13:10;PLS
+1 ;;2.0;WOMEN'S HEALTH;**5,7,8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CDC EXPORT, BUILDS ASCII FIXED LENGTH RECORDS FOR EXPORT.
+4 ;
+5 ;IHS/CMI/THL - new cdc format patch 5
+6 ;IHS/CMI/THL - removed historic reference to old format - patch 7
+7 ;IHS/CMI/THL - use new routine BWMDE21 where appropriate - patch 7
+8 ;
BUILD(BWIEN,BWCDCV) ; EP
+1 ; Call with BWIEN = ien of entry in file
+2 ; BWCDCV = CDC MDE version number (4.1, 5.0)
+3 ;
+4 NEW BWBSU,BWCBE,BWCDC,BWQUIT,BWRACE,BWX,I,J,X
+5 FOR I=0,.3,2
SET BWIEN(I)=$GET(^BWPCD(BWIEN,I))
+6 ;
+7 ;IHS/CIM/THL PATCH 8
DO MCARE^BWMDET1
+8 IF $DATA(BWQUIT)
QUIT
+9 ;
+10 DO ^BWUTL5
DO PCDVARS^BWUTL3(BWIEN,0,1)
+11 IF 'BWMAM
IF 'BWPAP
QUIT
+12 ;
+13 ; Bethesda System Used
+14 SET BWBSU=$$BSU^BWMDEU($PIECE(BWIEN(0),"^",12),DUZ(2))
+15 ;
+16 SET $EXTRACT(BWCDC,1)=$$STSCR^BWMDE2(+DUZ(2))
+17 SET $EXTRACT(BWCDC,3)=$$CNTYSCR^BWMDE2(+DUZ(2))
+18 SET $EXTRACT(BWCDC,6)=$EXTRACT($PIECE($GET(^AUTTLOC(DUZ(2),0)),U,13),1,15)
+19 SET BWX=$PIECE(BWIEN(0),U,10)
+20 IF BWX'=""
Begin DoDot:1
+21 SET BWX=$$RJ^XLFSTR(BWX,5,"0")
+22 SET $EXTRACT(BWCDC,21)=BWX
+23 IF BWPAP
SET $EXTRACT(BWCDC,26)=BWX
+24 IF BWMAM
SET $EXTRACT(BWCDC,31)=BWX
End DoDot:1
+25 SET $EXTRACT(BWCDC,40)=$$PATID^BWMDE2
+26 SET $EXTRACT(BWCDC,55)=$$RECID^BWMDE2
+27 SET $EXTRACT(BWCDC,61)=2
+28 SET $EXTRACT(BWCDC,65)=$$STRES^BWMDE2
+29 SET $EXTRACT(BWCDC,67)=$$ZIP^BWMDE2
+30 SET $EXTRACT(BWCDC,72)=$$DOB^BWMDE2
+31 ;
+32 ; Code race and Hispanic/Latino origin based on MDE version
+33 ; If MDE v4.1 then return single race in position 80
+34 ; If MDE v5.0 then return up to 6 races in positions 82-87
+35 ; Hispanic origin returned in position 81
+36 DO RACE^BWMDEU(BWDFN,BWCDCV,.BWRACE)
+37 IF BWCDCV=41
Begin DoDot:1
+38 SET I=$ORDER(BWRACE(0))
IF 'I
QUIT
+39 SET $EXTRACT(BWCDC,80)=BWRACE(I)
End DoDot:1
+40 SET $EXTRACT(BWCDC,81)=$$HISP^BWMDEU(BWDFN)
+41 IF BWCDCV=50
Begin DoDot:1
+42 SET (I,J)=0
+43 FOR
SET I=$ORDER(BWRACE(I))
IF 'I
QUIT
SET J=J+1
SET $EXTRACT(BWCDC,J+81)=BWRACE(I)
IF J>6
QUIT
End DoDot:1
+44 ;
+45 ; IHS/CIM/THL PATCH 8
+46 IF DUZ(2)=1665
IF BWPAP
IF $PIECE(BWIEN(0),"^",12)>2990930
Begin DoDot:1
+47 KILL BWQUIT
+48 IF BWCDCV=41
IF $EXTRACT(BWCDC,80)'=4
SET BWQUIT=""
QUIT
+49 IF BWCDCV=50
IF $EXTRACT(BWCDC,82,87)'["5"
SET BWQUIT=""
End DoDot:1
IF $DATA(BWQUIT)
QUIT
+50 ;
+51 SET $EXTRACT(BWCDC,88)=$$BRSYMP^BWMDE2
+52 SET BWCBE=$$CBE^BWMDE2
+53 SET $EXTRACT(BWCDC,89)=BWCBE
+54 SET $EXTRACT(BWCDC,90)=$SELECT(BWCBE&(BWCBE<3):$$CBEDT^BWMDE2,1:"")
+55 SET $EXTRACT(BWCDC,98)=$SELECT(BWCBE&(BWCBE<3):1,1:"")
+56 SET $EXTRACT(BWCDC,99)=$$PPREV^BWMDE2
+57 ;
+58 IF BWPAP
Begin DoDot:1
+59 NEW BWPDT,BWPPAY,BWPRESLT,BWPRTEXT,BWPWKUP,BWSAPT
+60 SET BWPRESLT=$$PRESLT^BWMDEU(BWIEN,BWBSU)
+61 SET BWPRTEXT=$$POTHR^BWMDEU(BWIEN,BWBSU,BWPRESLT)
+62 SET BWPDT=$$PSCRDT^BWMDEU($PIECE(BWIEN(0),"^",12),BWBSU,BWPRESLT)
+63 SET BWPPAY=$$PPAY^BWMDEU(BWBSU,BWPRESLT)
+64 SET BWPWKUP=$$PWKUP^BWMDEU(BWIEN,BWBSU,BWPRESLT)
+65 SET BWSAPT=$$SAPT^BWMDEU(BWIEN,BWBSU,BWCDCV)
+66 SET $EXTRACT(BWCDC,100,105)=$$PPREVDT^BWMDE2
+67 IF BWCDCV=50
Begin DoDot:2
+68 SET $EXTRACT(BWCDC,106)=BWBSU
+69 SET $EXTRACT(BWCDC,107)=BWSAPT
+70 IF BWBSU=1
SET $EXTRACT(BWCDC,108,109)=BWPRESLT
+71 SET $EXTRACT(BWCDC,110)=$PIECE(BWIEN(.3),"^",2)
+72 IF BWBSU=2
SET $EXTRACT(BWCDC,111,112)=BWPRESLT
+73 SET $EXTRACT(BWCDC,113,132)=BWPRTEXT
+74 SET $EXTRACT(BWCDC,133)=BWPWKUP
+75 SET $EXTRACT(BWCDC,134,141)=BWPDT
+76 SET $EXTRACT(BWCDC,142)=BWPPAY
+77 SET $EXTRACT(BWCDC,143)=3
+78 SET $EXTRACT(BWCDC,150,151)="08"
+79 SET $EXTRACT(BWCDC,152)=2
End DoDot:2
QUIT
+80 IF BWCDCV=41
Begin DoDot:2
+81 SET $EXTRACT(BWCDC,106)=BWSAPT
+82 SET $EXTRACT(BWCDC,107,108)=BWPRESLT
+83 SET $EXTRACT(BWCDC,109,128)=BWPRTEXT
+84 SET $EXTRACT(BWCDC,129)=BWPWKUP
+85 SET $EXTRACT(BWCDC,130,137)=BWPDT
+86 SET $EXTRACT(BWCDC,138)=BWPPAY
+87 SET $EXTRACT(BWCDC,139)=3
+88 SET $EXTRACT(BWCDC,146,147)="08"
+89 SET $EXTRACT(BWCDC,148)=2
End DoDot:2
End DoDot:1
+90 ;
+91 IF BWMAM
Begin DoDot:1
+92 NEW BWMDT,BWMRESLT,BWMWKUP,BWPAID,BWPMAMDT
+93 SET BWPMAMDT=$$MPREVDT^BWMDEU(BWIEN)
+94 SET BWMRESLT=$$MRESLT^BWMDEU2
+95 SET BWMWKUP=$$MWKUP^BWMDEU2
+96 SET BWMDT=$$MSCRDT^BWMDEU($PIECE(BWIEN(0),"^",12),BWMRESLT)
+97 SET BWPAID=$$PAID^BWMDEU(BWDFN,$PIECE(BWIEN(0),U,3),BWMDT,BWMRESLT,+DUZ(2))
+98 IF BWCDCV=50
Begin DoDot:2
+99 SET $EXTRACT(BWCDC,106)=BWBSU
+100 IF BWBSU=1
SET $EXTRACT(BWCDC,108,109)="09"
+101 IF BWBSU=2
SET $EXTRACT(BWCDC,111,112)="09"
+102 SET $EXTRACT(BWCDC,133)=2
+103 SET $EXTRACT(BWCDC,143)=$SELECT(BWPMAMDT<1:3,1:1)
+104 IF $EXTRACT(BWCDC,143)=1
SET $EXTRACT(BWCDC,144,149)=BWPMAMDT
+105 SET $EXTRACT(BWCDC,150,151)=BWMRESLT
+106 SET $EXTRACT(BWCDC,152)=BWMWKUP
+107 SET $EXTRACT(BWCDC,153,160)=BWMDT
+108 SET $EXTRACT(BWCDC,161)=BWPAID
End DoDot:2
QUIT
+109 IF BWCDCV=41
Begin DoDot:2
+110 SET $EXTRACT(BWCDC,107)="09"
+111 SET $EXTRACT(BWCDC,129)=2
+112 SET $EXTRACT(BWCDC,139)=$SELECT(BWPMAMDT<1:3,1:1)
+113 IF $EXTRACT(BWCDC,139)=1
SET $EXTRACT(BWCDC,140,145)=BWPMAMDT
+114 SET $EXTRACT(BWCDC,146,147)=BWMRESLT
+115 SET $EXTRACT(BWCDC,148)=BWMWKUP
+116 SET $EXTRACT(BWCDC,149,156)=BWMDT
+117 SET $EXTRACT(BWCDC,157)=BWPAID
End DoDot:2
End DoDot:1
+118 ;
+119 ; Abnormal Pap smear/Diagnostic workup section
+120 IF BWPAP
Begin DoDot:1
+121 IF BWCDCV=50
IF $EXTRACT(BWCDC,133)='1
QUIT
+122 IF BWCDCV=41
IF $EXTRACT(BWCDC,129)'=1
QUIT
+123 NEW BWCDBX,BWCDXPAY,BWCWOBX,BWPABN,BWPFDXDT,BWPFNDX,BWPSTFDX,BWPSTGDX,BWPSTTX,BWPSTXDT
+124 SET BWPABN=$$PABN^BWMDEU(BWBSU,$SELECT(BWBSU=50:$EXTRACT(BWCDC,111,112),BWBSU=41:$EXTRACT(BWCDC,108,109),1:""))
+125 SET BWCWOBX=$$CONOBX^BWMDEU2
+126 SET BWCDBX=$$COLPBX^BWMDEU2
+127 SET BWCDXPAY=$$CDXPAID^BWMDEU2
+128 SET BWPFNDX=$$PFNDX^BWMDEU2
+129 SET BWPSTGDX=$$PSTGDX^BWMDEU2(BWPFNDX,BWC0)
+130 SET BWPSTGDX(1)=$$PFNDXO^BWMDEU2
+131 SET BWPSTFDX=$PIECE(BWIEN(2),"^",22)
+132 SET BWPFDXDT=$$CDCDT^BWMDEU2($PIECE(BWIEN(2),"^",23))
+133 SET BWPSTTX=$PIECE(BWIEN(2),"^",24)
+134 SET BWPSTXDT=$$CDCDT^BWMDEU2($PIECE(BWIEN(2),"^",25))
+135 IF BWCDCV=50
IF $EXTRACT(BWCDC,133)=1
Begin DoDot:2
+136 SET $EXTRACT(BWCDC,169)=BWCWOBX
+137 SET $EXTRACT(BWCDC,170)=BWCDBX
+138 SET $EXTRACT(BWCDC,171)=$SELECT($PIECE(BWIEN(2),"^",21)="":2,1:1)
+139 SET $EXTRACT(BWCDC,172,191)=$EXTRACT($PIECE(BWIEN(2),"^",21),1,20)
+140 SET $EXTRACT(BWCDC,192,210)=""
+141 SET $EXTRACT(BWCDC,211)=BWCDXPAY
+142 SET $EXTRACT(BWCDC,212)=BWPFNDX
+143 SET $EXTRACT(BWCDC,213)=BWPSTGDX
+144 SET $EXTRACT(BWCDC,214,233)=BWPSTGDX(1)
+145 SET $EXTRACT(BWCDC,234)=BWPSTFDX
+146 SET $EXTRACT(BWCDC,235,242)=BWPFDXDT
+147 SET $EXTRACT(BWCDC,243)=BWPSTTX
+148 SET $EXTRACT(BWCDC,244,251)=BWPSTXDT
End DoDot:2
QUIT
+149 IF BWCDCV=41
IF $EXTRACT(BWCDC,129)=1
Begin DoDot:2
+150 SET $EXTRACT(BWCDC,160)=BWCWOBX
+151 SET $EXTRACT(BWCDC,161)=BWCDBX
+152 SET $EXTRACT(BWCDC,162)=$SELECT($PIECE(BWIEN(2),"^",21)="":2,1:1)
+153 SET $EXTRACT(BWCDC,163)=$EXTRACT($PIECE(BWIEN(2),"^",21),1,20)
+154 SET $EXTRACT(BWCDC,183)=""
+155 SET $EXTRACT(BWCDC,202)=BWCDXPAY
+156 SET $EXTRACT(BWCDC,203)=BWPFNDX
+157 SET $EXTRACT(BWCDC,204)=BWPSTGDX
+158 SET $EXTRACT(BWCDC,205)=BWPSTGDX(1)
+159 SET $EXTRACT(BWCDC,225)=BWPSTFDX
+160 SET $EXTRACT(BWCDC,226)=BWPFDXDT
+161 SET $EXTRACT(BWCDC,234)=BWPSTTX
+162 SET $EXTRACT(BWCDC,235)=BWPSTXDT
End DoDot:2
End DoDot:1
+163 ;
+164 ; Abnormal Initial Mammogram or CLinical Breast Exam/Diagnostic workup section
+165 IF BWMAM
Begin DoDot:1
+166 IF BWCDCV=50
IF $EXTRACT(BWCDC,152)'=1
QUIT
+167 IF BWCDCV=41
IF $EXTRACT(BWCDC,148)'=1
QUIT
+168 NEW BWBDXPAY,BWMFDXDT,BWMFINDL,BWMFNDX,BWMFUDXV,BWMLUMP,BWMRBREX,BWMSTFDX,BWMSTGDX,BWMULTRA,BWSRGDX,BWMSTTX,BWMSTXDT,BWMTMRSZ
+169 SET BWMFUDXV=$PIECE(BWIEN(2),"^",34)
+170 SET BWMRBREX=$PIECE(BWIEN(2),"^",26)
+171 SET BWMULTRA=$PIECE(BWIEN(2),"^",27)
+172 SET BWMLUMP=$PIECE(BWIEN(2),"^",28)
+173 SET BWMFINDL=$PIECE(BWIEN(2),"^",29)
+174 SET BWBDXPAY=$$BDXPAID^BWMDEU2
+175 SET BWMFNDX=$PIECE(BWIEN(2),"^",30)
+176 SET BWMSTGDX=$PIECE(BWIEN(0),"^",31)
+177 SET BWMTMRSZ=$PIECE(BWIEN(2),"^",31)
+178 SET BWMSTFDX=$PIECE(BWIEN(2),"^",22)
+179 SET BWMFDXDT=$$CDCDT^BWMDEU2($PIECE(BWIEN(2),"^",23))
+180 SET BWMSTTX=$PIECE(BWIEN(2),"^",24)
+181 SET BWMSTXDT=$$CDCDT^BWMDEU2($PIECE(BWIEN(2),"^",25))
+182 IF BWCDCV=50
IF $EXTRACT(BWCDC,152)=1
Begin DoDot:2
+183 SET $EXTRACT(BWCDC,257)=BWMFUDXV
+184 SET $EXTRACT(BWCDC,258)=BWMRBREX
+185 SET $EXTRACT(BWCDC,259)=BWMULTRA
+186 SET $EXTRACT(BWCDC,260)=BWMLUMP
+187 SET $EXTRACT(BWCDC,261)=BWMFINDL
+188 SET $EXTRACT(BWCDC,262)=$SELECT($PIECE(BWIEN(2),"^",21)="":2,1:1)
+189 SET $EXTRACT(BWCDC,263,282)=$EXTRACT($PIECE(BWIEN(2),"^",21),1,20)
+190 SET $EXTRACT(BWCDC,282,301)=""
+191 SET $EXTRACT(BWCDC,302)=BWBDXPAY
+192 SET $EXTRACT(BWCDC,303)=BWMFNDX
+193 SET $EXTRACT(BWCDC,304)=BWMSTGDX
+194 SET $EXTRACT(BWCDC,305)=BWMTMRSZ
+195 SET $EXTRACT(BWCDC,306)=BWMSTFDX
+196 SET $EXTRACT(BWCDC,307,314)=BWMFDXDT
+197 SET $EXTRACT(BWCDC,315)=BWMSTTX
+198 SET $EXTRACT(BWCDC,316,323)=BWMSTXDT
End DoDot:2
QUIT
+199 IF BWCDCV=41
IF $EXTRACT(BWCDC,148)=1
Begin DoDot:2
+200 SET $EXTRACT(BWCDC,243)=BWMFUDXV
+201 SET $EXTRACT(BWCDC,244)=BWMRBREX
+202 SET $EXTRACT(BWCDC,245)=BWMULTRA
+203 SET $EXTRACT(BWCDC,246)=BWMLUMP
+204 SET $EXTRACT(BWCDC,247)=BWMFINDL
+205 SET $EXTRACT(BWCDC,248)=$SELECT($PIECE(BWIEN(2),"^",21)="":2,1:1)
+206 SET $EXTRACT(BWCDC,249,268)=$EXTRACT($PIECE(BWIEN(2),"^",21),1,20)
+207 SET $EXTRACT(BWCDC,269,287)=""
+208 SET $EXTRACT(BWCDC,288)=BWBDXPAY
+209 SET $EXTRACT(BWCDC,289)=BWMFNDX
+210 SET $EXTRACT(BWCDC,290)=BWMSTGDX
+211 SET $EXTRACT(BWCDC,291)=BWMTMRSZ
+212 SET $EXTRACT(BWCDC,292)=BWMSTFDX
+213 SET $EXTRACT(BWCDC,293)=BWMFDXDT
+214 SET $EXTRACT(BWCDC,301)=BWMSTTX
+215 SET $EXTRACT(BWCDC,302)=BWMSTXDT
End DoDot:2
End DoDot:1
+216 ;
+217 IF BWCDCV=41
Begin DoDot:1
+218 SET $EXTRACT(BWCDC,158,159)=BWCDCV
+219 SET $EXTRACT(BWCDC,310,311)=$$EOR^BWMDE21
End DoDot:1
+220 IF BWCDCV=50
Begin DoDot:1
+221 SET $EXTRACT(BWCDC,162,163)=BWCDCV
+222 SET $EXTRACT(BWCDC,329,330)=$$EOR^BWMDE21
End DoDot:1
+223 SET ^BWTMP($JOB,BWDFN,BWIEN)=BWCDC
+224 ;
+225 IF '$DATA(BWSILENT)
IF '$DATA(ZTQUEUED)
USE IO(0)
WRITE "."
+226 QUIT
