BWMDEU.m

BWMDEU ;IHS/ANMC/MWR - MDE FUNCTIONS.;29-Oct-2003 21:34;PLS

 ;;2.0;WOMEN'S HEALTH;**8,9**;MAY 16, 1996

 ; CDC Export functions to retrieve data for individual fields.

 ;

 ;

RACE(BWDFN,MDEVER,MDERACE) ; EP - CDC's MDE Race classification.

 ; Call with  BWDFN = ien of patient in file PATIENT (#9000001)

 ;           MDEVER = version number of CDC Minimum Data Extraction (MDE)

 ;

 ; Returns  MDERACE = MDE Race classification based on MDE version number (passed by reference).

 ;                    Contains array of all races reported by patient

 ;

 N BWIEN,CODE,I,TRIBE

 ;

 ; Build array of race code for patient's designated races

 S I=0

 F  S I=$O(^BWP(BWDFN,2,I)) Q:'I  D

 . S BWIEN=+^BWP(BWDFN,2,I,0)

 . S CODE=$O(^BWRACE(BWIEN,1,"AC",MDEVER,0))

 . I CODE S MDERACE(I)=CODE

 ;

 ; If no race designated then return a CDC MDE Race code based on tribal relationship

 ;  ***These relationships should moved to a table. ***

 I '$O(MDERACE(0)) D

 . S TRIBE=$P($G(^AUPNPAT(BWDFN,11)),U,8),BWIEN=0

 . I TRIBE D

 . . I "^1^215^219^220^"[(U_TRIBE_U) S BWIEN=6 Q  ; Other

 . . I "^206^207^208^209^210^212^213^217^"[(U_TRIBE_U) S BWIEN=3 Q  ; Asian

 . . I TRIBE=211 S BWIEN=4 Q  ; Native Hawaiian/Pacific Islander

 . . I TRIBE=214 S BWIEN=1 Q  ; White

 . . I TRIBE=216 S BWIEN=2 Q  ; Black

 . . S BWIEN=5 ; American Indian/Alaska Native

 . I BWIEN D

 . . S CODE=$O(^BWRACE(BWIEN,1,"AC",MDEVER,0))

 . . I CODE S MDERACE(1)=CODE

 ;

 ; If no race designated then return 'unknown' for corresponding MDE version

 I '$O(MDERACE(0)) D

 . S CODE=$O(^BWRACE(7,1,"AC",MDEVER,0))

 . I CODE S MDERACE(1)=CODE

 Q

 ;

 ;

HISP(BWDFN) ; EP - Determine Hispanic/Latino origin

 ; Call with BWDFN = ien of patient in file PATIENT (#9000001)

 ; Returns     BWY = 1 (yes), 2 (no), 3 (unknown)

 ;

 N BWY,TRIBE

 S TRIBE=$P($G(^AUPNPAT(BWDFN,11)),U,8)

 I TRIBE=215 S BWY=1

 E  S BWY=3

 Q BWY

 ;

 ;

BSU(BWDT,SITE) ; EP - Determine Bethesda System Used

 ; Call with BWDT = "as of" date to check

 ;           SITE = site to check (pointer to BW SITE PARAMETER file #9002086.02)

 ;

 ; Returns  BWBSU = 1 (Bethesda 1991)

 ;                  2 (Bethesda 2001)

 ;

 N BWBSU,X

 ;

 S X=$G(^BWSITE(SITE,.51))

 I $P(X,"^",2),BWDT'<$P(X,"^",2) S BWBSU=2

 E  S BWBSU=1

 ;

 Q BWBSU

 ;

 ;

SAPT(BWIEN,BWBSU,BWMDEV) ; EP - Specimen Adequacy of Pap Test

 ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 ;           BWBSU = Bethesda System Used

 ;          BWMDEV = MDE version

 ;

 ; Returns   BWSAPT = Specimen adequacy based on Bethesda system used

 ;

 N BWPDT,BWSAPT

 ;

 ; Specimen adequacy not collected under versions of MDE prior to 5.0

 I BWMDEV<50 S BWSAPT=" "

 ;

 ; Need to code for Bethesda 2001 and collected after 10/01/02.

 I BWMDEV=50 D

 . S BWSAPT=$P($G(^BWPCD(BWIEN,.3)),"^")

 . S BWPDT=$P($G(^BWPCD(BWIEN,0)),"^",12)

 . I BWBSU=2,BWSAPT=2 S BWSAPT=1 Q  ; code 2 only for Bethesda 1991

 . I BWPDT>3020930,BWSAPT="" S BWSAPT=4 Q  ; default to 4-unknown when none entered.

 ;

 Q BWSAPT

 ;

 ;

POTHR(BWIEN,BWBSU,BWRPT) ; EP - Text results of Pap Test

 ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 ;           BWBSU = Bethesda system used

 ;           BWRPT = Results of Pap Test

 ;

 ; Return    BWRES = Pap test text results when result = other

 ;

 N BWRES,X,Y

 S BWRES="",X=+$P($G(^BWPCD(BWIEN,0)),"^",5),Y=""

 I X S Y=$P($G(^BWDIAG(X,0)),"^")

 ;

 I BWBSU=1,BWRPT=7 S BWRES=$E(Y,1,20)

 I BWBSU=2,BWRPT=8 S BWRES=$E(Y,1,20)

 ;

 Q BWRES

 ;

 ;

PSCRDT(BWDT,BWBSU,BWRPT) ; EP - Return date of Pap Test

 ; Call with BWDT = date of Pap test

 ;          BWBSU = Bethesda system used

 ;          BWRPT = results of Pap test

 ;

 ; Returns  BWPDT = date of Pap test in MDE date format

 ;

 N BWPDT,FLAG

 S FLAG=1

 ;

 I BWBSU=1,BWRPT>8,BWRPT<11 S FLAG=0

 I BWBSU=2,BWRPT>8,BWRPT<11 S FLAG=0

 ;

 I FLAG,BWDT S BWPDT=$TR($$FMTE^XLFDT(BWDT,"5DZ"),"/")

 E  S BWPDT=$$REPEAT^XLFSTR(" ",8)

 Q BWPDT

 ;

 ;

PRESLT(BWIEN,BWBSU) ; EP - Results of Pap Test

 ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 ;           BWBSU = Bethesda system used (1-Bethesda 1991) (2-Bethesda 2001)

 ;

 ; Return    BWRESLT = result of Pap test based on Bethesda system used

 ;

 ;

 N BWRESN,BWRESLT

 ;

 S BWRESN=$P($G(^BWPCD(BWIEN,0)),"^",5),BWRESLT=""

 ; If no result, return 11 (Result pending).

 I 'BWRESN S BWRESLT=11

 ;

 ; Return CDC code for the result.

 I BWRESN D

 . I BWBSU=1 S BWRESLT=$P($G(^BWDIAG(BWRESN,0)),"^",24) Q

 . I BWBSU=2 S BWRESLT=$P($G(^BWDIAG(BWRESN,1)),"^",1)

 ;

 I BWRESLT,BWRESLT<10 S BWRESLT=$$RJ^XLFSTR(BWRESLT,2,"0")

 ;

 Q BWRESLT

 ;

 ;

PABN(BWBSU,BWPRESLT) ; EP - Abnormal Pap Flag

 ; Call with BWBSU = Bethesda system used (1-Bethesda 1991) (2-Bethesda 2001)

 ;        BWPRESLT = results of Pap test

 ;

 ; Return   BWPABN = 1-yes, 2-no

 ;

 N BWPABN

 S BWPABN=""

 I BWBSU=1 D

 . I BWPRESLT=11 S BWPABN=0 Q

 . I BWPRESLT=14 S BWPABN=1 Q

 . I "3456"[BWPRESLT S BWPABN=1 Q

 . S BWPABN=0

 I BWBSU=2 D

 . I BWPRESLT=11 S BWPABN=0 Q

 . I "4567"[BWPRESLT S BWPABN=1 Q

 . S BWPABN=0

 ;

 Q BWPABN

 ;

 ;

PPAY(BWBSU,BWPRESLT) ; EP - Pap paid for by NBCCEDP funds

 ; Call with BWBSU = Bethesda system used (1-Bethesda 1991) (2-Bethesda 2001)

 ;        BWPRESLT = results of Pap test

 ;

 ; Return   BWPPAY = 1-yes, 2-no, 3=unknown

 ;

 N BWPPAY

 S BWPPAY=1

 I BWBSU=1 D

 . I BWPRESLT>8,BWPRESLT<12 S BWPPAY="" Q

 . I BWPRESLT>11,BWPRESLT<14 S BWPPAY=2

 I BWBSU=2 D

 . I BWPRESLT>8,BWPRESLT<12 S BWPPAY="" Q

 . I BWPRESLT>11,BWPRESLT<14 S BWPPAY=2

 Q BWPPAY

 ;

 ;

PWKUP(BWIEN,BWBSU,BWPRESLT) ; EP - Diagnostic workup 1=PLANNED, 2=NOT PLANNED, 3=UNDETERMINED.

 ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 ;           BWBSU = Bethesda system used (1-Bethesda 1991) (2-Bethesda 2001)

 ;        BWPRESLT = result of Pap test

 ;

 ; Return  BWPWKUP = CDC code for diagnostic workup

 ;

 N BWPWKUP,X

 ;

 I BWBSU=1,BWPRESLT=11 S BWPWKUP=3

 I BWBSU=2,BWPRESLT=11 S BWPWKUP=3

 S X=$P($G(^BWPCD(BWIEN,2)),"^",20)

 I X S BWPWKUP=X

 E  S BWPWKUP=2

 Q BWPWKUP

 ;

 ;

MPREVDT(BWIEN) ; EP - Retrieve date of previous mammogram if any in CDC MDE date format

 ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 ;

 ; Return    BWMDT = date of mammogram in CDC MDE date format (MMYYYY)

 ;

 N BWMAM,BWMDT,BWI,CUTOFF,DFN,N,X,Y

 ;

 ; Look for previous mammograms (ien 25, 26, or 28)

 S X=$G(^BWPCD(BWIEN,0))

 S DFN=+$P(X,"^",2),CUTOFF=+$P(^BWPCD(BWIEN,0),"^",12)

 S N=0

 F  S N=$O(^BWPCD("C",DFN,N)) Q:'N  D

 . S Y=^BWPCD(N,0)

 . I "^25^26^28^"'[(U_$P(Y,U,4)_U) Q  ;CIA/DKM - added delimeters

 . I $P(Y,"^",12)<CUTOFF S BWMAM($P(Y,"^",12))=""

 ;

 ; Get last date in list and return in CDC MDE date format

 S BWI=$O(BWMAM(""),-1)

 I BWI S BWMDT=$E(BWI,4,5)_($E(BWI,1,3)+1700)  ;$$CDCDT^BWMDEU2(BWI)

 E  S BWMDT=""

 Q BWMDT

 ;

 ;

MSCRDT(BWDT,BWRPT) ; EP - Return date of Mammogram Test

 ; Call with BWDT = date of Mammogram test

 ;          BWRPT = results of Mammogram test

 ;

 ; Returns  BWPDT = date of Pap test in MDE date format

 ;

 N BWPDT,FLAG

 S FLAG=1

 ;

 I BWRPT>7,BWRPT<10 S FLAG=0

 ;

 I FLAG,BWDT S BWPDT=$$CDCDT^BWMDEU2(BWDT)

 E  S BWPDT=$$REPEAT^XLFSTR(" ",8)

 Q BWPDT

 ;

 ;

PAID(DFN,PCCDATE,MDATE,RESULT,SITE) ; EP - Determine if procedure paid with NBCCEDP funds.

 ; Call with   DFN = patient ien in Patient file

 ;         PCCDATE = PCC event date in FileMan format

 ;           MDATE = date of mammogram in MDE date format

 ;          RESULT = mammography test result from item k of MDE

 ;            SITE = pointer to site in BW SITE file

 ;

 ; Reuturns  PAID = 1-yes, 2-no, 3-unknown

 ;

 N AGE,PAID

 S PAID=""

 ; PCC event date before CDC Funding Began date, funded if procedure is before CDC Funding date

 I MDATE,PCCDATE<$P($G(^BWSITE(SITE,0)),"^",17) S PAID=1

 ; Result type 12 do not have funding

 I 'PAID,RESULT=12 S PAID=2

 ; Age logic ensures that 75% of the reported population meets the CDC 75% rule.

 ; IHS WH does not turn away patients not meeting the age limitations.

 ; Ensure that at least 75% of those between ages 50 and 65 are funded

 I PAID>1 D

 . S AGE=+$$AGE^AUPNPAT(DFN)

 . I AGE<50!(AGE>65) S AGE=$R(100)

 . E  S AGE=1

 . S PAID=$S(AGE<26:1,1:2)

 ; Date of Mammogram required to mark funding as YES

 I PAID="",MDATE S PAID=1

 Q PAID

BWMDEU    ;IHS/ANMC/MWR - MDE FUNCTIONS.;29-Oct-2003 21:34;PLS

 +1       ;;2.0;WOMEN'S HEALTH;**8,9**;MAY 16, 1996

 +2       ; CDC Export functions to retrieve data for individual fields.

 +3       ;

 +4       ;

RACE(BWDFN,MDEVER,MDERACE) ; EP - CDC's MDE Race classification.

 +1       ; Call with  BWDFN = ien of patient in file PATIENT (#9000001)

 +2       ;           MDEVER = version number of CDC Minimum Data Extraction (MDE)

 +3       ;

 +4       ; Returns  MDERACE = MDE Race classification based on MDE version number (passed by reference).

 +5       ;                    Contains array of all races reported by patient

 +6       ;

 +7        NEW BWIEN,CODE,I,TRIBE

 +8       ;

 +9       ; Build array of race code for patient's designated races

 +10       SET I=0

 +11       FOR 

               SET I=$ORDER(^BWP(BWDFN,2,I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +12               SET BWIEN=+^BWP(BWDFN,2,I,0)

 +13               SET CODE=$ORDER(^BWRACE(BWIEN,1,"AC",MDEVER,0))

 +14               IF CODE

                       SET MDERACE(I)=CODE

               End DoDot:1

 +15      ;

 +16      ; If no race designated then return a CDC MDE Race code based on tribal relationship

 +17      ;  ***These relationships should moved to a table. ***

 +18       IF '$ORDER(MDERACE(0))

               Begin DoDot:1

 +19               SET TRIBE=$PIECE($GET(^AUPNPAT(BWDFN,11)),U,8)

                   SET BWIEN=0

 +20               IF TRIBE

                       Begin DoDot:2

 +21      ; Other

                           IF "^1^215^219^220^"[(U_TRIBE_U)

                               SET BWIEN=6

                               QUIT 

 +22      ; Asian

                           IF "^206^207^208^209^210^212^213^217^"[(U_TRIBE_U)

                               SET BWIEN=3

                               QUIT 

 +23      ; Native Hawaiian/Pacific Islander

                           IF TRIBE=211

                               SET BWIEN=4

                               QUIT 

 +24      ; White

                           IF TRIBE=214

                               SET BWIEN=1

                               QUIT 

 +25      ; Black

                           IF TRIBE=216

                               SET BWIEN=2

                               QUIT 

 +26      ; American Indian/Alaska Native

                           SET BWIEN=5

                       End DoDot:2

 +27               IF BWIEN

                       Begin DoDot:2

 +28                       SET CODE=$ORDER(^BWRACE(BWIEN,1,"AC",MDEVER,0))

 +29                       IF CODE

                               SET MDERACE(1)=CODE

                       End DoDot:2

               End DoDot:1

 +30      ;

 +31      ; If no race designated then return 'unknown' for corresponding MDE version

 +32       IF '$ORDER(MDERACE(0))

               Begin DoDot:1

 +33               SET CODE=$ORDER(^BWRACE(7,1,"AC",MDEVER,0))

 +34               IF CODE

                       SET MDERACE(1)=CODE

               End DoDot:1

 +35       QUIT 

 +36      ;

 +37      ;

HISP(BWDFN) ; EP - Determine Hispanic/Latino origin

 +1       ; Call with BWDFN = ien of patient in file PATIENT (#9000001)

 +2       ; Returns     BWY = 1 (yes), 2 (no), 3 (unknown)

 +3       ;

 +4        NEW BWY,TRIBE

 +5        SET TRIBE=$PIECE($GET(^AUPNPAT(BWDFN,11)),U,8)

 +6        IF TRIBE=215

               SET BWY=1

 +7       IF '$TEST

               SET BWY=3

 +8        QUIT BWY

 +9       ;

 +10      ;

BSU(BWDT,SITE) ; EP - Determine Bethesda System Used

 +1       ; Call with BWDT = "as of" date to check

 +2       ;           SITE = site to check (pointer to BW SITE PARAMETER file #9002086.02)

 +3       ;

 +4       ; Returns  BWBSU = 1 (Bethesda 1991)

 +5       ;                  2 (Bethesda 2001)

 +6       ;

 +7        NEW BWBSU,X

 +8       ;

 +9        SET X=$GET(^BWSITE(SITE,.51))

 +10       IF $PIECE(X,"^",2)

               IF BWDT'<$PIECE(X,"^",2)

                   SET BWBSU=2

 +11      IF '$TEST

               SET BWBSU=1

 +12      ;

 +13       QUIT BWBSU

 +14      ;

 +15      ;

SAPT(BWIEN,BWBSU,BWMDEV) ; EP - Specimen Adequacy of Pap Test

 +1       ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 +2       ;           BWBSU = Bethesda System Used

 +3       ;          BWMDEV = MDE version

 +4       ;

 +5       ; Returns   BWSAPT = Specimen adequacy based on Bethesda system used

 +6       ;

 +7        NEW BWPDT,BWSAPT

 +8       ;

 +9       ; Specimen adequacy not collected under versions of MDE prior to 5.0

 +10       IF BWMDEV<50

               SET BWSAPT=" "

 +11      ;

 +12      ; Need to code for Bethesda 2001 and collected after 10/01/02.

 +13       IF BWMDEV=50

               Begin DoDot:1

 +14               SET BWSAPT=$PIECE($GET(^BWPCD(BWIEN,.3)),"^")

 +15               SET BWPDT=$PIECE($GET(^BWPCD(BWIEN,0)),"^",12)

 +16      ; code 2 only for Bethesda 1991

                   IF BWBSU=2

                       IF BWSAPT=2

                           SET BWSAPT=1

                           QUIT 

 +17      ; default to 4-unknown when none entered.

                   IF BWPDT>3020930

                       IF BWSAPT=""

                           SET BWSAPT=4

                           QUIT 

               End DoDot:1

 +18      ;

 +19       QUIT BWSAPT

 +20      ;

 +21      ;

POTHR(BWIEN,BWBSU,BWRPT) ; EP - Text results of Pap Test

 +1       ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 +2       ;           BWBSU = Bethesda system used

 +3       ;           BWRPT = Results of Pap Test

 +4       ;

 +5       ; Return    BWRES = Pap test text results when result = other

 +6       ;

 +7        NEW BWRES,X,Y

 +8        SET BWRES=""

           SET X=+$PIECE($GET(^BWPCD(BWIEN,0)),"^",5)

           SET Y=""

 +9        IF X

               SET Y=$PIECE($GET(^BWDIAG(X,0)),"^")

 +10      ;

 +11       IF BWBSU=1

               IF BWRPT=7

                   SET BWRES=$EXTRACT(Y,1,20)

 +12       IF BWBSU=2

               IF BWRPT=8

                   SET BWRES=$EXTRACT(Y,1,20)

 +13      ;

 +14       QUIT BWRES

 +15      ;

 +16      ;

PSCRDT(BWDT,BWBSU,BWRPT) ; EP - Return date of Pap Test

 +1       ; Call with BWDT = date of Pap test

 +2       ;          BWBSU = Bethesda system used

 +3       ;          BWRPT = results of Pap test

 +4       ;

 +5       ; Returns  BWPDT = date of Pap test in MDE date format

 +6       ;

 +7        NEW BWPDT,FLAG

 +8        SET FLAG=1

 +9       ;

 +10       IF BWBSU=1

               IF BWRPT>8

                   IF BWRPT<11

                       SET FLAG=0

 +11       IF BWBSU=2

               IF BWRPT>8

                   IF BWRPT<11

                       SET FLAG=0

 +12      ;

 +13       IF FLAG

               IF BWDT

                   SET BWPDT=$TRANSLATE($$FMTE^XLFDT(BWDT,"5DZ"),"/")

 +14      IF '$TEST

               SET BWPDT=$$REPEAT^XLFSTR(" ",8)

 +15       QUIT BWPDT

 +16      ;

 +17      ;

PRESLT(BWIEN,BWBSU) ; EP - Results of Pap Test

 +1       ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 +2       ;           BWBSU = Bethesda system used (1-Bethesda 1991) (2-Bethesda 2001)

 +3       ;

 +4       ; Return    BWRESLT = result of Pap test based on Bethesda system used

 +5       ;

 +6       ;

 +7        NEW BWRESN,BWRESLT

 +8       ;

 +9        SET BWRESN=$PIECE($GET(^BWPCD(BWIEN,0)),"^",5)

           SET BWRESLT=""

 +10      ; If no result, return 11 (Result pending).

 +11       IF 'BWRESN

               SET BWRESLT=11

 +12      ;

 +13      ; Return CDC code for the result.

 +14       IF BWRESN

               Begin DoDot:1

 +15               IF BWBSU=1

                       SET BWRESLT=$PIECE($GET(^BWDIAG(BWRESN,0)),"^",24)

                       QUIT 

 +16               IF BWBSU=2

                       SET BWRESLT=$PIECE($GET(^BWDIAG(BWRESN,1)),"^",1)

               End DoDot:1

 +17      ;

 +18       IF BWRESLT

               IF BWRESLT<10

                   SET BWRESLT=$$RJ^XLFSTR(BWRESLT,2,"0")

 +19      ;

 +20       QUIT BWRESLT

 +21      ;

 +22      ;

PABN(BWBSU,BWPRESLT) ; EP - Abnormal Pap Flag

 +1       ; Call with BWBSU = Bethesda system used (1-Bethesda 1991) (2-Bethesda 2001)

 +2       ;        BWPRESLT = results of Pap test

 +3       ;

 +4       ; Return   BWPABN = 1-yes, 2-no

 +5       ;

 +6        NEW BWPABN

 +7        SET BWPABN=""

 +8        IF BWBSU=1

               Begin DoDot:1

 +9                IF BWPRESLT=11

                       SET BWPABN=0

                       QUIT 

 +10               IF BWPRESLT=14

                       SET BWPABN=1

                       QUIT 

 +11               IF "3456"[BWPRESLT

                       SET BWPABN=1

                       QUIT 

 +12               SET BWPABN=0

               End DoDot:1

 +13       IF BWBSU=2

               Begin DoDot:1

 +14               IF BWPRESLT=11

                       SET BWPABN=0

                       QUIT 

 +15               IF "4567"[BWPRESLT

                       SET BWPABN=1

                       QUIT 

 +16               SET BWPABN=0

               End DoDot:1

 +17      ;

 +18       QUIT BWPABN

 +19      ;

 +20      ;

PPAY(BWBSU,BWPRESLT) ; EP - Pap paid for by NBCCEDP funds

 +1       ; Call with BWBSU = Bethesda system used (1-Bethesda 1991) (2-Bethesda 2001)

 +2       ;        BWPRESLT = results of Pap test

 +3       ;

 +4       ; Return   BWPPAY = 1-yes, 2-no, 3=unknown

 +5       ;

 +6        NEW BWPPAY

 +7        SET BWPPAY=1

 +8        IF BWBSU=1

               Begin DoDot:1

 +9                IF BWPRESLT>8

                       IF BWPRESLT<12

                           SET BWPPAY=""

                           QUIT 

 +10               IF BWPRESLT>11

                       IF BWPRESLT<14

                           SET BWPPAY=2

               End DoDot:1

 +11       IF BWBSU=2

               Begin DoDot:1

 +12               IF BWPRESLT>8

                       IF BWPRESLT<12

                           SET BWPPAY=""

                           QUIT 

 +13               IF BWPRESLT>11

                       IF BWPRESLT<14

                           SET BWPPAY=2

               End DoDot:1

 +14       QUIT BWPPAY

 +15      ;

 +16      ;

PWKUP(BWIEN,BWBSU,BWPRESLT) ; EP - Diagnostic workup 1=PLANNED, 2=NOT PLANNED, 3=UNDETERMINED.

 +1       ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 +2       ;           BWBSU = Bethesda system used (1-Bethesda 1991) (2-Bethesda 2001)

 +3       ;        BWPRESLT = result of Pap test

 +4       ;

 +5       ; Return  BWPWKUP = CDC code for diagnostic workup

 +6       ;

 +7        NEW BWPWKUP,X

 +8       ;

 +9        IF BWBSU=1

               IF BWPRESLT=11

                   SET BWPWKUP=3

 +10       IF BWBSU=2

               IF BWPRESLT=11

                   SET BWPWKUP=3

 +11       SET X=$PIECE($GET(^BWPCD(BWIEN,2)),"^",20)

 +12       IF X

               SET BWPWKUP=X

 +13      IF '$TEST

               SET BWPWKUP=2

 +14       QUIT BWPWKUP

 +15      ;

 +16      ;

MPREVDT(BWIEN) ; EP - Retrieve date of previous mammogram if any in CDC MDE date format

 +1       ; Call with BWIEN = ien of entry in file BW PROCEDURE (#9002086.1)

 +2       ;

 +3       ; Return    BWMDT = date of mammogram in CDC MDE date format (MMYYYY)

 +4       ;

 +5        NEW BWMAM,BWMDT,BWI,CUTOFF,DFN,N,X,Y

 +6       ;

 +7       ; Look for previous mammograms (ien 25, 26, or 28)

 +8        SET X=$GET(^BWPCD(BWIEN,0))

 +9        SET DFN=+$PIECE(X,"^",2)

           SET CUTOFF=+$PIECE(^BWPCD(BWIEN,0),"^",12)

 +10       SET N=0

 +11       FOR 

               SET N=$ORDER(^BWPCD("C",DFN,N))

               IF 'N

                   QUIT 

               Begin DoDot:1

 +12               SET Y=^BWPCD(N,0)

 +13      ;CIA/DKM - added delimeters

                   IF "^25^26^28^"'[(U_$PIECE(Y,U,4)_U)

                       QUIT 

 +14               IF $PIECE(Y,"^",12)<CUTOFF

                       SET BWMAM($PIECE(Y,"^",12))=""

               End DoDot:1

 +15      ;

 +16      ; Get last date in list and return in CDC MDE date format

 +17       SET BWI=$ORDER(BWMAM(""),-1)

 +18      ;$$CDCDT^BWMDEU2(BWI)

           IF BWI

               SET BWMDT=$EXTRACT(BWI,4,5)_($EXTRACT(BWI,1,3)+1700)

 +19      IF '$TEST

               SET BWMDT=""

 +20       QUIT BWMDT

 +21      ;

 +22      ;

MSCRDT(BWDT,BWRPT) ; EP - Return date of Mammogram Test

 +1       ; Call with BWDT = date of Mammogram test

 +2       ;          BWRPT = results of Mammogram test

 +3       ;

 +4       ; Returns  BWPDT = date of Pap test in MDE date format

 +5       ;

 +6        NEW BWPDT,FLAG

 +7        SET FLAG=1

 +8       ;

 +9        IF BWRPT>7

               IF BWRPT<10

                   SET FLAG=0

 +10      ;

 +11       IF FLAG

               IF BWDT

                   SET BWPDT=$$CDCDT^BWMDEU2(BWDT)

 +12      IF '$TEST

               SET BWPDT=$$REPEAT^XLFSTR(" ",8)

 +13       QUIT BWPDT

 +14      ;

 +15      ;

PAID(DFN,PCCDATE,MDATE,RESULT,SITE) ; EP - Determine if procedure paid with NBCCEDP funds.

 +1       ; Call with   DFN = patient ien in Patient file

 +2       ;         PCCDATE = PCC event date in FileMan format

 +3       ;           MDATE = date of mammogram in MDE date format

 +4       ;          RESULT = mammography test result from item k of MDE

 +5       ;            SITE = pointer to site in BW SITE file

 +6       ;

 +7       ; Reuturns  PAID = 1-yes, 2-no, 3-unknown

 +8       ;

 +9        NEW AGE,PAID

 +10       SET PAID=""

 +11      ; PCC event date before CDC Funding Began date, funded if procedure is before CDC Funding date

 +12       IF MDATE

               IF PCCDATE<$PIECE($GET(^BWSITE(SITE,0)),"^",17)

                   SET PAID=1

 +13      ; Result type 12 do not have funding

 +14       IF 'PAID

               IF RESULT=12

                   SET PAID=2

 +15      ; Age logic ensures that 75% of the reported population meets the CDC 75% rule.

 +16      ; IHS WH does not turn away patients not meeting the age limitations.

 +17      ; Ensure that at least 75% of those between ages 50 and 65 are funded

 +18       IF PAID>1

               Begin DoDot:1

 +19               SET AGE=+$$AGE^AUPNPAT(DFN)

 +20               IF AGE<50!(AGE>65)

                       SET AGE=$RANDOM(100)

 +21              IF '$TEST

                       SET AGE=1

 +22               SET PAID=$SELECT(AGE<26:1,1:2)

               End DoDot:1

 +23      ; Date of Mammogram required to mark funding as YES

 +24       IF PAID=""

               IF MDATE

                   SET PAID=1

 +25       QUIT PAID