1:18 AM  21-NOV-96
Patch **1** Routines for Women's Health v2.0 - Michael Remillard, IHS/ANMC
BWPROF
BWPROF ;IHS/ANMC/MWR - DISPLAY PATIENT PROFILE; [ 11/21/96  1:12 AM ]
 ;;2.0;WOMEN'S HEALTH;**1**;MAY 16, 1996
 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
 ;;  CALL ED BY OPTION: "BW PATIENT PROFILE" TO DISPLAY PROFILE.
 ;;  PATCHED AT LINELABEL PROFCALL.  IHS/ANMC/MWR 11/20/96
 ;
 ;---> *NOTE: TO ASK DATE RANGE, UNCOMMENT ALL LINES WITH "XDATES",
 ;--->        AND IN HEADER2^BWUTL7.
 ;
 ;---> VARIABLES:
 ;---> BWDFN: DFN OF SELECTED PATIENT
 ;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE
 ;---> USE NODES 1 & 2 IN ^TMP GLOBAL.
 ;
 D SETVARS^BWUTL5
 S:'$D(BWERRORS) BWERRORS=1
 F  D RUN Q:BWPOP
 D EXIT
 Q
 ;
RUN ;EP
 D TITLE^BWUTL5("PATIENT PROFILE")
 D PATIENT Q:BWPOP
 ;D DATES  Q:BWPOP
 D BRIEF   Q:BWPOP
 D DEVICE  Q:BWPOP
 D SORT^BWPROF2
 D COPYGBL
 D ^BWPROF1 S BWPOP=0
 K BWD,BWSUBH
 Q
 ;
EXIT ;EP
 D KILLALL^BWUTL8
 Q
 ;
 ;
PATIENT ;EP
 ;---> SELECT PATIENT (RETURN BWDFN).
 W !!,"   Select the patient whose Profile you wish to display."
 D PATLKUP^BWUTL8(.Y) S:Y<0 BWPOP=1
 ;---> USE NEXT LINE IF I WANT TO ADD CAPABILITY OF ADDING NEW PATIENT.
 ;D PATLKUP^BWUTL8(.Y,$S($G(BWPUSER):"",1:"ADD")) S:Y<0 BWPOP=1
 S BWDFN=+Y
 Q
 ;
DATES ;EP
 ;---> ASK DATE RANGE.  RETURN DATES IN BWBEGDT AND BWENDDT.
 ;---> IF LOOKING AT ONLY ONE PATIENT, SET DEFAULT BEGIN DATE=T-5YEARS.
 ;S BWBEGDT=2500101,BWENDDT=DT     ;---> XDATES-CAN USE THIS INSTEAD.
 ;S BWBEGDF="T-60M",BWENDDF="T"    ;---> XDATES
 ;D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP,"T-365","T")  ;---> XDATES
 Q
 ;
BRIEF ;EP
 ;---> BRIEF OR DETAILED LISTING OF PROCEDURES (BRIEF DOES NOT LIST
 ;---> NOTIFICATIONS AND PROVIDERS).
 N DIR,DIRUT,Y
 W !!?3,"List Patient Profile in BRIEF or DETAILED format?"
 S DIR("A")="   Select BRIEF or DETAILED: ",DIR("B")="BRIEF"
 S DIR(0)="SAM^b:BRIEF;d:DETAILED" D HELP1
 D ^DIR
 I Y=-1!($D(DIRUT)) S BWPOP=1 Q
 ;---> IF ALL DETAILED, S BWD=1; FOR BRIEF BWD=0
 S BWD=$S(Y="d":1,1:0)
 Q
 ;
DEVICE ;EP
 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
 S ZTRTN="DEQUEUE^BWPROF"
 F BWSV="D","DFN","BEGDT","ENDDT","ERRORS" D
 .I $D(@("BW"_BWSV)) S ZTSAVE("BW"_BWSV)=""
 D ZIS^BWUTL2(.BWPOP,1,"HOME")
 Q
 ;
COPYGBL ;EP
 ;---> COPY ^TMP("BW",$J,1 TO ^TMP("BW",$J,2 TO MAKE IT FLAT.
 N I,M,N,P,Q
 S N=0,I=0
 F  S N=$O(^TMP("BW",$J,1,N)) Q:N=""  D
 .S M=0
 .F  S M=$O(^TMP("BW",$J,1,N,M)) Q:M=""  D
 ..S P=0
 ..F  S P=$O(^TMP("BW",$J,1,N,M,P)) Q:P=""  D
 ...S Q=0
 ...F  S Q=$O(^TMP("BW",$J,1,N,M,P,Q)) Q:Q=""  D
 ....S I=I+1,^TMP("BW",$J,2,I)=^TMP("BW",$J,1,N,M,P,Q)
 Q
 ;
 ;
DEQUEUE ;EP
 ;---> EP FOR TASKMAN QUEUE OF PRINTOUT.
 D SETVARS^BWUTL5,SORT^BWPROF2,COPYGBL,^BWPROF1,EXIT
 Q
 ;
HELP1 ;EP
 ;;Enter "D" for a "Detailed" listing of the patient's Procedures,
 ;;Notifications, PAP Regimen and Pregnancy changes.
 ;;Enter "B" for a "Brief" listing of the patient's Procedures only.
 S BWTAB=5,BWLINL="HELP1" D HELPTX
 Q
 ;
HELPTX ;EP
 ;---> CREATES DIR ARRAY FOR DIR.  REQUIRED VARIABLES: BWTAB,BWLINL.
 N I,T,X S T="" F I=1:1:BWTAB S T=T_" "
 F I=1:1 S X=$T(@BWLINL+I) Q:X'[";;"  S DIR("?",I)=T_$P(X,";;",2)
 S DIR("?")=DIR("?",I-1) K DIR("?",I-1)
 Q
 ;
 ;
USER ;EP
 ;---> CALLED BY OPTION: "BW PATIENT PROFILE USER"
 ;---> FOR USER TO VIEW PROFILE AND PRINT PROCEDURES, BUT NO EDIT.
 S BWPUSER=1
 D BWPROF K BWPUSER
 Q
 ;
PROFCALL(BWDFN) ;EP
 ;---> PATCHED: EARLIER METHODS FOR OTHER PACKAGES TO PRODUCE A
 ;---> WOMEN'S HEALTH PROFILE WERE TO CUMBERSOME AND ERROR PRONE.
 ;---> USED TO CALL A PATIENT PROFILE (DISPLAY ONLY) WITH PATIENT
 ;---> ALREADY SELECTED.  DFN PASSED AS FIRST PARAMETER.
 ;---> THIS ENTIRE CALL HAS BEEN ADDED AS A PATCH. IHS/ANMC/MWR 11/20/96
 I '$G(BWDFN) D  Q
 .W !?5,"Patient DFN was not passed.  Please contact your site manager."
 .D DIRZ^BWUTL3
 I '$D(^BWP(BWDFN,0)) D  Q
 .W !?5,"This patient is not currently in the Women's Health Database."
 .D DIRZ^BWUTL3
 N (BWDFN)
 D SETVARS^BWUTL5 S BWERRORS=1,BWPUSER=1
 D BRIEF  Q:BWPOP
 D DEVICE Q:BWPOP
 D SORT^BWPROF2
 D COPYGBL
 D ^BWPROF1
 Q
 ;
ERRORS ;EP
 ;---> CALLED BY OPTION: "BW PATIENT PROFILE W/ERRORS"
 ;---> ENTER HERE TO INCLUDE ERRONEOUS ENTRIES.
 S BWERRORS=0 G BWPROF
 Q

BWRPSCR
BWRPSCR ;IHS/ANMC/MWR - WOMEN'S HEALTH PCC LINK [ 11/21/96  1:15 AM ]
 ;;2.0;WOMEN'S HEALTH;**1**;MAY 16, 1996
 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
 ;;  THIS REPORT WILL DISPLAY SCREENING RATES FOR PAPS & MAMS.
 ;;  PATCHED AT LINELABEL CURCOM.  IHS/ANMC/MWR 11/20/96
 ;
PRINT ;EP
 ;---> DISPLAY PROCEDURE PCC .01 POINTERS.
 D SETUP
 D TITLE^BWUTL5("SCREENING RATES FOR PAPS AND MAMS")
 D TEXT1,DIRZ^BWUTL3 G:BWPOP EXIT
 D DATES   G:BWPOP EXIT
 D AGERNG  G:BWPOP EXIT
 D CURCOM  G:BWPOP EXIT
 D DEVICE  G:BWPOP EXIT
 D DATA^BWRPSCR1
 D DISPLAY
 ;
EXIT ;EP
 D KILLALL^BWUTL8
 Q
 ;
SETUP ;EP
 D SETVARS^BWUTL5
 Q
 ;
DATES ;EP
 ;---> ASK DATE RANGE.  RETURN DATES IN BWBEGDT AND BWENDDT.
 D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP)
 Q
 ;
AGERNG ;EP
 ;---> ASK AGE RANGE.
 ;---> RETURN AGE RANGE IN BWAGRG.
 D AGERNG^BWRPSCR1(.BWAGRG,.BWPOP)
 Q
 ;
CURCOM ;EP
 ;---> SELECT CASES FOR ONE OR MORE CURRENT COMMUNITY (OR ALL).
 ;---> DO NOT PROMPT FOR CURRENT COMMUNITY IF THIS IS A VA SITE.
 ;I $$AGENCY^BWUTL5(DUZ(2))='"i" S BWCC("ALL")="" Q   ;VAMOD
 I $$AGENCY^BWUTL5(DUZ(2))'="i" D  Q  ;IHS/ANMC/MWR 11/20/96
 .S BWCC("ALL")=""                    ;IHS/ANMC/MWR 11/20/96
 ;---> SELECT CURRENT COMMUNITY(S).
 D TEXT2
 D SELECT^BWSELECT("Current Community",9999999.05,"BWCC","","",.BWPOP)
 Q
 ;
DEVICE ;EP
 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
 S ZTRTN="DEQUEUE^BWRPSCR"
 F BWSV="AGRG","BEGDT","ENDDT" D
 .I $D(@("BW"_BWSV)) S ZTSAVE("BW"_BWSV)=""
 ;---> SAVE ATTRIBUTES ARRAY. NOTE: SUBSTITUTE LOCAL ARRAY FOR BWATT.
 I $D(BWCC) N N S N=0 F  S N=$O(BWCC(N)) Q:N=""  D
 .S ZTSAVE("BWCC("""_N_""")")=""
 D ZIS^BWUTL2(.BWPOP,1,"HOME")
 Q
 ;
 ;
DISPLAY ;EP
 U IO
 S BWTITLE="*  WOMEN'S HEALTH: SCREENING RATES FOR PAPS AND MAMS  *"
 D CENTERT^BWUTL5(.BWTITLE)
 D TOPHEAD^BWUTL7
 S BWPAGE=1,BWPOP=0
 S BWSUB="W !?3,""For Age Range: "",$S(BWAGRG=1:""ALL"",1:BWAGRG)"
 ;
 S (BWPOP,N,Z)=0
 W:BWCRT @IOF D HEADER8^BWUTL7
 F  S N=$O(^TMP("BW",$J,N)) Q:'N!(BWPOP)  D
 .I $Y+3>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP  D HEADER8^BWUTL7
 .W !,^TMP("BW",$J,N,0)
 W:'BWCRT !
 D ENDREP^BWUTL7(BWCRT)
 Q
 ;
DEQUEUE ;EP
 ;---> CALLED BY TASKMAN
 D SETUP,DATA^BWRPSCR1,DISPLAY,EXIT
 Q
 ;
TEXT1 ;
 ;;This report is designed to serve as an indicator of screening
 ;;rates for PAPs and MAMs.  The report will display the percentages
 ;;of women who received PAPs and MAMs for screening purposes only,
 ;;within the selected date range.
 ;;
 ;;Only patients who have had normal results for procedures in the
 ;;specified date range are counted; the intent is to exclude
 ;;any procedures that would involve abnormal results, diagnostic
 ;;and follow-up procedures, etc.  Due to the complexities
 ;;involved in the treatment of individual cases that involve
 ;;abnormal results, those patients will not be included, even
 ;;though some of them may have received screening PAPs or MAMs.
 ;;
 ;;This report, therefore, serves ONLY AS AN INDICATOR (NOT as an exact
 ;;count of screening rates) for gauging the success rates of annual
 ;;screening programs.  It can be run for several different time frames
 ;;in order to examine trends.  Assuming a screening cycle of one year,
 ;;a minimum date range spanning 15 months is recommended.
 S BWTAB=5,BWLINL="TEXT1" D PRINTX
 Q
 ;
TEXT2 ;EP
 ;;
 ;;You may limit this report to one or more specific communities,
 ;;or you may select all communities.  "Community" in this context
 ;;refers to the patient's "Current Community" as displayed and
 ;;edited in the IHS Registration software.
 S BWTAB=3,BWLINL="TEXT2" D PRINTX
 Q
 ;
PRINTX ;EP
 N I,T,X S T="" F I=1:1:BWTAB S T=T_" "
 F I=1:1 S X=$T(@BWLINL+I) Q:X'[";;"  W !,T,$P(X,";;",2)
 Q

BWUTL1
BWUTL1 ;IHS/ANMC/MWR - UTIL: MOSTLY PATIENT DATA  [ 11/21/96  1:16 AM ]
 ;;2.0;WOMEN'S HEALTH;**1**;MAY 16, 1996
 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
 ;;  UTILITY: PATIENT DEMOGRAPHICS, NEEDS, AND REGIMENS.
 ;;  ALSO DISPLAY PRIORITY, PROCEDURE TYPE.
 ;;  PATCHED AT LINELABELS BNEED AND REFS.  IHS/ANMC/MWR 11/20/96
 ;
 ;
NAME(DFN) ;EP
 ;---> PATIENT NAME.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^DPT(DFN,0)) "UNKNOWN"
 Q $P(^DPT(DFN,0),U)
 ;
DOB(DFN) ;EP
 ;---> RETURN PATIENT'S DATE OF BIRTH IN FILEMAN FORMAT.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$P(^DPT(DFN,0),U,3) "UNKNOWN"
 Q $P(^DPT(DFN,0),U,3)
 ;
 ;
AGE(DFN) ;EP
 ;---> YIELD PATIENT'S AGE IN YEARS.
 ;---> REQ: DFN=IEN PATIENT FILE
 N X,X1,X2
 Q:'$G(DFN) "NO PATIENT"
 S X2=$$DOB(DFN)
 Q:'+X2 "UNKNOWN"
 I $$DECEASED(DFN) Q "DECEASED: "_$$SLDT2^BWUTL5(+^DPT(DFN,.35))
 I '$D(DT) D NOW^%DTC S DT=X
 S X1=DT
 D ^%DTC
 Q $P(X/365.25,".")_"y/o"
 ;
DECEASED(DFN) ;EP
 ;---> RETURN 1 IF PATIENT IS DECEASED, 0 IF NOT DECEASED.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) 0
 Q:'$D(^DPT(DFN,.35)) 0
 Q:'+^DPT(DFN,.35) 0
 Q 1
 ;
SEX(DFN) ;EP
 ;---> RETURN 1 IF PATIENT IS FEMALE.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) ""
 Q:'$D(^DPT(DFN,0)) ""
 Q:$P(^DPT(DFN,0),U,2)'="F" ""
 Q 1
 ;
INACT(DFN) ;EP
 ;---> DATE THIS PATIENT BECAME INACTIVE
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^DPT(DFN,0)) "UNKNOWN"
 Q $P(^BWP(DFN,0),U,24)
 ;
AGEAT(DFN,DATE) ;EP
 ;---> YIELD PATIENT'S AGE IN YEARS AT GIVEN DATE.
 ;---> REQ: DFN =IEN PATIENT FILE
 ;--->                    DATE=DATE AT WHICH AGE IS DESIRED.
 N X,X1,X2
 Q:'$G(DFN) "NO PATIENT"
 Q:'$G(DATE) "NO DATE"
 S X2=$$DOB(DFN)
 Q:'+X2 "UNKNOWN"
 S X1=DATE
 D ^%DTC
 Q $P(X/365.25,".")_"y/o"
 ;
NAMAGE(DFN) ;EP
 ;---> PATIENT NAME CONCAT WITH AGE.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q $$NAME(DFN)_" ("_$$AGE(DFN)_")"
 ;
SSN(DFN) ;EP
 ;---> SOCIAL SECURITY NUMBER.
 ;---> REQ: DFN=IEN PATIENT FILE
 N X
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^DPT(DFN,0)) "UNKNOWN"
 S X=$P(^DPT(DFN,0),U,9)
 Q:X']"" "UNKNOWN"
 Q X
 ;
CDCID(DFN) ;EP
 ;---> CDC UNIQUE PATIENT ID.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 Q $P(^BWP(DFN,0),U,20)
 ;
HRCN1(DFN,DUZ2) ;EP
 ;---> IHS HEALTH RECORD NUMBER, WITH NO DASHES INSERTED.
 ;---> REQUIRED VARIABLES: DFN, DUZ(2)
 Q:'$G(DFN)!('$G(DUZ2)) "UNKNOWN1"
 I '$D(^AUPNPAT(DFN,41,DUZ2,0)) Q "UNKNOWN2"
 I '+$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2) Q "UNKNOWN3"
 Q $P(^AUPNPAT(DFN,41,DUZ2,0),"^",2)
 ;
HRCN(DFN,DUZ2) ;EP
 ;---> IHS HEALTH RECORD NUMBER.  IF NOT IHS, RETURN SSN.
 ;---> REQ: DFN
 ;---> OPT: DUZ2 (SITE), IF NOT PASSED, ASSUMED =DUZ(2).
 S:'$G(DUZ2) DUZ2=$G(DUZ(2))
 I $$AGENCY^BWUTL5(DUZ2)'="i" Q $$SSN(DFN)
 N Y S Y=$$HRCN1(DFN,DUZ2)
 Q:'+Y Y
 I $L(Y)=7 D  Q Y
 .S Y=$TR("123-45-67",1234567,Y)
 S Y=$E("00000",0,6-$L(Y))_Y
 S Y=$TR("12-34-56",123456,Y)
 Q Y
 ;
HPHONE(DFN) ;EP
 ;---> GET HOME PHONE#.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^DPT(DFN,.13)) "UNKNOWN"
 Q:$P(^DPT(DFN,.13),U)="" "UNKNOWN"
 Q $P(^DPT(DFN,.13),U)
 ;
STREET(DFN) ;EP
 ;---> GET STREET ADDRESS.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^DPT(DFN,.11)) "UNKNOWN"
 Q:$P(^DPT(DFN,.11),U)="" "UNKNOWN"
 Q $P(^DPT(DFN,.11),U)
 ;
CITY(DFN) ;EP
 ;---> GET CITY ADDRESS.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^DPT(DFN,.11)) "UNKNOWN"
 Q:$P(^DPT(DFN,.11),U,4)="" "UNKNOWN"
 Q $P(^DPT(DFN,.11),U,4)
 ;
STATE(DFN) ;EP
 ;---> GET STATE ADDRESS.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^DPT(DFN,.11)) "UNKNOWN"
 Q:$P(^DPT(DFN,.11),U,5)="" "UNKNOWN"
 Q $P(^DIC(5,$P(^DPT(DFN,.11),U,5),0),U,2)
 ;
ZIP(DFN) ;EP
 ;---> GET ZIPCODE ADDRESS.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^DPT(DFN,.11)) "UNKNOWN"
 Q:$P(^DPT(DFN,.11),U,6)="" "UNKNOWN"
 Q $P(^DPT(DFN,.11),U,6)
 ;
CTYSTZ(DFN) ;EP
 ;---> GET ZIPCODE ADDRESS.
 ;---> REQ: DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q $$CITY(DFN)_", "_$$STATE(DFN)_"  "_$$ZIP(DFN)
 ;
CURCOM(DFN) ;EP
 ;---> GET CURRENT COMMUNITY IEN (ITEM 6 ON PAGE 1 OF REGISTRATION).
 ;---> REQ: DFN=IEN PATIENT FILE
 N Y
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^AUPNPAT(DFN,11)) "UNKNOWN1"
 S Y=$P(^AUPNPAT(DFN,11),U,17)
 Q:Y="" "UNKNOWN2"
 Q:'$D(^AUTTCOM(Y,0)) "BAD POINTER"
 Q Y
 ;
CMGR(DFN) ;EP
 ;---> YIELD PATIENT'S CASE MANAGER.
 ;---> REQ: DFN=IEN PATIENT FILE
 N X
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 S X=$P(^BWP(DFN,0),U,10)
 Q $$PERSON(X)
 ;
PERSON(X) ;EP
 ;---> RETURN PERSON'S NAME FROM FILE #200.
 Q:'X "UNKNOWN"
 Q:'$D(^VA(200,X,0)) "UNKNOWN"
 Q $P(^VA(200,X,0),U)
 ;
EDC(DFN) ;EP
 ;---> YIELD IF PATIENT IS PREGNANT, AND EDC.
 ;---> REQ: DFN=IEN PATIENT FILE
 N X,Y
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 S Y=$P(^BWP(DFN,0),U,13)
 S X=$P(^BWP(DFN,0),U,14)
 Q:'Y ""
 S Y=" PREGNANT"
 Q Y_", EDC: "_$S(X:$$SLDT2^BWUTL5(X),1:"NO DATE ")_" "
 ;
PAPRG(DFN,TXDT) ;EP
 ;---> YIELD PATIENT'S PAP REGIMEN AND DATE IT BEGAN.
 ;---> REQ: DFN=IEN PATIENT FILE
 ;---> OPT: TXDT=1 IF DATE SHOULD BE TEXT FORMAT.
 N Y,X
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 S Y=$P(^BWP(DFN,0),U,16)
 S X=$P(^BWP(DFN,0),U,17) D Z(.X,$G(TXDT))
 Q $$PAPRG1(Y)_" (began "_X_")"
 ;
PAPRG1(PREG) ;EP
 ;---> YIELD PATIENT'S PAP REGIMEN.
 ;---> REQ: PREG=IEN IN BW PAP REGIMEN FILE #9002086.03.
 Q:'$G(PREG) "UNKNOWN"
 Q:'$D(^BWPR(PREG,0)) "PAP REGIMEN MISSING"
 Q $P(^BWPR(PREG,0),U)
 ;
CNEED(DFN,TXDT) ;PEP
 ;---> YIELD PATIENT'S CX TX NEED AND CX TX NEED DUE DATE.
 ;---> REQ: DFN=IEN PATIENT FILE
 ;---> OPT: TXDT=1 IF DATE SHOULD BE TEXT FORMAT.
 N X,Y
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 S Y=$P(^BWP(DFN,0),U,11)
 Q:'Y "UNKNOWN"
 Q:'$D(^BWCUR(Y,0)) "UNKNOWN"
 S X=$P(^BWP(DFN,0),U,12) D Z(.X,$G(TXDT))
 Q $E($P(^BWCUR(Y,0),U),1,22)_" (by "_X_")"
 ;
BNEED(DFN,TXDT) ;PEP
 ;---> YIELD PATIENT'S BR TX NEED AND BR TX NEED DUE DATE.
 ;---> REQ: DFN=IEN PATIENT FILE
 ;---> OPT: TXDT=1 IF DATE SHOULD BE TEXT FORMAT.
 N X,Y,Z
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 ;S Y=$P(^BWP(BWDFN,0),U,18)
 S Y=$P(^BWP(DFN,0),U,18)  ;IHS/ANMC/MWR 11/20/96
 Q:'Y "UNKNOWN"
 Q:'$D(^BWMAMT(Y,0)) "UNKNOWN"
 ;S X=$P(^BWP(DFN,0),U,19) D Z(.X,$G(TXDT))
 S X=$P(^BWP(DFN,0),U,19) D Z(.X,$G(TXDT))  ;IHS/ANMC/MWR 11/20/96
 Q $E($P(^BWMAMT(Y,0),U),1,22)_" (by "_X_")"
 ;
DES(DFN) ;EP
 ;---> YIELD PATIENT'S STATUS AS A DES DAUGHTER: 1=YES, 0=NO.
 ;---> DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 Q:'$D(^DD(9002086,.15,0)) "^DD MISSING"
 S X=$P(^BWP(DFN,0),U,15)
 Q:X="" ""
 Q $P($P(^DD(9002086,.15,0),X_":",2),";")
 ;
FAMHX(DFN) ;EP
 ;---> RETURN FAMILY HISTORY OF BREAST CANCER.
 ;---> DFN=IEN PATIENT FILE
 N X
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 Q:'$D(^DD(9002086,.23,0)) "^DD MISSING"
 S X=$P(^BWP(DFN,0),U,23)
 Q:X="" ""
 Q $P($P(^DD(9002086,.23,0),X_":",2),";")
 ;
REFS(DFN) ;EP
 ;---> RETURN REFERRAL SOURCE FOR THIS PATIENT (INTO CDC PROGRAM).
 ;---> DFN=IEN PATIENT FILE
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 ;Q:'$D(^DD(9002086,.15,0)) "^DD MISSING"
 Q:'$D(^DD(9002086,.22,0)) "^DD MISSING"  ;IHS/ANMC/MWR 11/20/96
 S X=$P(^BWP(DFN,0),U,22)
 Q:X="" ""
 Q $P($P(^DD(9002086,.22,0),X_":",2),";")
 ;
ENRLDT(DFN,TXDT) ;PEP
 ;---> YIELD PATIENT'S ENROLLMENT DATE.
 ;---> REQ: DFN=IEN PATIENT FILE
 ;---> OPT: TXDT=1 IF DATE SHOULD BE IN TEXT FORMAT.
 N X
 Q:'$G(DFN) "NO PATIENT"
 Q:'$D(^BWP(DFN,0)) "UNKNOWN"
 S X=$P(^BWP(DFN,0),U,21)
 Q:'X ""  D Z(.X,$G(TXDT))
 Q X
 ;
Z(X,Z) ;EP
 ;---> SET Z = NUMERIC (1/1/95) OR TEXT (JAN 1,1995) FORMAT OF DATE.
 ;---> REQ:  X=FILEMAN INTERNAL DATE FORMAT.
 ;---> OPT: Z=1 IF TEXT, 0/"" IF NUMERIC.
 S X=$S($G(Z):$$TXDT^BWUTL5(X),1:$$SLDT2^BWUTL5(X))
 Q
 ;
 ;
ACC(IEN) ;EP
 ;---> ACCESSION#; CONCATENATE SCREENING PAP IF IT EXISTS.
 ;---> IEN=IEN IN BW PROCEDURE FILE #9002086.1).
 Q:'$G(IEN) "NO PROC"
 Q:'$D(^BWPCD(IEN,0)) "NO PROC"
 N X S X=$P(^BWPCD(IEN,0),U,30)
 I X]"" I $D(^BWPCD(X,0)) S X=$P(^BWPCD(X,0),U),X=","_X
 Q $E($P(^BWPCD(IEN,0),U)_X,1,19)
 ;
PRIOR() ;EP
 ;---> CALLED FROM BW NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
 ;---> NOTIFICATION PRIORITY AND RESULT/REMINDER, FROM PURPOSE OF
 ;---> NOTIFICATION WHEN FIRST DISPLAYING SCREEN.
 ;---> REQ: DA=IEN OF NOTIFICATION.
 N X
 Q:'$D(DA) "UNKNOWN"
 Q:'$D(^BWNOT(DA,0)) "UNKNOWN"
 S X=$P(^BWNOT(DA,0),U,4)
 Q:'X "UNKNOWN"
 Q $$PRIOR1
 ;
PRIOR1() ;EP
 ;---> CALLED FROM BW NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
 ;---> NOTIFICATION PRIORITY FROM PURPOSE OF NOTIFICATION AS AN
 ;---> ACTION WHEN EDITING PURPOSE OF NOTIFICATION.  ALSO DISPLAY
 ;---> WHETHER PURPOSE IS A RESULT OR A REMINDER.
 ;---> REQ: X=IEN IN NOTIFICATION PURPOSE FILE.
 N R,Y,Z
 Q:'$D(X) "UNDEFINED"
 Q:'X "UNKNOWN"
 Q:'$D(^BWNOTP(X,0)) "UNKNOWN"
 S Y=$P(^BWNOTP(X,0),U,2) D
 .I 'Y S R="UNKNOWN" Q
 .I '$D(^DD(9002086.404,.02,0)) S R="^DD MISSING"
 .S R=$P($P(^DD(9002086.404,.02,0),Y_":",2),";")
 S Z=$P(^BWNOTP(X,0),U,6)
 Q:Z="" R
 Q:Z R_", RESULT"
 Q R_", REMINDER"
 ;
 ;
NTPROC() ;EP
 ;---> CALLED FROM BW NOTIF-EDITBLK-1(?) BLOCK TO DISPLAY PROCEDURE
 ;---> NAME, BASED ON ACCESSION# PTR, WHEN FIRST DISPLAYING SCREEN.
 ;---> REQ: X=ACCESSION# OF PROCEDURE
 N X
 S X=$P(^BWNOT(DA,0),U,6)
 Q $$PROC
 ;
PROC() ;EP
 ;---> DISPLAY PROCEDURE TYPE OF THIS PROCEDURE.
 ;---> REQ: X=IEN OF PROCEDURE IN PROC FILE #9002086.1.
 N BWY,BWYY,Y,Z S BWYY="INVALID ACC# OR PTR"
 Q:X']"" ""
 Q:'$D(^BWPCD(X,0)) BWYY
 S BWY=$P(^BWPCD(X,0),U,4)
 Q:'BWY BWYY
 Q:'$D(^BWPN(BWY,0)) BWYY
 S Z=$P(^BWPN(BWY,0),U)
 ;---> IF UNILATERAL AND LEFT/RIGHT HAS A VALUE, REPLACE "UNILATERAL"
 ;---> WITH LEFT OR RIGHT.
 S Y=$P(^BWPCD(X,0),U,9)
 S Y=$S(Y="l":"LEFT",Y="r":"RIGHT",1:"")
 Q:Y="" Z
 Q $P(Z," ")_" "_Y
 ;
PROC1() ;EP
 ;---> DISPLAY PROCEDURE TYPE OF THIS PROCEDURE, USING DA.
 ;---> CALLED BY BW PROC-HEADER-1, WHICH CANNOT USE X.
 ;---> REQ: DA=IEN OF PROCEDURE IN PROC FILE #9002086.1.
 N X S X=DA
 Q $$PROC