BWMDEX2.m

BWMDEX2 ;IHS/CIA/DKM - Data transforms for extract;21-Mar-2011 14:15;PLS

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

 ; Returns CDC export version

CDCVER(BWSITE) ; EP

 N X

 S:'$G(BWSITE) BWSITE=DUZ(2)

 S X=$P($G(^BWSITE(BWSITE,0)),U,18)

 Q $S(X:X,1:41)

 ; Convert FM date to CDC format

 ; BWLN = Format type

 ;        6: 6-bytes (MMYYYY)

 ;        8: 8-bytes (MMDDYYYY) (default)

CDCDT(BWDT,BWLN) ;

 S:BWDT BWDT=BWDT+17000000

 Q $S(BWDT:$E(BWDT,5,$G(BWLN,8))_$E(BWDT,1,4),1:"")

 ; Return data from specified node and piece

PC(BWN,BWP,BWT) ;

 Q $$PC^BWMDEX(.BWN,.BWP,.BWT)

 ; ===========================

 ; Patient Demographics

 ; ===========================

 ; Return unique patient id

 ; Assigns one if this has not already been done.

PATID() N X

 S X=$$CDCID^BWUTL1(BWDFN)

 I '$L(X) D

 .D CDCID^BWPATE(BWDFN)

 .S X=$$CDCID^BWUTL1(BWDFN)

 Q X

 ; Returns DOB

DOB() Q $$CDCDT($$DOB^BWUTL1(BWDFN))

 ; Return record identifier for this procedure.

 ; First digit is 1 for pap, 2 for mam.

 ; Second digit is one's digit of the year.

 ; Last 4 digits are the 1-10000 digits of the accession.

RECID() N X,Y

 S Y=$$PC(0,1),X=$P(Y,"-",2)

 Q $S($E(Y)="P":1,1:2)_$E(Y,4)_$E(X,$L(X)-3,$L(X))

 ; Return state of residence (FIPS)

STRES() N X

 S X=$P($G(^DPT(BWDFN,.11)),U,5)

 Q $S(X:$P(^DIC(5,X,0),U,3),1:"")

 ; Return 5 digit zipcode

ZIP() N X

 S X=$E($$ZIP^BWUTL1(BWDFN),1,5)

 Q $S(X:X,1:"")

 ; Return FIPS code for screening state

STSCR(BWSITE) ;

 Q $P($G(^BWSITE($G(BWSITE,DUZ(2)),0)),U,11)

 ; Return FIPS code for screening county

CNTYSCR(BWSITE) ;

 N X

 S X=$P($G(^BWSITE($G(BWSITE,DUZ(2)),0)),U,16)

 Q $S(X>0:X,1:999)

 ; Return screening city

CITY(BWSITE) ;

 Q $P($G(^AUTTLOC($G(BWSITE,DUZ(2)),0)),U,13)

 ; Return race as a string of CDC race codes

 ; BWVER = CDC version # (defaults to current)

RACE(BWVER) ;

 N BWRACE,BWRSLT,I

 D RACEGET(.BWRACE)

 S BWRSLT="",I=0

 S:'$G(BWVER) BWVER=$$CDCVER

 F  S I=$O(BWRACE(I)) Q:'I  D

 .S BWRACE=$O(^BWRACE(I,1,"AC",BWVER,0))

 .I BWRACE,BWRSLT'[BWRACE S BWRSLT=BWRSLT_BWRACE

 Q BWRSLT

 ; Check for specific racial origin

 ; BWRC = IEN of race file entry

 ; Returns: 1 = yes, 2 = no, 3 = unknown

RACECHK(BWRC) ;

 N BWRACE

 D RACEGET(.BWRACE)

 Q $S('$D(BWRACE):3,$D(BWRACE(BWRC)):1,1:2)

 ; Load race IENs into array

RACEGET(BWRACE) ;

 N I

 K BWRACE

 S I=0

 F  S I=$O(^BWP(BWDFN,2,I)) Q:'I  S BWRACE(+^(I,0))=""

 ; If no race designated then infer from tribal affiliation

 I '$D(BWRACE) D

 .S I=+$P($G(^AUPNPAT(BWDFN,11)),U,8)

 .S I=$S(I:+$O(^BWRACE("C",I,0)),1:7)

 .; bw patch 10 - remove default race value of '5'/if unknown blank fill

 .I 'I Q

 .S BWRACE(I)=""

 Q

 ; Returns ethnicity code

 ; Assumes the IENs of file 10.2 are constant.

HISPANIC() ; EP

 N X

 S X=$P(^BWP(BWDFN,0),U,9)

 Q $S('X:2,X=1:1,X=2:2,1:3)

 ; Determine Bethesda System used

 ; BWPDT = Date of Procedure (defaults to BWDT)

 ; BWSITE = Site to check (defaults to DUZ(2))

 ; Returns 1: 1991 system; 2: 2001 system

BSU(BWPDT,BWSITE) ;

 N X

 I $G(BWMAM)!$G(BWCBE) Q ""

 I $$PC("all.5.03")=4!($$PC("all.5.03")=5),'$G(BWPDT) Q ""

 S X=$P($G(^BWSITE($G(BWSITE,DUZ(2)),.51)),U,2)

 S BWDT=$G(BWPDT,$G(BWDT))

 Q $S('X:1,BWDT<X:1,1:2)

 ; Return the dx workup (PAP and MAM)

 ; BWFLG = If zero, forces result to 2

 ; 1 = planned; 2 = unplanned; 3 = undetermined

WKUP(BWFLG) ;

 N X

 S BWFLG=+$G(BWFLG,1),X=$S('BWFLG:2,1:$$PC(2,20))

 I BWFLG,$G(BWPAP),$$PRESLT=11 S X=3

 I BWFLG,$G(BWMAM),$$MRESLT=10 S X=3

 Q $S(X:X,1:2)

 ; Find the last procedure within time window

 ; BWPT  = Procedure type(s) to find (separate by ^)

 ; BWDT1 = Ending date for search

 ; BWDT2 = Beginning date for search (defaults to BWDT1 - 1 year)

 ; Return IEN of last procedure, or 0 if none found.

FINDLAST(BWPT,BWDT1,BWDT2) ; EP

 N X,Y,Z

 S:'$D(BWDT2) BWDT2=$$FMADD^XLFDT(BWDT1,-366)

 F X=1:1:$L(BWPT,U) S BWPT(+$P(BWPT,U,X))=""

 S X=0

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

 .S Y=^BWPCD(X,0),Z=$P(Y,U,12)

 .I $D(BWPT(+$P(Y,U,4))),Z<BWDT1,Z>BWDT2 S Z(Z)=X

 S Z=$O(Z(""),-1)

 Q $S(Z:Z(Z),1:0)

 ; ===========================

 ; Breast exam

 ; ===========================

 ; Breast symptoms

BRSYMP() Q $S('BWMAM&'BWCBE:3,$$PC(2,35):$$PC(2,35),1:3)

 ; Clinical breast exam results

 ; Also sets:

 ; CBEAB = abnormal flag

 ; CBEDT = abnormal date

CBE() ; EP

 Q:'$G(BWMAM)&'$G(BWCBE) 3

 N BWCBEDX,BWCBEDT

 I $G(BWMAM) S BWCBEDX=$$PC(2,32),BWCBEDT=$$PC(2,33)

 E  S BWCBEDX=$P($G(^BWDIAG(+$$PC(0,5),0)),U,27),BWCBEDT=BWDT

 S:BWCBEDX BWCBEDX=+$P($G(^BWCBE(BWCBEDX,0)),U,2)

 I $G(BWMAM) D

 .S BWDATA("CBEAB")=$$PC(16,7)

 .I BWDATA("CBEAB")="",BWCBEDX D

 ..Q:BWCBEDX=3

 ..Q:BWCBEDX=4

 ..S BWDATA("CBEAB")=1

 E  D

 .I $L($$PC(16,7)) S BWDATA("CBEAB")=$$PC(16,7)

 .E  I $L($$PC(2,38)) S BWDATA("CBEAB")=$$PC(2,38)

 .E  S BWDATA("CBEAB")=$S(BWCBEDX<1:"",BWCBEDX<3:1,1:"")

 ; if a value is set in 2.38, use as OVERRIDE for default

 ;I 'BWDATA("CBEAB"),$$PC(2,38) S BWDATA("CBEAB")=$$PC(2,38)

 S BWDATA("CBEDT")=$S(BWDATA("CBEAB"):$$CDCDT(BWCBEDT),1:"")

 Q BWCBEDX

 ; ===========================

 ; PAP

 ; ===========================

 ; PAP specimen adequacy (CDC 5.0 and above)

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

SAPT() N BWSAPT

 I $G(BWMAM)!$G(BWCBE) Q ""

 S BWSAPT=$$PC(.3)

 I BWSAPT=2,$$BSU=2 S BWSAPT=1    ; code 2 only for Bethesda 1991

 I BWDT>3020930,'$L(BWSAPT) S BWSAPT=4  ; default to 4

 Q BWSAPT

 ; Find previous PAP

 ; Returns 1 if found, 2 if not, 3 if not PAP.

 ; Sets PAPDT

PPREV() Q:'BWPAP 3

 N X

 S X=$G(^BWPCD(+$$FINDLAST(1,BWDT,0),0))

 S BWDATA("PAPDT")=$$CDCDT($P(X,U,12),6)

 Q $S($L(X):1,1:2)

 ; PAP result code

 ; Sets the following:

 ;  POTHR = PAP result text

 ;  PDT   = Date of screening pap

 ;  PPAY  = Paid

 ;  PABN  = Abnormal PAP

 ;  PRES  = PAP result code

PRESLT() N BWRESN,BWBSU,BWCODE,BWTEXT

 I 'BWPAP Q ""

 I $G(BWMAM)!$$PC(2,33)!BWCBE Q ""

 Q:$D(BWDATA("PRES")) BWDATA("PRES")

 S BWRESN=+$$PC(0,5)

 I 'BWRESN S BWCODE=11,BWDATA("PWKUP")=3,BWBSU=0

 E  S BWCODE="",BWTEXT=$P($G(^BWDIAG(BWRESN,0)),U),BWBSU=$$BSU

 I BWBSU=1 D

 .S BWCODE=$P($G(^BWDIAG(BWRESN,0)),U,24)

 .S:BWCODE=7 BWDATA("POTHR")=BWTEXT

 .S BWDATA("PABN")=$S(BWCODE=14:1,1:3456[BWCODE)

 I BWBSU=2 D

 .S BWCODE=$P($G(^BWDIAG(BWRESN,1)),U)

 .S:BWCODE=8 BWDATA("POTHR")=BWTEXT

 .S BWDATA("PABN")=4567[BWCODE

 S:(BWCODE<9)!(BWCODE>10) BWDATA("PDT")=$$CDCDT(BWDT)

 I $L($$PC(2,38)) S BWDATA("PPAY")=$$PC(2,38)

 E  S BWDATA("PPAY")=$S(BWCODE<9:1,BWCODE>13:1,BWCODE>11:2,1:"")

 ; IF a value is present in 2.38, OVERRIDE accordingly (NBCCEDP PAID)

 ;I 'BWDATA("PPAY") S BWDATA("PPAY")=$$PC(2,38)

 S BWDATA("PRES")=BWCODE

 Q BWCODE

 ; ===========================

 ; Colposcopy

 ; ===========================

 ; Return piece from 0-node of colposcopy

COLPPC(BWP) ;

 S:'$D(BWDATA("COLP")) BWDATA("COLP")=$$COLP0^BWUTL4(BWIEN)

 Q $P(BWDATA("COLP"),U,BWP)

 ; Colposcopy Impression (No Biopsy)

 ; Return: 1 = Yes, 2 = No

CONOBX() Q $S($$WKUP'=1:"",$$COLPPC(4)=37:1,1:2)

 ; Colposcopy w/Biopsy

 ; Return: 1 = Yes, 2 = No

COLPBX() Q $S($$WKUP'=1:"",$$COLPPC(4)=2:1,1:2)

 ; Colposcopy final dx

 ; Sets the following:

 ;  CPSTG = final stage

 ;  CPDX  = diagnosis text

COLPDX() Q:$$WKUP'=1 ""

 N BWDX,X

 S BWDX=$$PC(0,33)

 S:'BWDX BWDX=$$COLPPC(5)

 S X=$G(^BWDIAG(+BWDX,0))

 S BWDX=$P(X,U,26)

 S:BWDX=6 BWDATA("CPSTG")=$$COLPPC(31)

 S:BWDX=7 BWDATA("CPDX")=$P(X,U)

 Q BWDX

 ; ===========================

 ; Mammography

 ; ===========================

 ; Find previous MAM

 ; Returns 1 if found, 2 if not, 3 if not MAM.

 ; Sets MAMDT

MPREV() Q:'BWMAM&'BWCBE 3

 N X

 S X=$G(^BWPCD(+$$FINDLAST("25^26^28",BWDT,0),0))

 S BWDATA("MAMDT")=$$CDCDT($P(X,U,12),6)

 Q $S($L(X):1,1:2)

 ; MAM Result Code

 ; Sets the following:

 ;  MABN = Abnormal mammogram

 ;  MDT  = Date of MAM

 ;  MPAY = MAM paid

 ;  MRES = MAM result code

MRESLT() N BWCODE,BWRESN,BWMPAY

 Q:'$G(BWMAM) $S(BWFMT=2:8,BWFMT=3:8,1:"")

 Q:$D(BWDATA("MRES")) BWDATA("MRES")

 S BWDATA("MABN")=0,BWRESN=+$$PC(0,5)

 S BWCODE=$S(BWRESN:$P(^BWDIAG(BWRESN,0),U,25),1:10),BWMPAY=$S(BWCODE=12:2,1:"")

 S BWDATA("MABN")=$S(654[BWCODE:1,1:0)

 S:(BWCODE<8)!(BWCODE>9) BWDATA("MDT")=$$CDCDT(BWDT)

 S:$$PC(0,3)<$P($G(^BWSITE(DUZ(2),0)),U,17) BWMPAY=1

 ;I BWMPAY>1 D

 ;.N BWAGE

 ;.S BWAGE=$$AGE^AUPNPAT(BWDFN)

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

 ;.E  S BWAGE=1

 ;.S BWMPAY=$S(BWAGE<26:1,1:2)

 ; If BWCODE IS 8 (Not needed) or 12 (Done recently elsewhewre), blank fill the MDE

 I BWCODE=8!(BWCODE=12)!(BWCODE=9) S BWCODE=""

 I $L($$PC(2,38)) S BWDATA("MPAY")=$$PC(2,38)

 E  S BWDATA("MPAY")=1  ;$S(BWMPAY:BWMPAY,1:1)

 ; CHECK FIELD 2.38 - IF DEFINED USE VALUE DEFINED IN 2.38 AS OVERRIDE

 ;I '$G(BWDATA("MPAY")) S BWDATA("MPAY")=$$PC(2,38)

 S BWDATA("MRES")=BWCODE

 Q BWCODE

 ; Returns true if diagnostic procedure was paid

DXPAID() Q $S($L($$PC(16,6)):$$PC(16,6),$L($$PC(15,9)):$$PC(15,9),$$PC(2,22)=1:1,1:2)

 ; Conversion for Indication for Mammogram

MIND() ;

 N BWRESN

 ; If this is a pap smear, return '5 (Cervical record only, breast services not done.)

 I $G(BWPAP) Q 5

 I $G(BWCBE),'$G(BWMAM) Q 4

 S BWRESN=+$$PC(0,5)

 S BWCODE=$S(BWRESN:$P(^BWDIAG(BWRESN,0),U,25),1:10)

 ; If the result code is '8' (Not needed), and there is a CBE, set the BWCODE to 4 (Initial mammogram not done...) and return the value

 ; set "Indication for Initial mammogram) to 4 (Initial mammogram not done..)

 I BWCODE=8,$$PC(2,32) S BWCODE=4 Q BWCODE

 ; If the result code is '9' (Needed but not performed at this visit), set Indication for initial mammogram to '4'

 I BWCODE=9 S BWCODE=4 Q BWCODE

 ; If the result code is '8' and there was no CBE, set BWCODE to 5 (Cervical Record only, breast services not done.)

 S BWCODE=$S(BWRESN=8:5,BWRESN=12:3,1:"")

 I 'BWCODE S BWCODE=$$PC(16,1)

 ; If there is still no code defined, and this is a 'Mammogram Screening', return 1 - for 'Routine Screening Mammogram'.

 I 'BWCODE,BWMAM S BWCODE=1

 I 'BWCODE S BWCODE=9

 Q BWCODE

 ;

 ; Conversion for Indication for Pap Smear

PIND() ;

 ; If this is a mammogram, return '5 (Breast Record only, cervical services not done)

 I $G(BWMAM) Q 5

 I $G(BWCBE),'$G(BWMAM) Q 5

 I BWPAP,$$PC(15,1) Q $$PC(15,1)

 I BWPAP Q 1

 Q 9

 ;

 ; HPV dx

 ; Sets the following:

 ;  HPVD = HPV Date

 ;  HPVP  = HPV Paid by NBCCEDP funds

HPVDX() ;

 N HPVIDT,HPVIEN,HPVDT,HPVIEN,HPVCDT,X,HPV15,HPVRIEN,HPVDX,DTXT,HPVCHK,X1,HPVSTAT

 S HPVIDT=$O(^BWPCD("AHPV",BWIEN,0)) Q:'HPVIDT 3

 S HPVFMDT=9999999-HPVIDT

 S HPVCDT=$$CDCDT(HPVFMDT,8) S BWDATA("HPVD")=HPVCDT

 S HPVIEN=$O(^BWPCD("AHPV",BWIEN,HPVIDT,0)) ;S BWDATA("HPVP")=$S($$PC(2,38):$$PC(2,38),1:1) Q 9

 I '$D(^BWPCD(HPVIEN)) S BWDATA("HPVP")=$S($$PC(2,38):$$PC(2,38),1:2) Q 9

 S HPV15=$G(^BWPCD(HPVIEN,2))

 ; IF HPV test present, default to 1

 ; if HPV test not present, default to 2

 ; override with what is in NBCCEDP PAID

 S BWDATA("HPVP")=$P(HPV15,U,38) I 'BWDATA("HPVP") S BWDATA("HPVP")=$S($$PC(2,38):$$PC(2,38),1:1)

 S HPVRIEN=$P(^BWPCD(HPVIEN,0),U,5)

 S X=$G(^BWDIAG(+HPVRIEN,0)),X1=$G(^BWDIAG(+HPVRIEN,1))

 ; Convert 'Detected' into POSITIVE (cdc value = 1)

 ; Convert 'Not Detected' into NEGATIVE (cdc value = 2)

 ; If the value is error/disregard, convert value to 'UNKNOWN' (cdc value = 9)

 S DTXT=$P(X,U)

 S HPVCHK=$S(DTXT="Detected":1,DTXT="Not Detected":2,DTXT="Error/Disregard":9,1:"")

 I HPVCHK'="" S HPVDX=HPVCHK Q HPVDX

 S HPVDX=$P(X1,U,2)

 S:HPVDX="" HPVDX=9

 Q HPVDX

 ;

 ; Screen logic for field mam.10.04 (Final Imaging outcome)

MAM1004() ;

 N MAM1001,MAM1002,MAM1003

 I $$PC("all.6.08")'=1 Q ""

 I BWDT<3090101 Q 0

 S MAM1001=$$PC("mam.10.01"),MAM1002=$$PC("mam.10.02"),MAM1003=$$PC("mam.10.03")

 ;I ((MAM1001="")!(MAM1001=2)),((MAM1002="")!(MAM1002=2)),((MAM1003="")!(MAM1003=2)) Q 0

 I MAM1001=1!(MAM1002=1)!(MAM1003=1) Q 1

 Q 0

 ; Specimen Type

SPECTYP() ;

 N DEFSTYP

 I $G(BWCBE)!$G(BWMAM) Q ""

 ; if Bethesda system used is 'Bethesda 1991' specimen type should be blank.

 I $$PC("all.5.05")=1 Q ""

 I $$PC(.3,2)'="" Q $$PC(.3,2)

 S DEFSTYP=$$GET1^DIQ(9002086.02,$G(DUZ(2)),.24,"I") I DEFSTYP Q DEFSTYP

 ; If there was not a value in the specimen type field, and there is no default defined, return 1 - Conventional

 Q 1

MAM1005() ;

 Q 1

 N RES

 S RES=0

 I $$MAM1004(),$$PC("mam.10.04"),$$PC("mam.10.04")'=8 S RES=1

 ;Q:$$PC("mam.10.01")=1!($$PC("mam.10.02")=1)!($$PC("mam.10.03")=1) 1

 Q RES

BWMDEX2   ;IHS/CIA/DKM - Data transforms for extract;21-Mar-2011 14:15;PLS

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

 +2       ; Returns CDC export version

CDCVER(BWSITE) ; EP

 +1        NEW X

 +2        IF '$GET(BWSITE)

               SET BWSITE=DUZ(2)

 +3        SET X=$PIECE($GET(^BWSITE(BWSITE,0)),U,18)

 +4        QUIT $SELECT(X:X,1:41)

 +5       ; Convert FM date to CDC format

 +6       ; BWLN = Format type

 +7       ;        6: 6-bytes (MMYYYY)

 +8       ;        8: 8-bytes (MMDDYYYY) (default)

CDCDT(BWDT,BWLN) ;

 +1        IF BWDT

               SET BWDT=BWDT+17000000

 +2        QUIT $SELECT(BWDT:$EXTRACT(BWDT,5,$GET(BWLN,8))_$EXTRACT(BWDT,1,4),1:"")

 +3       ; Return data from specified node and piece

PC(BWN,BWP,BWT) ;

 +1        QUIT $$PC^BWMDEX(.BWN,.BWP,.BWT)

 +2       ; ===========================

 +3       ; Patient Demographics

 +4       ; ===========================

 +5       ; Return unique patient id

 +6       ; Assigns one if this has not already been done.

PATID()    NEW X

 +1        SET X=$$CDCID^BWUTL1(BWDFN)

 +2        IF '$LENGTH(X)

               Begin DoDot:1

 +3                DO CDCID^BWPATE(BWDFN)

 +4                SET X=$$CDCID^BWUTL1(BWDFN)

               End DoDot:1

 +5        QUIT X

 +6       ; Returns DOB

DOB()      QUIT $$CDCDT($$DOB^BWUTL1(BWDFN))

 +1       ; Return record identifier for this procedure.

 +2       ; First digit is 1 for pap, 2 for mam.

 +3       ; Second digit is one's digit of the year.

 +4       ; Last 4 digits are the 1-10000 digits of the accession.

RECID()    NEW X,Y

 +1        SET Y=$$PC(0,1)

           SET X=$PIECE(Y,"-",2)

 +2        QUIT $SELECT($EXTRACT(Y)="P":1,1:2)_$EXTRACT(Y,4)_$EXTRACT(X,$LENGTH(X)-3,$LENGTH(X))

 +3       ; Return state of residence (FIPS)

STRES()    NEW X

 +1        SET X=$PIECE($GET(^DPT(BWDFN,.11)),U,5)

 +2        QUIT $SELECT(X:$PIECE(^DIC(5,X,0),U,3),1:"")

 +3       ; Return 5 digit zipcode

ZIP()      NEW X

 +1        SET X=$EXTRACT($$ZIP^BWUTL1(BWDFN),1,5)

 +2        QUIT $SELECT(X:X,1:"")

 +3       ; Return FIPS code for screening state

STSCR(BWSITE) ;

 +1        QUIT $PIECE($GET(^BWSITE($GET(BWSITE,DUZ(2)),0)),U,11)

 +2       ; Return FIPS code for screening county

CNTYSCR(BWSITE) ;

 +1        NEW X

 +2        SET X=$PIECE($GET(^BWSITE($GET(BWSITE,DUZ(2)),0)),U,16)

 +3        QUIT $SELECT(X>0:X,1:999)

 +4       ; Return screening city

CITY(BWSITE) ;

 +1        QUIT $PIECE($GET(^AUTTLOC($GET(BWSITE,DUZ(2)),0)),U,13)

 +2       ; Return race as a string of CDC race codes

 +3       ; BWVER = CDC version # (defaults to current)

RACE(BWVER) ;

 +1        NEW BWRACE,BWRSLT,I

 +2        DO RACEGET(.BWRACE)

 +3        SET BWRSLT=""

           SET I=0

 +4        IF '$GET(BWVER)

               SET BWVER=$$CDCVER

 +5        FOR 

               SET I=$ORDER(BWRACE(I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +6                SET BWRACE=$ORDER(^BWRACE(I,1,"AC",BWVER,0))

 +7                IF BWRACE

                       IF BWRSLT'[BWRACE

                           SET BWRSLT=BWRSLT_BWRACE

               End DoDot:1

 +8        QUIT BWRSLT

 +9       ; Check for specific racial origin

 +10      ; BWRC = IEN of race file entry

 +11      ; Returns: 1 = yes, 2 = no, 3 = unknown

RACECHK(BWRC) ;

 +1        NEW BWRACE

 +2        DO RACEGET(.BWRACE)

 +3        QUIT $SELECT('$DATA(BWRACE):3,$DATA(BWRACE(BWRC)):1,1:2)

 +4       ; Load race IENs into array

RACEGET(BWRACE) ;

 +1        NEW I

 +2        KILL BWRACE

 +3        SET I=0

 +4        FOR 

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

               IF 'I

                   QUIT 

               SET BWRACE(+^(I,0))=""

 +5       ; If no race designated then infer from tribal affiliation

 +6        IF '$DATA(BWRACE)

               Begin DoDot:1

 +7                SET I=+$PIECE($GET(^AUPNPAT(BWDFN,11)),U,8)

 +8                SET I=$SELECT(I:+$ORDER(^BWRACE("C",I,0)),1:7)

 +9       ; bw patch 10 - remove default race value of '5'/if unknown blank fill

 +10               IF 'I

                       QUIT 

 +11               SET BWRACE(I)=""

               End DoDot:1

 +12       QUIT 

 +13      ; Returns ethnicity code

 +14      ; Assumes the IENs of file 10.2 are constant.

HISPANIC() ; EP

 +1        NEW X

 +2        SET X=$PIECE(^BWP(BWDFN,0),U,9)

 +3        QUIT $SELECT('X:2,X=1:1,X=2:2,1:3)

 +4       ; Determine Bethesda System used

 +5       ; BWPDT = Date of Procedure (defaults to BWDT)

 +6       ; BWSITE = Site to check (defaults to DUZ(2))

 +7       ; Returns 1: 1991 system; 2: 2001 system

BSU(BWPDT,BWSITE) ;

 +1        NEW X

 +2        IF $GET(BWMAM)!$GET(BWCBE)

               QUIT ""

 +3        IF $$PC("all.5.03")=4!($$PC("all.5.03")=5)

               IF '$GET(BWPDT)

                   QUIT ""

 +4        SET X=$PIECE($GET(^BWSITE($GET(BWSITE,DUZ(2)),.51)),U,2)

 +5        SET BWDT=$GET(BWPDT,$GET(BWDT))

 +6        QUIT $SELECT('X:1,BWDT<X:1,1:2)

 +7       ; Return the dx workup (PAP and MAM)

 +8       ; BWFLG = If zero, forces result to 2

 +9       ; 1 = planned; 2 = unplanned; 3 = undetermined

WKUP(BWFLG) ;

 +1        NEW X

 +2        SET BWFLG=+$GET(BWFLG,1)

           SET X=$SELECT('BWFLG:2,1:$$PC(2,20))

 +3        IF BWFLG

               IF $GET(BWPAP)

                   IF $$PRESLT=11

                       SET X=3

 +4        IF BWFLG

               IF $GET(BWMAM)

                   IF $$MRESLT=10

                       SET X=3

 +5        QUIT $SELECT(X:X,1:2)

 +6       ; Find the last procedure within time window

 +7       ; BWPT  = Procedure type(s) to find (separate by ^)

 +8       ; BWDT1 = Ending date for search

 +9       ; BWDT2 = Beginning date for search (defaults to BWDT1 - 1 year)

 +10      ; Return IEN of last procedure, or 0 if none found.

FINDLAST(BWPT,BWDT1,BWDT2) ; EP

 +1        NEW X,Y,Z

 +2        IF '$DATA(BWDT2)

               SET BWDT2=$$FMADD^XLFDT(BWDT1,-366)

 +3        FOR X=1:1:$LENGTH(BWPT,U)

               SET BWPT(+$PIECE(BWPT,U,X))=""

 +4        SET X=0

 +5        FOR 

               SET X=$ORDER(^BWPCD("C",BWDFN,X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +6                SET Y=^BWPCD(X,0)

                   SET Z=$PIECE(Y,U,12)

 +7                IF $DATA(BWPT(+$PIECE(Y,U,4)))

                       IF Z<BWDT1

                           IF Z>BWDT2

                               SET Z(Z)=X

               End DoDot:1

 +8        SET Z=$ORDER(Z(""),-1)

 +9        QUIT $SELECT(Z:Z(Z),1:0)

 +10      ; ===========================

 +11      ; Breast exam

 +12      ; ===========================

 +13      ; Breast symptoms

BRSYMP()   QUIT $SELECT('BWMAM&'BWCBE:3,$$PC(2,35):$$PC(2,35),1:3)

 +1       ; Clinical breast exam results

 +2       ; Also sets:

 +3       ; CBEAB = abnormal flag

 +4       ; CBEDT = abnormal date

CBE()     ; EP

 +1        IF '$GET(BWMAM)&'$GET(BWCBE)

               QUIT 3

 +2        NEW BWCBEDX,BWCBEDT

 +3        IF $GET(BWMAM)

               SET BWCBEDX=$$PC(2,32)

               SET BWCBEDT=$$PC(2,33)

 +4       IF '$TEST

               SET BWCBEDX=$PIECE($GET(^BWDIAG(+$$PC(0,5),0)),U,27)

               SET BWCBEDT=BWDT

 +5        IF BWCBEDX

               SET BWCBEDX=+$PIECE($GET(^BWCBE(BWCBEDX,0)),U,2)

 +6        IF $GET(BWMAM)

               Begin DoDot:1

 +7                SET BWDATA("CBEAB")=$$PC(16,7)

 +8                IF BWDATA("CBEAB")=""

                       IF BWCBEDX

                           Begin DoDot:2

 +9                            IF BWCBEDX=3

                                   QUIT 

 +10                           IF BWCBEDX=4

                                   QUIT 

 +11                           SET BWDATA("CBEAB")=1

                           End DoDot:2

               End DoDot:1

 +12      IF '$TEST

               Begin DoDot:1

 +13               IF $LENGTH($$PC(16,7))

                       SET BWDATA("CBEAB")=$$PC(16,7)

 +14              IF '$TEST

                       IF $LENGTH($$PC(2,38))

                           SET BWDATA("CBEAB")=$$PC(2,38)

 +15              IF '$TEST

                       SET BWDATA("CBEAB")=$SELECT(BWCBEDX<1:"",BWCBEDX<3:1,1:"")

               End DoDot:1

 +16      ; if a value is set in 2.38, use as OVERRIDE for default

 +17      ;I 'BWDATA("CBEAB"),$$PC(2,38) S BWDATA("CBEAB")=$$PC(2,38)

 +18       SET BWDATA("CBEDT")=$SELECT(BWDATA("CBEAB"):$$CDCDT(BWCBEDT),1:"")

 +19       QUIT BWCBEDX

 +20      ; ===========================

 +21      ; PAP

 +22      ; ===========================

 +23      ; PAP specimen adequacy (CDC 5.0 and above)

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

SAPT()     NEW BWSAPT

 +1        IF $GET(BWMAM)!$GET(BWCBE)

               QUIT ""

 +2        SET BWSAPT=$$PC(.3)

 +3       ; code 2 only for Bethesda 1991

           IF BWSAPT=2

               IF $$BSU=2

                   SET BWSAPT=1

 +4       ; default to 4

           IF BWDT>3020930

               IF '$LENGTH(BWSAPT)

                   SET BWSAPT=4

 +5        QUIT BWSAPT

 +6       ; Find previous PAP

 +7       ; Returns 1 if found, 2 if not, 3 if not PAP.

 +8       ; Sets PAPDT

PPREV()    IF 'BWPAP

               QUIT 3

 +1        NEW X

 +2        SET X=$GET(^BWPCD(+$$FINDLAST(1,BWDT,0),0))

 +3        SET BWDATA("PAPDT")=$$CDCDT($PIECE(X,U,12),6)

 +4        QUIT $SELECT($LENGTH(X):1,1:2)

 +5       ; PAP result code

 +6       ; Sets the following:

 +7       ;  POTHR = PAP result text

 +8       ;  PDT   = Date of screening pap

 +9       ;  PPAY  = Paid

 +10      ;  PABN  = Abnormal PAP

 +11      ;  PRES  = PAP result code

PRESLT()   NEW BWRESN,BWBSU,BWCODE,BWTEXT

 +1        IF 'BWPAP

               QUIT ""

 +2        IF $GET(BWMAM)!$$PC(2,33)!BWCBE

               QUIT ""

 +3        IF $DATA(BWDATA("PRES"))

               QUIT BWDATA("PRES")

 +4        SET BWRESN=+$$PC(0,5)

 +5        IF 'BWRESN

               SET BWCODE=11

               SET BWDATA("PWKUP")=3

               SET BWBSU=0

 +6       IF '$TEST

               SET BWCODE=""

               SET BWTEXT=$PIECE($GET(^BWDIAG(BWRESN,0)),U)

               SET BWBSU=$$BSU

 +7        IF BWBSU=1

               Begin DoDot:1

 +8                SET BWCODE=$PIECE($GET(^BWDIAG(BWRESN,0)),U,24)

 +9                IF BWCODE=7

                       SET BWDATA("POTHR")=BWTEXT

 +10               SET BWDATA("PABN")=$SELECT(BWCODE=14:1,1:3456[BWCODE)

               End DoDot:1

 +11       IF BWBSU=2

               Begin DoDot:1

 +12               SET BWCODE=$PIECE($GET(^BWDIAG(BWRESN,1)),U)

 +13               IF BWCODE=8

                       SET BWDATA("POTHR")=BWTEXT

 +14               SET BWDATA("PABN")=4567[BWCODE

               End DoDot:1

 +15       IF (BWCODE<9)!(BWCODE>10)

               SET BWDATA("PDT")=$$CDCDT(BWDT)

 +16       IF $LENGTH($$PC(2,38))

               SET BWDATA("PPAY")=$$PC(2,38)

 +17      IF '$TEST

               SET BWDATA("PPAY")=$SELECT(BWCODE<9:1,BWCODE>13:1,BWCODE>11:2,1:"")

 +18      ; IF a value is present in 2.38, OVERRIDE accordingly (NBCCEDP PAID)

 +19      ;I 'BWDATA("PPAY") S BWDATA("PPAY")=$$PC(2,38)

 +20       SET BWDATA("PRES")=BWCODE

 +21       QUIT BWCODE

 +22      ; ===========================

 +23      ; Colposcopy

 +24      ; ===========================

 +25      ; Return piece from 0-node of colposcopy

COLPPC(BWP) ;

 +1        IF '$DATA(BWDATA("COLP"))

               SET BWDATA("COLP")=$$COLP0^BWUTL4(BWIEN)

 +2        QUIT $PIECE(BWDATA("COLP"),U,BWP)

 +3       ; Colposcopy Impression (No Biopsy)

 +4       ; Return: 1 = Yes, 2 = No

CONOBX()   QUIT $SELECT($$WKUP'=1:"",$$COLPPC(4)=37:1,1:2)

 +1       ; Colposcopy w/Biopsy

 +2       ; Return: 1 = Yes, 2 = No

COLPBX()   QUIT $SELECT($$WKUP'=1:"",$$COLPPC(4)=2:1,1:2)

 +1       ; Colposcopy final dx

 +2       ; Sets the following:

 +3       ;  CPSTG = final stage

 +4       ;  CPDX  = diagnosis text

COLPDX()   IF $$WKUP'=1

               QUIT ""

 +1        NEW BWDX,X

 +2        SET BWDX=$$PC(0,33)

 +3        IF 'BWDX

               SET BWDX=$$COLPPC(5)

 +4        SET X=$GET(^BWDIAG(+BWDX,0))