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
