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

BWMDEU2.m

Go to the documentation of this file. 
  1. BWMDEU2 ;IHS/ANMC/MWR - MDE FUNCTIONS. BWMDEU CON'T;29-Oct-2003 21:36;PLS
  1.  ;;2.0;WOMEN'S HEALTH;**8,9**;MAY 16, 1996
  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.  ;
  1. MWKUP() ;EP
  1.  ;---> RETURN THE DX WORKUP: 1=PLANNED, 2=NOT PLANNED, 3=UNDETERMINED.
  1.  N X
  1.  S X=$P(BW2,U,20)
  1.  Q:X X
  1.  Q 2
  1.  ;
  1.  ;
  1. MPAY() ;EP
  1.  ;---> MAM PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
  1.  N X
  1.  S X=$$MRESLT
  1.  Q:+X>7 ""
  1.  Q 1
  1.  ;
  1.  ;
  1. BDXPAID() ;EP
  1.  ;---> BREAST DX PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
  1.  N X S X=$$MRESLT
  1.  Q:+X>7 ""
  1.  Q:BWMAM 1
  1.  Q ""
  1.  ;
  1.  ;
  1. CBEPAID() ;EP
  1.  ;---> CBE PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
  1.  N X
  1.  S X=$$MRESLT
  1.  Q:+X>7 ""
  1.  Q:BWMAM 1
  1.  Q ""
  1.  ;
  1.  ;
  1. CDXPAID() ;EP
  1.  ;---> CBE PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW.
  1.  I '$$CONOBX(),'$$COLPBX() Q ""
  1.  Q 1
  1.  ;
  1.  ;
  1. CONOBX() ; EP
  1.  ; Colposcopy Impression (No Biopsy)
  1.  ; BWC0 holds the zero node of the Colposcopy procedure
  1.  ; Procedure must be a Colposcopy Impression
  1.  ; Return: 1 = Yes, 2 = No
  1.  Q $S(+$P($G(BWC0),U,4)=37:1,1:2)
  1.  ;
  1.  ;
  1. COLPBX() ;EP
  1.  ; Colposcopy w/Biopsy
  1.  ; BWC0 holds the zero node of the Colposcopy procedure
  1.  ; Procedure must be a Colposcopy Biopsy
  1.  ; Return: 1 = Yes, 2 = No
  1.  Q $S(+$P($G(BWC0),U,4)=2:1,1:2)
  1.  ;
  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.  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.  ;
  1. PSTGDX(BWFNDX,BWX) ; EP - Stage at final diagnosis.  GET FROM ASSOC'D COLP.
  1.  ; Call with BWFNDX = final diagnosis
  1.  ;              BWX = zeroth node of assoc'd colp.
  1.  ;
  1.  ; Returns BWSTAGE = CDC stage at diagnosis
  1.  ;
  1.  N BWSTAGE
  1.  S BWSTAGE=""
  1.  I BWFNDX=6 S BWSTAGE=$P(BWX,U,31)
  1.  Q BWSTAGE
  1.  ;
  1.  ;
  1. PFNDXO() ; EP - FREE TEXT DIAGNOSIS OF "OTHER" FOR ASSOC'D COLP.
  1.  Q:$$PFNDX()'=7 ""
  1.  N X
  1.  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.  ;
  1. CDCDT(BWDT) ; EP: Convert FileMan date to CDC date format
  1.  ; Call with BWDT = FileMan date
  1.  ;
  1.  ; Returns    BWY = date in CDC MMDDYYYY format
  1.  ;
  1.  I BWDT S BWY=$TR($$FMTE^XLFDT(BWDT,"5DZ"),"/")
  1.  E  S BWY=$$REPEAT^XLFSTR(" ",8)
  1.  Q BWY