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

BWMDE21.m

Go to the documentation of this file. 
  1. BWMDE21 ;IHS/ANMC/MWR - MDE FUNCTIONS. BWMDE2 CON'T;15-Feb-2003 21:58;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 - CONTINUATION OF BWMDE2 - PATCH 7
  1.  ;
  1. MPREV() ;EP
  1.  ;---> BUILD BW("MAM") ARRAY OF PREVIOUS MAMS.  RETURN 3 IF NONE.
  1.  Q:'BWMAM 3
  1.  N N,Y K BW("MAM") S N=0
  1.  F  S N=$O(^BWPCD("C",BWDFN,N)) Q:'N  D
  1.  .S Y=^BWPCD(N,0)
  1.  .I $$PMAM^BWUTL6(+$P(Y,U,4)) D
  1.  ..S BWMAMDT=$P(Y,U,12)
  1.  ..Q:BWMAMDT'<$P(BW0,U,12)
  1.  ..S BW("MAM",9999999-BWMAMDT)=BWMAMDT
  1.  Q:$D(BW("MAM")) 1
  1.  Q 3
  1.  ;
  1. MPREVDT() ;EP
  1.  ;---> USE ABOVE BW("MAM") ARRAY TO RETURN DATE OF PREVIOUS MAM.
  1.  Q:'BWMAM ""
  1.  Q:'$D(BW("MAM")) ""
  1.  N N
  1.  S N=$O(BW("MAM",0))
  1.  ;Begin Y2k fix
  1.  ;I N S N=BW("MAM",N) K BW("MAM") 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("MAM",N) K BW("MAM") 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. MRESLT() ;EP
  1.  ;---> IF THIS PCD IS NOT MAM:
  1.  ;--->    RETURN 9 IF BR TX NEED=MAM AND DUE DATE IS BEFORE TODAY.
  1.  ;--->    RETURN 8 IF BR TX NEED'=MAM, OR IF BR TX NEED=MAM BUT DUE DATE
  1.  ;--->       IS AFTER TODAY.
  1.  ;--->    BOTH CASES SET BWMABN=0 (ABNORMAL MAM=0).
  1.  ;---> (BWMABN=0 WILL BLANK FILL ALL DATA IN ABNORMAL MAM SECTION.)
  1.  ;
  1.  I 'BWMAM S BWMABN=0 Q " 8"
  1.  ;---> THIS PROCEDURE MUST BE A MAM.
  1.  ;---> IF NO RESULT, RETURN 10 (RESULT PENDING) AND SET BWMABN=0.
  1.  I 'BWRESN S BWMABN=0 Q 10
  1.  ;---> RETURN THE CDC CODE FOR THE RESULT (PC 25).  IF RESULT IS 4,5,
  1.  ;---> OR 6, SET BWMABN=1 TO EXTRACT DATA FOR ABNORMAL MAM SECTION.
  1.  N X S X=$P(^BWDIAG(BWRESN,0),U,25)
  1.  S BWMABN=$S(654[X:1,1:0)
  1.  Q $J(X,2)
  1.  ;
  1. MWKUP() ;EP
  1.  ;---> RETURN THE DX WORKUP: 1=PLANNED, 2=NOT PLANNED, 3=UNDETERMINED.
  1.  Q:'BWMAM 2
  1.  ;Q:'BWMABN 2
  1.  N X
  1.  S X=$P(BW2,U,20)
  1.  Q:X X
  1.  Q 2
  1.  ;
  1. MDT() ;EP
  1.  ;---> DATE OF THIS MAMMOGRAM.
  1.  Q:'BWMAM!'$P(BW0,U,12) ""
  1.  N X
  1.  S X=$$MRESLT
  1.  Q:+X>7 ""
  1.  Q:BWMAM $$CDCDT^BWMDE2($P(BW0,U,12))
  1.  Q ""
  1.  ;
  1. MPAY() ;EP
  1.  ;---> MAM PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
  1.  Q:'BWMAM ""
  1.  N X
  1.  S X=$$MRESLT
  1.  Q:+X>7 ""
  1.  Q 1
  1. BDXPAID() ;EP
  1.  ;---> BREAST DX PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
  1.  Q:'BWMAM ""
  1.  N X S X=$$MRESLT
  1.  Q:+X>7 ""
  1.  Q:BWMAM 1
  1.  Q ""
  1. CBEPAID() ;EP
  1.  ;---> CBE PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
  1.  Q:'BWMAM ""
  1.  N X
  1.  S X=$$MRESLT
  1.  Q:+X>7 ""
  1.  Q:BWMAM 1
  1.  Q ""
  1.  ;
  1. CDXPAID() ;EP
  1.  ;---> CBE PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
  1.  Q:'BWPAP ""
  1.  I '$$CONOBX(),'$$COLPBX(),'$$POTHPR() Q ""
  1.  Q 1
  1.  ;
  1. MDEVER() ;EP
  1.  ;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ  07/17/97
  1.  ;Q 23
  1.  ;Q 24  ;IHS/ANMC/MWRZ 07/17/97 ;CHANGE VERSION# FROM 23 TO 24.
  1.  ;Q 40  ;IHS/CMI/THL 03/25/99 ;CHANGE VERSION# FROM 24 TO 40.
  1.  Q 41  ;IHS/CMI/THL CHANGE VERSION# FROM 40 TO 41.
  1.  ;===> ANMC MODS END, IHS/ANMC/MWRZ  07/17/97
  1.  ;
  1. CONOBX() ;EP
  1.  ;---> COLP DONE WITHOUT BIOPSY.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  ;---> IF THERE IS AN ASSOCIATED COLP, BWC0=ZERO NODE OF THAT PCD.
  1.  Q:BWC0']"" 2
  1.  Q:$P(BWC0,U,26)="" 1
  1.  Q 2
  1.  ;
  1. COLPBX() ;EP
  1.  ;---> COLP DONE WITH BIOPSY.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  ;---> IF THERE IS AN ASSOCIATED COLP, BWC0=ZERO NODE OF THAT PCD.
  1.  Q:BWC0']"" 2
  1.  Q:$P(BWC0,U,26)]"" 1
  1.  Q 2
  1.  ;
  1. POTHPR() ;EP
  1.  ;---> OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL PAP.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  Q:$P(BW2,U,21)]"" 1
  1.  Q 2
  1.  ;
  1. POTHPR1() ;EP
  1.  ;---> LIST OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL PAP.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  Q $E($P(BW2,U,21),1,20)
  1.  ;
  1. POTHPR2() ;EP
  1.  Q ""
  1.  ;
  1. PFNDX() ;EP
  1.  ;---> FINAL DIAGNOSIS FOR ASSOCIATED COLP.
  1.  ;---> FIRST TRY TO GET IT FROM #.33 FIELD; IF NOT, TRY ASSOC'D COLP.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  N X S X=$P(BW0,U,33)
  1.  S:'X X=$P(BWC0,U,5)
  1.  Q:'X ""
  1.  Q:'$D(^BWDIAG(X,0)) ""
  1.  Q $P(^BWDIAG(X,0),U,26)
  1.  ;
  1. PSTGDX() ;EP
  1.  ;---> STAGE AT FINAL DIAGNOSIS.  GET FROM ASSOC'D COLP.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  Q:$$PFNDX()'=6 ""
  1.  Q $P(BWC0,U,31)
  1.  ;
  1. PFNDXO() ;EP
  1.  ;---> FREE TEXT DIAGNOSIS OF "OTHER" FOR ASSOC'D COLP.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  Q:$$PFNDX()'=7 ""
  1.  N X S X=$P(BW0,U,33)
  1.  S:'X X=$P(BWC0,U,5)
  1.  Q:'X ""
  1.  Q:'$D(^BWDIAG(X,0)) ""
  1.  Q $E($P(^BWDIAG(X,0),U),1,20)
  1.  ;
  1. PSTFDX() ;EP
  1.  ;---> PAP STATUS OF FINAL DX.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  Q $P(BW2,U,22)
  1.  ;
  1. PFDXDT() ;EP
  1.  ;---> PAP DATE OF FINAL DX.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  Q $$CDCDT^BWMDE2($P(BW2,U,23))
  1.  ;
  1. PSTTX() ;EP
  1.  ;---> STATUS OF TX.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  Q $P(BW2,U,24)
  1.  ;
  1. PSTXDT() ;EP
  1.  ;---> DATE OF TX STATUS.
  1.  Q:'BWPABN ""
  1.  Q:$$PWKUP>1 ""
  1.  Q $$CDCDT^BWMDE2($P(BW2,U,25))
  1.  ;
  1. MFUDXV() ;EP
  1.  ;---> MAM FOLLOWUP DIAGNOSTIC VIEWW.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW2,U,34)
  1.  ;
  1. MRBREX() ;EP
  1.  ;---> MAM REPEAT BREAST EXAM.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW2,U,26)
  1.  ;
  1. MULTRA() ;EP
  1.  ;---> MAM ULTRASOUND.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW2,U,27)
  1.  ;
  1. MLUMP() ;EP
  1.  ;---> MAM BIOPSY/LUMPECTOMY.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW2,U,28)
  1.  ;
  1. MFINDL() ;EP
  1.  ;---> MAM FINE NEEDLE/CYST ASPIRATION.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW2,U,29)
  1.  ;
  1. MOTHPR() ;EP
  1.  ;---> MAM OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL MAM.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q:$P(BW2,U,21)]"" 1
  1.  Q 2
  1.  ;
  1. MOTHPR1() ;EP
  1.  ;---> LIST OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL PAP.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q:$P(BW2,U,21)]"" $E($P(BW2,U,21),1,20)
  1.  Q ""
  1.  ;
  1. MOTHPR2() ;EP
  1.  ;---> LIST MORE OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL PAP.
  1.  Q ""
  1.  ;Q:'BWMABN ""
  1.  ;
  1. MFNDX() ;EP
  1.  ;---> MAM FINAL DX.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW2,U,30)
  1.  ;
  1. MSTGDX() ;EP
  1.  ;---> MAM STAGE AT FINAL DX.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW0,U,31)
  1.  ;
  1. MTMRSZ() ;EP
  1.  ;---> MAM TUMOR SIZE.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW2,U,31)
  1.  ;
  1. MSTFDX() ;EP
  1.  ;---> MAM STATUS OF FINAL DX.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW2,U,22)
  1.  ;
  1. MFDXDT() ;EP
  1.  ;---> MAM DATE OF FINAL DX.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q:$P(BW2,U,23) $$CDCDT^BWMDE2($P(BW2,U,23))
  1.  Q ""
  1.  ;
  1. MSTTX() ;EP
  1.  ;---> MAM STATUS OF TX.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q $P(BW2,U,24)
  1.  ;
  1. MSTXDT() ;EP
  1.  ;---> MAM DATE OF TX STATUS.
  1.  ;Q:'BWMABN ""
  1.  ;Q:$$MWKUP>1 ""
  1.  Q:$P(BW2,U,25) $$CDCDT^BWMDE2($P(BW2,U,25))
  1.  Q ""
  1.  ;
  1. EOR() ;EP
  1.  Q ""
  1.  ;
  1. HRCN() ;
  1.  ;---> APPEND HEALTH RECORD NUMBER FOR LOCAL PURPOSE.
  1.  Q $$HRCN1^BWUTL1(BWDFN,DUZ(2))
  1. PWKUP() ;EP
  1.  ;---> RETURN THE DX WORKUP: 1=PLANNED, 2=NOT PLANNED, 3=UNDETERMINED.
  1.  Q:'BWPAP 2
  1.  ;IHS/CMI/THL 04/13/99 PATCH 7 TO RETURN CODE 3
  1.  Q:$E($G(BWCDC(+$G(BWIEN))),107,108)=11 3
  1.  Q:'BWPABN 2
  1.  N X S X=$P(BW2,U,20)
  1.  Q:(BWPAP&(X)) X
  1.  Q 2
  1.  ;