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

BPXRMWH.m

Go to the documentation of this file. 
  1. BPXRMWH ; IHS/CIA/MGH - Women's health reminders. ;29-Nov-2017 09:29;DU
  1.  ;;2.0;CLINICAL REMINDERS;**1001,1006,1009**;Feb 04, 2005;Build 17
  1.  ;===================================================================
  1.  ;This routine will be used as a computed finding for the last pap smear
  1.  ;and the last mammogram
  1.  ;Patch 1009 fixed infant feeding
  1.  ;=====================================================================
  1. LASTPAP(DFN,TEST,DATE,VALUE,TEXT) ;EP; -- returns last pap date and result
  1.  NEW N,Y,BW,LINE
  1.  I $P(^DPT(DFN,0),U,2)="M" Q ""
  1.  S N=0 F  S N=$O(^BWPCD("C",DFN,N)) Q:'N  D
  1.  .S Y=^BWPCD(N,0)
  1.  .I $P(Y,U,4)=1 S DATE=$P(Y,U,12) D
  1.  ..S BW("PAP",9999999-DATE)=DATE_U_$P(Y,U,5)_U_N
  1.  I '$D(BW("PAP")) S TEST=0,DATE="",TEXT="No PAP on record" Q
  1.  S N=$O(BW("PAP",0))
  1.  I 'N S TEST=0,DATE="",TEXT="No PAP on record"
  1.  E  D
  1.  .S N=BW("PAP",N)
  1.  .S TEST=1,DATE=(+N)
  1.  .S TEXT="Result - "_$$GET1^DIQ(9002086.31,$P(N,U,2),.01)
  1.  .S TEXT=TEXT_" ("_$$GET1^DIQ(9002086.1,$P(N,U,3),.14)_")"
  1.  Q
  1.  ;
  1. LASTMAM(DFN,TEST,DATE,VALUE,TEXT) ;EP; -- returns last mammogram date and result
  1.  NEW N,Y,BW,LINE,X
  1.  I $P(^DPT(DFN,0),U,2)="M" Q ""
  1.  S N=0 F  S N=$O(^BWPCD("C",DFN,N)) Q:'N  D
  1.  . S Y=^BWPCD(N,0)
  1.  . S X=+$P(Y,U,4) I (X'=25)&(X'=26)&(X'=28) Q   ;mamo iens are 25,26,28
  1.  . S DATE=$P(Y,U,12)
  1.  . S BW("MAM",9999999-DATE)=DATE_U_$P(Y,U,5)_U_N_U_$P(Y,U,4)
  1.  I '$D(BW("MAM")) S TEST=0,DATE="",TEXT="No Mammogram on record" Q
  1.  S N=$O(BW("MAM",0))
  1.  I 'N S TEST=0,DATE="",TEXT="No Mammogram on record"
  1.  E  D
  1.  .S N=BW("MAM",N)
  1.  .S TEST=1
  1.  .S DATE=(+N)
  1.  .S TEXT="Result - "_$$GET1^DIQ(9002086.31,+$P(N,U,2),.01)
  1.  .S TEXT=TEXT_" ("_$$GET1^DIQ(9002086.1,$P(N,U,3),.14)_")"
  1.  Q
  1. CURPREG(DFN,TEST,DATE,VALUE,TEXT) ;EP Returns if pt is listed as pregnant in reproductive factors
  1.  N PREG
  1.  S PREG=$$GET1^DIQ(9000017,DFN,1101)
  1.  I PREG="YES" D
  1.  .S TEST=1,DATE=DT,TEXT="Currently Pregnant",VALUE=PREG
  1.  I PREG="NO" D
  1.  .S TEST=0,DATE=DT,VALUE=PREG,TEXT="Not pregnant"
  1.  Q
  1. DEDD(DFN,TEST,DATE,VALUE,TEXT) ;EP Returns true if DEDD+10 days (accounting for overdue) is less then today
  1.  N DEDD,X1,X2,X,EXT,DUE
  1.  S DEDD=$$GET1^DIQ(9000017,DFN,1311,"I")
  1.  S EXT=$$GET1^DIQ(9000017,DFN,1311)
  1.  I +DEDD D
  1.  .S X1=DEDD,X2=+15
  1.  .D C^%DTC
  1.  .S DUE=X
  1.  .I DT<DUE S TEST=1,DATE=DT,TEXT="Apparently Pregnant",VALUE=EXT
  1.  .E  S TEST=0,DATE=DT,VALUE=EXT,TEXT="Apparently not pregnant"
  1.  E  S TEST=0,DATE=DT,VALUE=0,TEXT="No due date found"
  1.  Q
  1. FIRST(DFN,TEST,DATE,VALUE,TEXT) ;Returns true if pt is in first trimester
  1.  N DEDD,EXT,X1,X2,X
  1.  S DEDD=$$GET1^DIQ(9000017,DFN,1311,"I")
  1.  I DEDD="" S TEST=0,DATE=DT,VALUE=0,TEXT="No due date"
  1.  E  D
  1.  .S X1=DEDD,X2=DT D ^%DTC
  1.  .I X>0 D
  1.  ..I ((280-X)/7)<15 D
  1.  ...S VALUE=$J((280-X)/7,4,1)_" weeks"
  1.  ...S TEST=1,DATE=DT,TEXT="First Trimester"
  1.  ..E  S TEST=0,DATE=DT,VALUE=0,TEXT="Not in first trimester"
  1.  .E  S TEST=0,DATE=DT,VALUE=0,TEXT="Not in first trimester"
  1.  Q
  1. THIRD(DFN,TEST,DATE,VALUE,TEXT) ;Returns true if pt is in second trimester
  1.  N DEDD,EXT,X1,X2,X
  1.  S DEDD=$$GET1^DIQ(9000017,DFN,1311,"I")
  1.  I DEDD="" S TEST=0,DATE=DT,VALUE=0,TEXT="No due date"
  1.  E  D
  1.  .S X1=DEDD,X2=DT D ^%DTC
  1.  .I X>0 D
  1.  ..I ((280-X)/7)>27 D
  1.  ...S VALUE=$J((280-X)/7,4,1)_" weeks"
  1.  ...S TEST=1,DATE=DT,TEXT="Third Trimester"
  1.  ..E  S TEST=0,DATE=DT,VALUE=0,TEXT="Not in third trimester"
  1.  .E  D
  1.  ..I X<0&(X>-15) S TEST=1,DATE=DT,VALUE=$J((280-X)/7,4,1)_" weeks",TEXT="Overdue"
  1.  ..E  S TEST=0,DATE=DT,VALUE=0,TEXT="Not in third trimester"
  1.  Q
  1. SECOND(DFN,TEST,DATE,VALUE,TEXT) ;Returns true if pt is in second trimester
  1.  N DEDD,EXT,X1,X2,X
  1.  S DEDD=$$GET1^DIQ(9000017,DFN,1311,"I")
  1.  I DEDD="" S TEST=0,DATE=DT,VALUE=0,TEXT="No due date"
  1.  E  D
  1.  .S X1=DEDD,X2=DT D ^%DTC
  1.  .I X>0 D
  1.  ..I (((280-X)/7)>13)&(((280-X)/7)<28) D
  1.  ...S VALUE=$J((280-X)/7,4,1)_" weeks"
  1.  ...S TEST=1,DATE=DT,TEXT="Second Trimester"
  1.  ..E  S TEST=0,DATE=DT,VALUE=0,TEXT="Not in second trimester"
  1.  .E  S TEST=0,DATE=DT,VALUE=0,TEXT="Not in second trimester"
  1.  Q
  1. CONCEIVE(DFN,TEST,DATE,VALUE,TEXT) ;EP Returns true if pt has contraceptive method for unable to conceive
  1.  N CONT,NODE,METHOD,IENS,NAME,FOUND
  1.  S FOUND=0
  1.  S CONT=0 F  S CONT=$O(^AUPNREP(DFN,2101,CONT)) Q:CONT=""!(FOUND=1)  D
  1.  .S NODE=$G(^AUPNREP(DFN,2101,CONT,0))
  1.  .Q:+$P(NODE,U,3)     ;Must be active so not ended
  1.  .Q:+$P($G(^AUPNREP(DFN,2101,CONT,1)),U,2)  ;Must not be deleted
  1.  .S IENS=CONT_","_DFN
  1.  .S NAME=$$GET1^DIQ(9000017.02101,IENS,.01)
  1.  .I NAME="NA MENOPAUSE"!(NAME="NA POST HYSTERECTOMY")!(NAME="STERILIZATION (FEMALE)") D
  1.  ..S TEST=1,DATE=DT,TEXT="Unable to conceive",VALUE=NAME,FOUND=1
  1.  .E  S TEST=0,DATE=DT,VALUE=NAME,TEXT="Able to conceive"
  1.  Q
  1. FEEDING(DFN,TEST,DATE,VALUE,TEXT) ;Checks infant feeding against input parameter
  1.  N FEED,FIEN,FTIME,FTYP,VIEN
  1.  S FEED=$G(TEST)
  1.  Q:FEED=""
  1.  S FTIME=""
  1.  S FTIME=$O(^AUPNVIF("AA",DFN,FTIME)) Q:FTIME=""  D
  1.  .S FIEN=""  S FIEN=$O(^AUPNVIF("AA",DFN,FTIME,FIEN),-1) Q:'+FIEN  D
  1.  ..S FTYP=$$GET1^DIQ(9000010.44,FIEN,.01)
  1.  ..I FTYP=FEED S TEST=1,VIEN=$$GET1^DIQ(9000010.44,FIEN,.03,"I"),DATE=$$GET1^DIQ(9000010,VIEN,.01,"I"),VALUE=FEED,TEXT="Infant Feeding"
  1.  ..E  S TEST=0,DATE=DT,VALUE=FEED,TEXT="Infant Feeding"
  1.  Q