BWMDE2 ;IHS/ANMC/MWR - MDE FUNCTIONS.;11-Feb-2003 12:34;PLS
;;2.0;WOMEN'S HEALTH;**5,7,8**;MAY 16, 1996
;;Modified for Y2K compliance THL/HJT 5/14/99
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CDC EXPORT, FUNCTIONS TO RETRIEVE DATA FOR INDIVIDUAL FIELDS
;; FOR EXPORT.
;
;IHS/CMI/THL BROKE ROUTINE INTO BWMDE2 AND BWMDE21
;DUE TO ROUTINE SIZE - PATCH 7
;
CDCDT(FMDATE) ;EP
;Begin Y2K fix
;---> CHANGE FILEMAN DATE FORMAT TO CDC DATE FORMAT (MMDDYY).
;Q $E(FMDATE,4,5)_$E(FMDATE,6,7)_($E(FMDATE,2,3))
;
;MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE
;
Q:'FMDATE ""
Q $E(FMDATE,4,5)_$E(FMDATE,6,7)_($E(FMDATE,1,3)+1700) ;Y2000
;
;END MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE
;End Y2k fix
;
STSCR(SITE) ;EP
;---> TRIBAL FIPS CODE.
; Call with SITE = site ien
; Return BWX = 2 digit numeric FIPS or tribal code for state, right justified.
N BWX
S BWX=$P($G(^BWSITE(SITE,0)),U,11)
I BWX]"" S BWX=$$RJ^XLFSTR(BWX,2,"0")
Q BWX
;
;
CNTYSCR(SITE) ;EP
;---> COUNTY OF SCREENING.
; Call with SITE = site ien
; Return BWX = 3 digit numeric FIPS code for county, right justified, if none then return 999.
;
N BWX
S BWX=$P($G(^BWSITE(SITE,0)),U,16)
I BWX>0 S BWX=$$RJ^XLFSTR(BWX,3,"0")
E S BWX=999
Q BWX
;
;
CITY() ;EP
;---> CITY OF SCREENING.
Q $P($G(^AUTTLOC(DUZ(2),0)),U,13)
;
ENROLL() ;EP
;---> ENROLLMENT SITE - DUZ(2) (INSTITUTION FILE).
Q $J($P(BW0,U,10),5)
;
PSCRSI() ;EP
;---> PAP SCREENING SITE--OPTIONAL.
Q:BWPAP $J($P(BW0,U,10),5)
Q ""
;
MSCRSI() ;EP
;---> MAM SCREENING SITE--OPTIONAL.
Q:BWMAM $J($P(BW0,U,10),5)
Q ""
;
PATID() ;EP
;---> UNIQUE PATIENT IDENTIFIER.
D:$$CDCID^BWUTL1(BWDFN)']"" CDCID^BWPATE(BWDFN)
Q $$CDCID^BWUTL1(BWDFN)
;
RECID() ;EP
;---> RECORD IDENTIFIER FOR THIS PATIENT.
;---> FIRST DIGIT IS 1 IF IT'S A PAP, 2 IF IT'S A MAM.
;---> SECOND DIGIT IS THE ONES DIGIT OF THE YEAR, LAST FOUR DIGITS
;---> ARE THE 1-10000 DIGITS OF THE ACCESSION#.
N X
S X=$P(BWACCN,"-",2)
Q $S($E(BWACCN)="P":1,1:2)_$E(BWACCN,4)_$E(X,($L(X)-3),$L(X))
;
RECTYP() ;EP
;---> RECORD TYPE: 1=ADD(NEW), 2=UPDATE.
;Q $P(BW0,U,17)
;---> FOR NOW, PER TELEPHONE CONVERSATION WITH BILL HELSEL 3/12/96,
;---> SINCE WE ARE RE-EXPORTING ALL RECORDS WITH EACH SUBMISSION,
;---> IT'S OKAY TO JUST FLAG THEM ALL AS NEW.
;IHS/CIM/THL PATCH 8 DEFAULT RECORD TYPE CHANGED TO 2
Q 2
;
CNTYRES() ;EP
;---> COUNTY OF RESIDENCE--OPTIONAL.
Q ""
;
STRES() ;EP
;---> STATE OF RESIDENCE, FIPS CODE.
Q:'$D(^DPT(BWDFN,.11)) ""
Q:$P(^DPT(BWDFN,.11),U,5)="" ""
Q $P(^DIC(5,$P(^DPT(BWDFN,.11),U,5),0),U,3)
;
ZIP() ;EP
;---> ZIP OF RESIDENCE.
N X
S X=$E($$ZIP^BWUTL1(BWDFN),1,5)
Q:+X X
Q ""
;
DOB() ;EP
;---> DATE OF BIRTH, FORMAT: 09011956.
N X
S X=$$DOB^BWUTL1(BWDFN)
Q:'+X ""
Q $E(X,4,5)_$E(X,6,7)_($E(X,1,3)+1700)
;
;
ENRLDT() ;EP
;---> ENROLLMENT DATE. IF PATIENT DOESN'T HAVE ENROLLMENT DATE,
;---> COMPUTE IT AND STUFF IT FOR THE PATIENT, THEN USE IT HERE.
N X S X=$P(^BWP(BWDFN,0),U,21)
D:'X ENROL^BWMDE5(BWDFN,$P(^BWSITE(DUZ(2),0),U,17),.X)
;---> IF COMPUTED DATE IS MM/YY ONLY, MAKE IT THE FIRST OF THE MONTH.
S:$E(X,6,7)="00" $E(X,6,7)="01"
Q $$CDCDT(X)
;
REFER() ;EP
;---> REFERRAL SOURCE: IF NOT TRACKED, 4="UNKNOWN".
N X S X=$P(^BWP(BWDFN,0),U,22)
Q:X X
Q 4
;
BRSYMP() ;EP
;---> BREAST SYMTOMS: IF NOT TRACKED, 3="UNKNOWN".
Q:'BWMAM 3
;---> IF THIS PCD IS MAM, RETURN FIELD 2.35 OF BW PROCEDURE FILE,
;---> WHICH SHOULD HAVE BEEN ENTERED MANUALLY.
Q:$P(BW2,U,35) $P(BW2,U,35)
Q 3
;
CBE() ;EP
Q:'BWMAM 3
;---> RETURN FIELD 2.32 OF BW PROCEDURE FILE.
;---> FIELD 2.32 IS ENTERED AUTOMATICALLY IF A CBE IS ADDED FROM
;---> THE "PROCEDURE FOLLOWUP MENU" FOR A PAP; OR, IT IS ENTERED
;---> MANUALLY ON PAGE 2 OF A MAMMOGRAM.
;
;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 12/12/96
;N Z S Z=$P(BW2,U,32)
;Q:('Z&(BWMAM)) ""
;Q:'Z 3
;;---> NOW COLLAPSE CDC CLINCAL CATEGORIES TO 4 MDE CATEGORIES.
;Q:'$D(^BWCBE(Z,0)) 0 ;---> IF ZERO, PROBLEM WITH ^BWCBE POINTER.
;Q $P(^BWCBE(Z,0),U,2)
;
;
;---> GET MANUALLY ENTERED CBE RESULT FOR THIS PROCEDURE.
N Z S Z=$P(BW2,U,32)
;
;---> IF NO CBE RESULT AND THIS IS A PAP, RETURN 3.
Q:('Z&(BWPAP)) 3
;
;---> IF THERE IS A CBE RESULT, RETURN 1-4 MDE CATEGORIES.
;---> (IF ZERO, PROBLEM WITH ^BWCBE POINTER.)
I Z Q:'$D(^BWCBE(Z,0)) 0 Q $P(^BWCBE(Z,0),U,2)
;
;---> IF IT WASN'T A PAP AND ISN'T A MAM, RETURN "" (ERROR).
;
;---> IF NO CBE RESULT AND THIS IS A MAM, LOOK FOR LAST CBE.
N N,Y K BW("CBE") S N=0
F S N=$O(^BWPCD("C",BWDFN,N)) Q:'N D
.S Y=^BWPCD(N,0)
.;---> IF THIS IS A CBE, GET DATE AND RESULT.
.I $P(Y,U,4)=27 S BWCBEDT=$P(Y,U,12),BWCBERS=$P(Y,U,5) D
..Q:BWCBEDT'<$P(BW0,U,12)
..;---> IF CBE IS >1 YEAR BEFORE MAM, IGNORE IT.
..N X,X1,X2,Y S X1=$P(BW0,U,12),X2=BWCBEDT D ^%DTC Q:X>365
..S BW("CBE",9999999-BWCBEDT)=BWCBERS
;
;---> IF NO CBE'S, RETURN "".
Q:'$D(BW("CBE")) ""
;
;---> GET RESULT AND COLLAPSE TO 4 MDE CATEGORIES.
N N S N=$O(BW("CBE",0))
S BWCBERS=$P(BW("CBE",N),U)
Q:BWCBERS=11 1
Q:BWCBERS=64 1
Q:BWCBERS=78 ""
Q:BWCBERS="" ""
Q 2
;
;===> ANMC MODS END, IHS/ANMC/MWRZ 12/12/96
;
;
CBEDT() ;EP
Q:BWPAP ""
;---> RETURN THE DATE OF THE CBE.
;---> NOTE: IF THERE'S A DATE, BUT NO RESULT ABOVE, THEN SEND THE DATE
;---> SO THAT ERROR WILL SHOW UP NEED TO ENTER RESULT FOR THAT CBE.
;Q:789[$P(BW2,U,32) ""
;
;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 12/12/96
;---> IF THE DATE HAS BEEN ENTERED MANUALLY, USE IT.
Q:$P(BW2,U,33) $$CDCDT($P(BW2,U,33))
;---> IF THIS IS A PAP AND NO CBE DATE ENTERED MANUALLY, QUIT ""
;---> (DON'T LOOK AT CBE ARRAY).
;---> THIS MUST BE A MAM, SO LOOK FOR CBE ARRAY.
Q:'$D(BW("CBE")) ""
;---> USE ABOVE BW("CBE") ARRAY TO RETURN DATE OF LAST CBE.
N N S N=$O(BW("CBE",0))
Q:'N ""
Q $$CDCDT(9999999-N)
;===> ANMC MODS END, IHS/ANMC/MWRZ 12/12/96
;
PPREV() ;EP
;---> BUILD BW("PAP") ARRAY OF PREVIOUS PAPS. RETURN 3 IF NONE.
Q:'BWPAP 3
N N,Y K BW("PAP") S N=0
F S N=$O(^BWPCD("C",BWDFN,N)) Q:'N D
.S Y=^BWPCD(N,0)
.I $P(Y,U,4)=1 S BWPAPDT=$P(Y,U,12) D
..Q:BWPAPDT'<$P(BW0,U,12)
..S BW("PAP",9999999-BWPAPDT)=BWPAPDT
Q:$D(BW("PAP")) 1
Q 3
;
PPREVDT() ;EP
Q:'BWPAP ""
;---> USE ABOVE BW("PAP") ARRAY TO RETURN DATE OF PREVIOUS PAP.
Q:'$D(BW("PAP")) ""
N N
S N=$O(BW("PAP",0))
;Begin Y2k fix
;I N S N=BW("PAP",N) K BW("PAP") Q $E(N,4,5)_$E(N,2,3)
;
;MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE
;
I N S N=BW("PAP",N) K BW("PAP") Q $E(N,4,5)_($E(N,1,3)+1700) ;Y2000
;
;END MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE
;End Y2k fix
;
Q ""
;
ADQPAP() ;EP
;---> ADEQUACY OF SCREENING PAP--OPTIONAL.
Q ""
;
;
PRESLT() ;EP
;---> IF THIS PCD IS NOT PAP, RETURN 9 & SET BWPABN=0 (ABNORMAL PAP=0).
;---> (BWPABN=0 WILL BLANK FILL ALL DATA IN ABNORMAL PAP SECTION.)
;
I 'BWPAP S BWPABN=0 Q " 9"
;---> THIS PROCEDURE MUST BE A PAP.
;---> IF NO RESULT, RETURN 11 (RESULT PENDING) AND SET BWPABN=0.
I 'BWRESN S BWPABN=0 Q 11
;
;---> RETURN THE CDC CODE FOR THE RESULT (PC 24). IF RESULT IS 3,4,5
;---> OR 6, SET BWPABN=1 TO EXTRACT DATA FOR ABNORMAL PAP SECTION.
N X S X=$P(^BWDIAG(BWRESN,0),U,24)
S BWPABN=$S(6543[X!(X=14):1,1:0)
Q $J(X,2)
;
POTHR() ;EP
;---> IF RESULT IS "OTHER" (7), RETURN TEXT OF THE RESULT
Q:'BWPAP ""
Q:'BWRESN ""
Q:$P(^BWDIAG(BWRESN,0),U,24)=7 $E(BWRES,1,20)
Q ""
;
PSCRDT() ;EP
;---> IF THIS PCD IS A PAP, RETURN THE DATE OF THIS PCD.
Q:'BWPAP ""
Q:BWPAP $$CDCDT($P(BW0,U,12))
;
PPAY() ;EP
;---> PAP PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
Q:'BWPAP ""
N X
S X=$$PRESLT
Q:X=9!(X=10)!(X=11) ""
Q:BWPAP 1
Q 3
BWMDE2 ;IHS/ANMC/MWR - MDE FUNCTIONS.;11-Feb-2003 12:34;PLS
+1 ;;2.0;WOMEN'S HEALTH;**5,7,8**;MAY 16, 1996
+2 ;;Modified for Y2K compliance THL/HJT 5/14/99
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; CDC EXPORT, FUNCTIONS TO RETRIEVE DATA FOR INDIVIDUAL FIELDS
+5 ;; FOR EXPORT.
+6 ;
+7 ;IHS/CMI/THL BROKE ROUTINE INTO BWMDE2 AND BWMDE21
+8 ;DUE TO ROUTINE SIZE - PATCH 7
+9 ;
CDCDT(FMDATE) ;EP
+1 ;Begin Y2K fix
+2 ;---> CHANGE FILEMAN DATE FORMAT TO CDC DATE FORMAT (MMDDYY).
+3 ;Q $E(FMDATE,4,5)_$E(FMDATE,6,7)_($E(FMDATE,2,3))
+4 ;
+5 ;MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE
+6 ;
+7 IF 'FMDATE
QUIT ""
+8 ;Y2000
QUIT $EXTRACT(FMDATE,4,5)_$EXTRACT(FMDATE,6,7)_($EXTRACT(FMDATE,1,3)+1700)
+9 ;
+10 ;END MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE
+11 ;End Y2k fix
+12 ;
STSCR(SITE) ;EP
+1 ;---> TRIBAL FIPS CODE.
+2 ; Call with SITE = site ien
+3 ; Return BWX = 2 digit numeric FIPS or tribal code for state, right justified.
+4 NEW BWX
+5 SET BWX=$PIECE($GET(^BWSITE(SITE,0)),U,11)
+6 IF BWX]""
SET BWX=$$RJ^XLFSTR(BWX,2,"0")
+7 QUIT BWX
+8 ;
+9 ;
CNTYSCR(SITE) ;EP
+1 ;---> COUNTY OF SCREENING.
+2 ; Call with SITE = site ien
+3 ; Return BWX = 3 digit numeric FIPS code for county, right justified, if none then return 999.
+4 ;
+5 NEW BWX
+6 SET BWX=$PIECE($GET(^BWSITE(SITE,0)),U,16)
+7 IF BWX>0
SET BWX=$$RJ^XLFSTR(BWX,3,"0")
+8 IF '$TEST
SET BWX=999
+9 QUIT BWX
+10 ;
+11 ;
CITY() ;EP
+1 ;---> CITY OF SCREENING.
+2 QUIT $PIECE($GET(^AUTTLOC(DUZ(2),0)),U,13)
+3 ;
ENROLL() ;EP
+1 ;---> ENROLLMENT SITE - DUZ(2) (INSTITUTION FILE).
+2 QUIT $JUSTIFY($PIECE(BW0,U,10),5)
+3 ;
PSCRSI() ;EP
+1 ;---> PAP SCREENING SITE--OPTIONAL.
+2 IF BWPAP
QUIT $JUSTIFY($PIECE(BW0,U,10),5)
+3 QUIT ""
+4 ;
MSCRSI() ;EP
+1 ;---> MAM SCREENING SITE--OPTIONAL.
+2 IF BWMAM
QUIT $JUSTIFY($PIECE(BW0,U,10),5)
+3 QUIT ""
+4 ;
PATID() ;EP
+1 ;---> UNIQUE PATIENT IDENTIFIER.
+2 IF $$CDCID^BWUTL1(BWDFN)']""
DO CDCID^BWPATE(BWDFN)
+3 QUIT $$CDCID^BWUTL1(BWDFN)
+4 ;
RECID() ;EP
+1 ;---> RECORD IDENTIFIER FOR THIS PATIENT.
+2 ;---> FIRST DIGIT IS 1 IF IT'S A PAP, 2 IF IT'S A MAM.
+3 ;---> SECOND DIGIT IS THE ONES DIGIT OF THE YEAR, LAST FOUR DIGITS
+4 ;---> ARE THE 1-10000 DIGITS OF THE ACCESSION#.
+5 NEW X
+6 SET X=$PIECE(BWACCN,"-",2)
+7 QUIT $SELECT($EXTRACT(BWACCN)="P":1,1:2)_$EXTRACT(BWACCN,4)_$EXTRACT(X,($LENGTH(X)-3),$LENGTH(X))
+8 ;
RECTYP() ;EP
+1 ;---> RECORD TYPE: 1=ADD(NEW), 2=UPDATE.
+2 ;Q $P(BW0,U,17)
+3 ;---> FOR NOW, PER TELEPHONE CONVERSATION WITH BILL HELSEL 3/12/96,
+4 ;---> SINCE WE ARE RE-EXPORTING ALL RECORDS WITH EACH SUBMISSION,
+5 ;---> IT'S OKAY TO JUST FLAG THEM ALL AS NEW.
+6 ;IHS/CIM/THL PATCH 8 DEFAULT RECORD TYPE CHANGED TO 2
+7 QUIT 2
+8 ;
CNTYRES() ;EP
+1 ;---> COUNTY OF RESIDENCE--OPTIONAL.
+2 QUIT ""
+3 ;
STRES() ;EP
+1 ;---> STATE OF RESIDENCE, FIPS CODE.
+2 IF '$DATA(^DPT(BWDFN,.11))
QUIT ""
+3 IF $PIECE(^DPT(BWDFN,.11),U,5)=""
QUIT ""
+4 QUIT $PIECE(^DIC(5,$PIECE(^DPT(BWDFN,.11),U,5),0),U,3)
+5 ;
ZIP() ;EP
+1 ;---> ZIP OF RESIDENCE.
+2 NEW X
+3 SET X=$EXTRACT($$ZIP^BWUTL1(BWDFN),1,5)
+4 IF +X
QUIT X
+5 QUIT ""
+6 ;
DOB() ;EP
+1 ;---> DATE OF BIRTH, FORMAT: 09011956.
+2 NEW X
+3 SET X=$$DOB^BWUTL1(BWDFN)
+4 IF '+X
QUIT ""
+5 QUIT $EXTRACT(X,4,5)_$EXTRACT(X,6,7)_($EXTRACT(X,1,3)+1700)
+6 ;
+7 ;
ENRLDT() ;EP
+1 ;---> ENROLLMENT DATE. IF PATIENT DOESN'T HAVE ENROLLMENT DATE,
+2 ;---> COMPUTE IT AND STUFF IT FOR THE PATIENT, THEN USE IT HERE.
+3 NEW X
SET X=$PIECE(^BWP(BWDFN,0),U,21)
+4 IF 'X
DO ENROL^BWMDE5(BWDFN,$PIECE(^BWSITE(DUZ(2),0),U,17),.X)
+5 ;---> IF COMPUTED DATE IS MM/YY ONLY, MAKE IT THE FIRST OF THE MONTH.
+6 IF $EXTRACT(X,6,7)="00"
SET $EXTRACT(X,6,7)="01"
+7 QUIT $$CDCDT(X)
+8 ;
REFER() ;EP
+1 ;---> REFERRAL SOURCE: IF NOT TRACKED, 4="UNKNOWN".
+2 NEW X
SET X=$PIECE(^BWP(BWDFN,0),U,22)
+3 IF X
QUIT X
+4 QUIT 4
+5 ;
BRSYMP() ;EP
+1 ;---> BREAST SYMTOMS: IF NOT TRACKED, 3="UNKNOWN".
+2 IF 'BWMAM
QUIT 3
+3 ;---> IF THIS PCD IS MAM, RETURN FIELD 2.35 OF BW PROCEDURE FILE,
+4 ;---> WHICH SHOULD HAVE BEEN ENTERED MANUALLY.
+5 IF $PIECE(BW2,U,35)
QUIT $PIECE(BW2,U,35)
+6 QUIT 3
+7 ;
CBE() ;EP
+1 IF 'BWMAM
QUIT 3
+2 ;---> RETURN FIELD 2.32 OF BW PROCEDURE FILE.
+3 ;---> FIELD 2.32 IS ENTERED AUTOMATICALLY IF A CBE IS ADDED FROM
+4 ;---> THE "PROCEDURE FOLLOWUP MENU" FOR A PAP; OR, IT IS ENTERED
+5 ;---> MANUALLY ON PAGE 2 OF A MAMMOGRAM.
+6 ;
+7 ;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 12/12/96
+8 ;N Z S Z=$P(BW2,U,32)
+9 ;Q:('Z&(BWMAM)) ""
+10 ;Q:'Z 3
+11 ;;---> NOW COLLAPSE CDC CLINCAL CATEGORIES TO 4 MDE CATEGORIES.
+12 ;Q:'$D(^BWCBE(Z,0)) 0 ;---> IF ZERO, PROBLEM WITH ^BWCBE POINTER.
+13 ;Q $P(^BWCBE(Z,0),U,2)
+14 ;
+15 ;
+16 ;---> GET MANUALLY ENTERED CBE RESULT FOR THIS PROCEDURE.
+17 NEW Z
SET Z=$PIECE(BW2,U,32)
+18 ;
+19 ;---> IF NO CBE RESULT AND THIS IS A PAP, RETURN 3.
+20 IF ('Z&(BWPAP))
QUIT 3
+21 ;
+22 ;---> IF THERE IS A CBE RESULT, RETURN 1-4 MDE CATEGORIES.
+23 ;---> (IF ZERO, PROBLEM WITH ^BWCBE POINTER.)
+24 IF Z
IF '$DATA(^BWCBE(Z,0))
QUIT 0
QUIT $PIECE(^BWCBE(Z,0),U,2)
+25 ;
+26 ;---> IF IT WASN'T A PAP AND ISN'T A MAM, RETURN "" (ERROR).
+27 ;
+28 ;---> IF NO CBE RESULT AND THIS IS A MAM, LOOK FOR LAST CBE.
+29 NEW N,Y
KILL BW("CBE")
SET N=0
+30 FOR
SET N=$ORDER(^BWPCD("C",BWDFN,N))
IF 'N
QUIT
Begin DoDot:1
+31 SET Y=^BWPCD(N,0)
+32 ;---> IF THIS IS A CBE, GET DATE AND RESULT.
+33 IF $PIECE(Y,U,4)=27
SET BWCBEDT=$PIECE(Y,U,12)
SET BWCBERS=$PIECE(Y,U,5)
Begin DoDot:2
+34 IF BWCBEDT'<$PIECE(BW0,U,12)
QUIT
+35 ;---> IF CBE IS >1 YEAR BEFORE MAM, IGNORE IT.
+36 NEW X,X1,X2,Y
SET X1=$PIECE(BW0,U,12)
SET X2=BWCBEDT
DO ^%DTC
IF X>365
QUIT
+37 SET BW("CBE",9999999-BWCBEDT)=BWCBERS
End DoDot:2
End DoDot:1
+38 ;
+39 ;---> IF NO CBE'S, RETURN "".
+40 IF '$DATA(BW("CBE"))
QUIT ""
+41 ;
+42 ;---> GET RESULT AND COLLAPSE TO 4 MDE CATEGORIES.
+43 NEW N
SET N=$ORDER(BW("CBE",0))
+44 SET BWCBERS=$PIECE(BW("CBE",N),U)
+45 IF BWCBERS=11
QUIT 1
+46 IF BWCBERS=64
QUIT 1
+47 IF BWCBERS=78
QUIT ""
+48 IF BWCBERS=""
QUIT ""
+49 QUIT 2
+50 ;
+51 ;===> ANMC MODS END, IHS/ANMC/MWRZ 12/12/96
+52 ;
+53 ;
CBEDT() ;EP
+1 IF BWPAP
QUIT ""
+2 ;---> RETURN THE DATE OF THE CBE.
+3 ;---> NOTE: IF THERE'S A DATE, BUT NO RESULT ABOVE, THEN SEND THE DATE
+4 ;---> SO THAT ERROR WILL SHOW UP NEED TO ENTER RESULT FOR THAT CBE.
+5 ;Q:789[$P(BW2,U,32) ""
+6 ;
+7 ;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 12/12/96
+8 ;---> IF THE DATE HAS BEEN ENTERED MANUALLY, USE IT.
+9 IF $PIECE(BW2,U,33)
QUIT $$CDCDT($PIECE(BW2,U,33))
+10 ;---> IF THIS IS A PAP AND NO CBE DATE ENTERED MANUALLY, QUIT ""
+11 ;---> (DON'T LOOK AT CBE ARRAY).
+12 ;---> THIS MUST BE A MAM, SO LOOK FOR CBE ARRAY.
+13 IF '$DATA(BW("CBE"))
QUIT ""
+14 ;---> USE ABOVE BW("CBE") ARRAY TO RETURN DATE OF LAST CBE.
+15 NEW N
SET N=$ORDER(BW("CBE",0))
+16 IF 'N
QUIT ""
+17 QUIT $$CDCDT(9999999-N)
+18 ;===> ANMC MODS END, IHS/ANMC/MWRZ 12/12/96
+19 ;
PPREV() ;EP
+1 ;---> BUILD BW("PAP") ARRAY OF PREVIOUS PAPS. RETURN 3 IF NONE.
+2 IF 'BWPAP
QUIT 3
+3 NEW N,Y
KILL BW("PAP")
SET N=0
+4 FOR
SET N=$ORDER(^BWPCD("C",BWDFN,N))
IF 'N
QUIT
Begin DoDot:1
+5 SET Y=^BWPCD(N,0)
+6 IF $PIECE(Y,U,4)=1
SET BWPAPDT=$PIECE(Y,U,12)
Begin DoDot:2
+7 IF BWPAPDT'<$PIECE(BW0,U,12)
QUIT
+8 SET BW("PAP",9999999-BWPAPDT)=BWPAPDT
End DoDot:2
End DoDot:1
+9 IF $DATA(BW("PAP"))
QUIT 1
+10 QUIT 3
+11 ;
PPREVDT() ;EP
+1 IF 'BWPAP
QUIT ""
+2 ;---> USE ABOVE BW("PAP") ARRAY TO RETURN DATE OF PREVIOUS PAP.
+3 IF '$DATA(BW("PAP"))
QUIT ""
+4 NEW N
+5 SET N=$ORDER(BW("PAP",0))
+6 ;Begin Y2k fix
+7 ;I N S N=BW("PAP",N) K BW("PAP") Q $E(N,4,5)_$E(N,2,3)
+8 ;
+9 ;MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE
+10 ;
+11 ;Y2000
IF N
SET N=BW("PAP",N)
KILL BW("PAP")
QUIT $EXTRACT(N,4,5)_($EXTRACT(N,1,3)+1700)
+12 ;
+13 ;END MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE
+14 ;End Y2k fix
+15 ;
+16 QUIT ""
+17 ;
ADQPAP() ;EP
+1 ;---> ADEQUACY OF SCREENING PAP--OPTIONAL.
+2 QUIT ""
+3 ;
+4 ;
PRESLT() ;EP
+1 ;---> IF THIS PCD IS NOT PAP, RETURN 9 & SET BWPABN=0 (ABNORMAL PAP=0).
+2 ;---> (BWPABN=0 WILL BLANK FILL ALL DATA IN ABNORMAL PAP SECTION.)
+3 ;
+4 IF 'BWPAP
SET BWPABN=0
QUIT " 9"
+5 ;---> THIS PROCEDURE MUST BE A PAP.
+6 ;---> IF NO RESULT, RETURN 11 (RESULT PENDING) AND SET BWPABN=0.
+7 IF 'BWRESN
SET BWPABN=0
QUIT 11
+8 ;
+9 ;---> RETURN THE CDC CODE FOR THE RESULT (PC 24). IF RESULT IS 3,4,5
+10 ;---> OR 6, SET BWPABN=1 TO EXTRACT DATA FOR ABNORMAL PAP SECTION.
+11 NEW X
SET X=$PIECE(^BWDIAG(BWRESN,0),U,24)
+12 SET BWPABN=$SELECT(6543[X!(X=14):1,1:0)
+13 QUIT $JUSTIFY(X,2)
+14 ;
POTHR() ;EP
+1 ;---> IF RESULT IS "OTHER" (7), RETURN TEXT OF THE RESULT
+2 IF 'BWPAP
QUIT ""
+3 IF 'BWRESN
QUIT ""
+4 IF $PIECE(^BWDIAG(BWRESN,0),U,24)=7
QUIT $EXTRACT(BWRES,1,20)
+5 QUIT ""
+6 ;
PSCRDT() ;EP
+1 ;---> IF THIS PCD IS A PAP, RETURN THE DATE OF THIS PCD.
+2 IF 'BWPAP
QUIT ""
+3 IF BWPAP
QUIT $$CDCDT($PIECE(BW0,U,12))
+4 ;
PPAY() ;EP
+1 ;---> PAP PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
+2 IF 'BWPAP
QUIT ""
+3 NEW X
+4 SET X=$$PRESLT
+5 IF X=9!(X=10)!(X=11)
QUIT ""
+6 IF BWPAP
QUIT 1
+7 QUIT 3
