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))
+5 SET BWDX=$PIECE(X,U,26)
+6 IF BWDX=6
SET BWDATA("CPSTG")=$$COLPPC(31)
+7 IF BWDX=7
SET BWDATA("CPDX")=$PIECE(X,U)
+8 QUIT BWDX
+9 ; ===========================
+10 ; Mammography
+11 ; ===========================
+12 ; Find previous MAM
+13 ; Returns 1 if found, 2 if not, 3 if not MAM.
+14 ; Sets MAMDT
MPREV() IF 'BWMAM&'BWCBE
QUIT 3
+1 NEW X
+2 SET X=$GET(^BWPCD(+$$FINDLAST("25^26^28",BWDT,0),0))
+3 SET BWDATA("MAMDT")=$$CDCDT($PIECE(X,U,12),6)
+4 QUIT $SELECT($LENGTH(X):1,1:2)
+5 ; MAM Result Code
+6 ; Sets the following:
+7 ; MABN = Abnormal mammogram
+8 ; MDT = Date of MAM
+9 ; MPAY = MAM paid
+10 ; MRES = MAM result code
MRESLT() NEW BWCODE,BWRESN,BWMPAY
+1 IF '$GET(BWMAM)
QUIT $SELECT(BWFMT=2:8,BWFMT=3:8,1:"")
+2 IF $DATA(BWDATA("MRES"))
QUIT BWDATA("MRES")
+3 SET BWDATA("MABN")=0
SET BWRESN=+$$PC(0,5)
+4 SET BWCODE=$SELECT(BWRESN:$PIECE(^BWDIAG(BWRESN,0),U,25),1:10)
SET BWMPAY=$SELECT(BWCODE=12:2,1:"")
+5 SET BWDATA("MABN")=$SELECT(654[BWCODE:1,1:0)
+6 IF (BWCODE<8)!(BWCODE>9)
SET BWDATA("MDT")=$$CDCDT(BWDT)
+7 IF $$PC(0,3)<$PIECE($GET(^BWSITE(DUZ(2),0)),U,17)
SET BWMPAY=1
+8 ;I BWMPAY>1 D
+9 ;.N BWAGE
+10 ;.S BWAGE=$$AGE^AUPNPAT(BWDFN)
+11 ;.I (BWAGE<50)!(BWAGE>65) S BWAGE=$R(100)
+12 ;.E S BWAGE=1
+13 ;.S BWMPAY=$S(BWAGE<26:1,1:2)
+14 ; If BWCODE IS 8 (Not needed) or 12 (Done recently elsewhewre), blank fill the MDE
+15 IF BWCODE=8!(BWCODE=12)!(BWCODE=9)
SET BWCODE=""
+16 IF $LENGTH($$PC(2,38))
SET BWDATA("MPAY")=$$PC(2,38)
+17 ;$S(BWMPAY:BWMPAY,1:1)
IF '$TEST
SET BWDATA("MPAY")=1
+18 ; CHECK FIELD 2.38 - IF DEFINED USE VALUE DEFINED IN 2.38 AS OVERRIDE
+19 ;I '$G(BWDATA("MPAY")) S BWDATA("MPAY")=$$PC(2,38)
+20 SET BWDATA("MRES")=BWCODE
+21 QUIT BWCODE
+22 ; Returns true if diagnostic procedure was paid
DXPAID() QUIT $SELECT($LENGTH($$PC(16,6)):$$PC(16,6),$LENGTH($$PC(15,9)):$$PC(15,9),$$PC(2,22)=1:1,1:2)
+1 ; Conversion for Indication for Mammogram
MIND() ;
+1 NEW BWRESN
+2 ; If this is a pap smear, return '5 (Cervical record only, breast services not done.)
+3 IF $GET(BWPAP)
QUIT 5
+4 IF $GET(BWCBE)
IF '$GET(BWMAM)
QUIT 4
+5 SET BWRESN=+$$PC(0,5)
+6 SET BWCODE=$SELECT(BWRESN:$PIECE(^BWDIAG(BWRESN,0),U,25),1:10)
+7 ; 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
+8 ; set "Indication for Initial mammogram) to 4 (Initial mammogram not done..)
+9 IF BWCODE=8
IF $$PC(2,32)
SET BWCODE=4
QUIT BWCODE
+10 ; If the result code is '9' (Needed but not performed at this visit), set Indication for initial mammogram to '4'
+11 IF BWCODE=9
SET BWCODE=4
QUIT BWCODE
+12 ; If the result code is '8' and there was no CBE, set BWCODE to 5 (Cervical Record only, breast services not done.)
+13 SET BWCODE=$SELECT(BWRESN=8:5,BWRESN=12:3,1:"")
+14 IF 'BWCODE
SET BWCODE=$$PC(16,1)
+15 ; If there is still no code defined, and this is a 'Mammogram Screening', return 1 - for 'Routine Screening Mammogram'.
+16 IF 'BWCODE
IF BWMAM
SET BWCODE=1
+17 IF 'BWCODE
SET BWCODE=9
+18 QUIT BWCODE
+19 ;
+20 ; Conversion for Indication for Pap Smear
PIND() ;
+1 ; If this is a mammogram, return '5 (Breast Record only, cervical services not done)
+2 IF $GET(BWMAM)
QUIT 5
+3 IF $GET(BWCBE)
IF '$GET(BWMAM)
QUIT 5
+4 IF BWPAP
IF $$PC(15,1)
QUIT $$PC(15,1)
+5 IF BWPAP
QUIT 1
+6 QUIT 9
+7 ;
+8 ; HPV dx
+9 ; Sets the following:
+10 ; HPVD = HPV Date
+11 ; HPVP = HPV Paid by NBCCEDP funds
HPVDX() ;
+1 NEW HPVIDT,HPVIEN,HPVDT,HPVIEN,HPVCDT,X,HPV15,HPVRIEN,HPVDX,DTXT,HPVCHK,X1,HPVSTAT
+2 SET HPVIDT=$ORDER(^BWPCD("AHPV",BWIEN,0))
IF 'HPVIDT
QUIT 3
+3 SET HPVFMDT=9999999-HPVIDT
+4 SET HPVCDT=$$CDCDT(HPVFMDT,8)
SET BWDATA("HPVD")=HPVCDT
+5 ;S BWDATA("HPVP")=$S($$PC(2,38):$$PC(2,38),1:1) Q 9
SET HPVIEN=$ORDER(^BWPCD("AHPV",BWIEN,HPVIDT,0))
+6 IF '$DATA(^BWPCD(HPVIEN))
SET BWDATA("HPVP")=$SELECT($$PC(2,38):$$PC(2,38),1:2)
QUIT 9
+7 SET HPV15=$GET(^BWPCD(HPVIEN,2))
+8 ; IF HPV test present, default to 1
+9 ; if HPV test not present, default to 2
+10 ; override with what is in NBCCEDP PAID
+11 SET BWDATA("HPVP")=$PIECE(HPV15,U,38)
IF 'BWDATA("HPVP")
SET BWDATA("HPVP")=$SELECT($$PC(2,38):$$PC(2,38),1:1)
+12 SET HPVRIEN=$PIECE(^BWPCD(HPVIEN,0),U,5)
+13 SET X=$GET(^BWDIAG(+HPVRIEN,0))
SET X1=$GET(^BWDIAG(+HPVRIEN,1))
+14 ; Convert 'Detected' into POSITIVE (cdc value = 1)
+15 ; Convert 'Not Detected' into NEGATIVE (cdc value = 2)
+16 ; If the value is error/disregard, convert value to 'UNKNOWN' (cdc value = 9)
+17 SET DTXT=$PIECE(X,U)
+18 SET HPVCHK=$SELECT(DTXT="Detected":1,DTXT="Not Detected":2,DTXT="Error/Disregard":9,1:"")
+19 IF HPVCHK'=""
SET HPVDX=HPVCHK
QUIT HPVDX
+20 SET HPVDX=$PIECE(X1,U,2)
+21 IF HPVDX=""
SET HPVDX=9
+22 QUIT HPVDX
+23 ;
+24 ; Screen logic for field mam.10.04 (Final Imaging outcome)
MAM1004() ;
+1 NEW MAM1001,MAM1002,MAM1003
+2 IF $$PC("all.6.08")'=1
QUIT ""
+3 IF BWDT<3090101
QUIT 0
+4 SET MAM1001=$$PC("mam.10.01")
SET MAM1002=$$PC("mam.10.02")
SET MAM1003=$$PC("mam.10.03")
+5 ;I ((MAM1001="")!(MAM1001=2)),((MAM1002="")!(MAM1002=2)),((MAM1003="")!(MAM1003=2)) Q 0
+6 IF MAM1001=1!(MAM1002=1)!(MAM1003=1)
QUIT 1
+7 QUIT 0
+8 ; Specimen Type
SPECTYP() ;
+1 NEW DEFSTYP
+2 IF $GET(BWCBE)!$GET(BWMAM)
QUIT ""
+3 ; if Bethesda system used is 'Bethesda 1991' specimen type should be blank.
+4 IF $$PC("all.5.05")=1
QUIT ""
+5 IF $$PC(.3,2)'=""
QUIT $$PC(.3,2)
+6 SET DEFSTYP=$$GET1^DIQ(9002086.02,$GET(DUZ(2)),.24,"I")
IF DEFSTYP
QUIT DEFSTYP
+7 ; If there was not a value in the specimen type field, and there is no default defined, return 1 - Conventional
+8 QUIT 1
MAM1005() ;
+1 QUIT 1
+2 NEW RES
+3 SET RES=0
+4 IF $$MAM1004()
IF $$PC("mam.10.04")
IF $$PC("mam.10.04")'=8
SET RES=1
+5 ;Q:$$PC("mam.10.01")=1!($$PC("mam.10.02")=1)!($$PC("mam.10.03")=1) 1
+6 QUIT RES
