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