BWMDE1.m

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)