BWMDET.m

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