Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BWMDE2

BWMDE2.m

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