10:42 AM  22-DEC-98
WOMEN'S HEALTH PATCH 4 (includes 1-4)
BWMDE
BWMDE ;IHS/ANMC/MWR - EXPORT MDE'S FOR CDC.  [ 09/30/98  2:01 PM ]
 ;;2.0;WOMEN'S HEALTH;**3**;MAY 16, 1996
 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
 ;;  CDC EXPORT, MAIN DRIVER FOR COLLECTION AND EXPORT OF DATA TO
 ;;  HOST FILE SERVER.
 ;
 ;IHS/CMI/LAB - patch 3 9/30/98 added age cutoff parameters
 ;
 G EXPORT Q
 ;
START ;EP
 ;---> CALLED FROM EXPORT^BWMDE (BELOW).
 D SETVARS^BWUTL5
 D CHECKS^BWMDE4 G:BWPOP EXIT
 ;---> UNCOMMENT TO RE-COMPILE A NEW ^BWMDE1 ROUTINE FROM
 ;---> MDE DEFINITIONS IN "BW CDC MDE DATA DEFINITION" FILE.
 ;D SETS^BWMDE4 X BWX0
 D SELECT G:BWPOP EXIT
 D DATA   G:BWPOP EXIT
 D HFS
EXIT ;
 D KILLALL^BWUTL8
 Q
 ;
 ;
SELECT ;EP
 ;---> EXPORT DATA.
 D TITLE^BWUTL5(BWTITLE)
DATES ;EP
 ;---> SELECT DATE RANGE FOR EXPORT.
 W !!?3,"Select the Date Range for this export."
 W !?5,"The Begin Date may not precede the Date CDC Funding Began,"
 W !?5,"as set on page 2 of the Edit Site Parameters screen."
 W !?5,"The End Date should be the cutoff date for this MDE Submission."
 S BWSTTDT=$P(^BWSITE(DUZ(2),0),U,17)
 D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP,BWSTTDT)
 Q:BWPOP
 I BWBEGDT<BWSTTDT D  G DATES
 .W !!?5,"* The Begin Date you have selected is before the Date CDC"
 .W " Funding Began.",!?7,"Please begin again."
 ;
 ;---> SELECT CASES FOR ONE OR MORE WARD/CLINIC/LOCATIONS (OR ALL).
 D SELECT^BWSELECT("Ward/Clinic/Location",44,"BWLOC","","",.BWPOP)
 Q:BWPOP
 ;
 ;---> SELECT CASES FOR ONE OR MORE HEALTH CARE FACILITIES (OR ALL).
 D  Q:BWPOP
 .N X,Y S X="Health Care Facility",Y=9999999.06
 .D SELECT^BWSELECT(X,Y,"BWHCF","",DUZ(2),.BWPOP)
 ;
 ;---> 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" D
 .D SELECT^BWSELECT("Current Community",9999999.05,"BWCC","","",.BWPOP)
 I $$AGENCY^BWUTL5(DUZ(2))'="i" S BWCC("ALL")=""  ;VAMOD
 Q:BWPOP
 ;
 ;---> SELECT CASES FOR ONE OR MORE PROVIDERS (OR ALL).
 D SELECT^BWSELECT("Provider",200,"BWPRV","","",.BWPOP)
 Q:BWPOP
 ;IHS/CMI/LAB - patch 3 added lower and higher age cutoffs 9/30/98
 ;IHS/CMI/LAB - next 17 or so lines added patch 3
 ;---> ENTER AN AGE CUTOFF.
 N DIR
 W !!,"   Enter a patient age for youngest patient to be exported."
 S DIR("?")="     Procedures for patients under the age you enter will"
 S DIR("?")=DIR("?")_" NOT be exported"
 S DIR(0)="N^0:99",DIR("A")="   Enter an age (0-99)",DIR("B")=35
 D ^DIR K DIR W !
 I $D(DIRUT) S BWPOP=1 Q
 S BWCUTF=Y
 N DIR
 W !!,"   Enter a patient age for the oldest patient to be exported."
 S DIR("?")="     Procedures for patients under the age you enter will"
 S DIR("?")=DIR("?")_" NOT be exported"
 S DIR(0)="N^0:99",DIR("A")="   Enter an age (0-99)",DIR("B")=99
 D ^DIR K DIR W !
 I $D(DIRUT) S BWPOP=1 Q
 S BWCUTO=Y
 ;===> IHS/CMI/LAB patch 3  MODS END
 ;
 ;---> IF THIS IS AN EXPORT, GET FINAL OKAY TO CONTINUE.
 I BWXPORT D  Q:BWPOP
 .N DIR
 .W !!,"   Do you REALLY wish to export records for CDC now?"
 .S DIR("?")="     Enter YES to export records, enter NO to abort this"
 .S DIR("?")=DIR("?")_" process."
 .S DIR(0)="Y",DIR("A")="   Enter Yes or No",DIR("B")="YES"
 .D ^DIR W !
 .I $D(DIRUT)!(Y=0) D  S BWPOP=1
 ..W !?25,"* NO RECORDS EXPORTED. *" D DIRZ^BWUTL3
 Q
 ;
DATA ;EP
 ;---> RETRIEVE DATA AND STORE IN ^BWTMP(.
 ;
 W !!?3,"Please hold while records are scanned.  This may take"
 W " several minutes..."
 ;
 ;---> TEST HOST FILE ACCESS.
 S BWPATH=$P(^BWSITE(DUZ(2),0),U,14) K IO(1)
 S BWFLNM=$P(^BWSITE(DUZ(2),0),U,13)_$E(DT,4,5)_$E(DT,2,3)_BWCDCV
 S BWPOP=$$OPEN^%ZISH(BWPATH,BWFLNM,"W")
 ;---> IF NOT VALID PATH, WILL BOMB WITH A <MODER>.
 ;---> PURPOSE HERE IS TO TEST HOST FILE ACCESS BEFORE FLAGGING
 ;---> PROCEDURES AS EXPORTED.
 I BWPOP D ^%ZISC,ERROR S BWPOP=1 Q
 U IO W ""
 ;
 S (BWNOFAC,BWOFAC)=0 K ^BWTMP($J)
 S BWDT=BWBEGDT-.00001,BWENDT=BWENDDT+.99999
 ;---> LOOP THROUGH "D" XREF TO PICK UP PCDS TO BE EXPORTED.
 F  S BWDT=$O(^BWPCD("D",BWDT)) Q:'BWDT  Q:BWDT>BWENDDT  D
 .S BWIEN=0
 .F  S BWIEN=$O(^BWPCD("D",BWDT,BWIEN)) Q:'BWIEN  D
 ..I '$D(^BWPCD(BWIEN,0)) K ^BWPCD("D",BWDT,BWIEN) Q
 ..S BW0=^BWPCD(BWIEN,0)
 ..;
 ..;---> QUIT IF THIS IS NOT A PAP (IEN=1) AND
 ..;---> NOT A SCREENING MAM (IEN=28).
 ..Q:(($P(BW0,U,4)'=1)&($P(BW0,U,4)'=28))
 ..;
 ..;---> QUIT IF THIS PROCEDURE IS BEFORE THE SOFTWARE WAS FUNCTIONAL,
 ..;---> OR BEFORE CDC FUNDING START DATE, OR AFTER THE CUTOFF DATE.
 ..;---> * !NOT USED FOR NOW.
 ..;Q:$P(BW0,U,12)<2951001  Q:$P(BW0,U,12)<BWSTTDT
 ..;Q:$P(BW0,U,12)>BWCUTDT
 ..;
 ..;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
 ..;I $P(BW0,U,5)=8 K ^BWPCD("ACDC",BWIEN) Q
 ..Q:$P(BW0,U,5)=8
 ..;
 ..;---> QUIT IF NOT SELECTING ALL CLINICS/WARDS AND IF THIS PROCEDURE
 ..;---> WAS NOT PERFORMED IN ONE OF THE CLINICS/WARDS SELECTED.
 ..I '$D(BWLOC("ALL")) Q:'$P(BW0,U,11)  Q:'$D(BWLOC($P(BW0,U,11)))
 ..;
 ..;---> QUIT IF THIS PROCEDURE HAS NO HEALTH CARE FACILITY.
 ..;---> (STORE TOTAL REJECTED FOR NO FACILITY IN BWNOFAC.)
 ..I '$P(BW0,U,10) S BWNOFAC=BWNOFAC+1 Q
 ..;
 ..;---> QUIT IF NOT SELECTING ALL HEALTH CARE FACILITIES AND IF THIS
 ..;---> PROCEDURE WAS NOT PERFORMED IN ONE OF THE FACILITIES SELECTED.
 ..I '$D(BWHCF("ALL"))  I '$D(BWHCF($P(BW0,U,10))) S BWOFAC=BWOFAC+1 Q
 ..;
 ..;IHS/CMI/LAB - patch 3 added age cutoff logic 9/30/97
 ..;IHS/CMI/LAB - added next 4 lines patch 3
 ..;---> QUIT IF THIS PATIENT IS BELOW THE AGE CUTOFF
 ..N BWDFN S BWDFN=$P(BW0,U,2)
 ..Q:(BWCUTF>$P($$AGE^BWUTL1(BWDFN),"y"))
 ..Q:(BWCUTO<$P($$AGE^BWUTL1(BWDFN),"y"))
 ..;---> QUIT IF NOT SELECTING ALL CURRENT COMMUNITIES AND IF THIS
 ..;---> PROCEDURE WAS NOT ON A PATIENT IN ONE OF THE CC'S SELECTED.
 ..I '$D(BWCC("ALL")) D  Q:'BWCUR  Q:'$D(BWCC(BWCUR))
 ...S BWCUR=$$CURCOM^BWUTL1($P(BW0,U,2))
 ..;
 ..;---> QUIT IF NOT SELECTING ALL PROVIDERS AND IF THIS PROCEDURE
 ..;---> WAS NOT PERFORMED BY ONE OF THE PROVIDERS SELECTED.
 ..I '$D(BWPRV("ALL")) Q:'$P(BW0,U,7)  Q:'$D(BWPRV($P(BW0,U,7)))
 ..D BUILD^BWMDE1(BWIEN)
 ..;---> * !!NOT CURRENTLY USED.  RETAINED IN CASE IMS GOES BACK!!
 ..;---> IF THIS IS AN EXPORT FOR CDC, THEN UPDATE THE CDC EXPORT
 ..;---> DATE AND STATUS FIELDS .16 AND .17.
 ..;---> IF CALLED FROM THE "BW CDC EXTRACT FOR LOCAL" OPTION, DO NOT
 ..;---> UPDATE THESE FIELDS.
 ..;D:BWXPORT CDCUPDT^BWPROC(BWIEN)
 Q
 ;
 ;
HFS ;EP
 ;---> SAVE DATA FROM ^BWTMP( TO HOST FILE SERVER.
 ;
 I '$D(^BWTMP($J)) D  Q
 .D ^%ZISC W !!?5,"NO RECORDS TO BE EXPORTED." D DIRZ^BWUTL3
 ;
 ;---> IF THIS IS AN EXTRACT, OFFER TO WRITE FILE OUT TO SCREEN.
 S BWCAPT="h"
 I 'BWXPORT D  Q:BWPOP
 .N DIR U IO(0)
 .W !!?3,"Do you wish to save this to the Host File ",BWPATH,BWFLNM,","
 .W !?3,"or write it to your screen for capture by a PC?",!
 .S DIR("A")="   Select HOST or SCREEN: ",DIR("B")="HOST"
 .S DIR(0)="SAM^h:HOST;s:SCREEN" D HELP1^BWMDE4
 .D ^DIR
 .I $D(DIRUT) S BWPOP=1 Q
 .S BWCAPT=Y I Y="s" D  Q
 ..S IO=0 U IO
 ..W !!?5,"Screen print of the file will follow immediately."
 ..D DIRZ^BWUTL3
 U IO
 N N,M S N=0,BWCOUNT=0
 F  S N=$O(^BWTMP($J,N)) Q:'N  D
 .S M=0 F  S M=$O(^BWTMP($J,N,M)) Q:'M  D
 ..W ^BWTMP($J,N,M),! S BWCOUNT=BWCOUNT+1
 D ^%ZISC
 I BWCAPT="s" D DIRZ^BWUTL3 Q
 W !!?5,"File ",BWPATH_BWFLNM
 W " successfully saved to Host File Server."
 W !!?5,"Records exported...........................................: "
 W $J(BWCOUNT,6)
 D NOFAC,DIRZ^BWUTL3
 ;---> QUIT IF THIS WAS ONLY AN EXTRACT (BWXPORT=0).
 Q:'BWXPORT
 D SAVELOG^BWMDE4
 Q
 ;
ERROR ;EP
 W !!?5,"* Save to Host File Server FAILED.  Contact your sitemanager."
 D DIRZ^BWUTL3
 Q
 ;
NOFAC ;EP
 W !?5,"Total Procedures rejected: "
 W ?33,"Not done at a selected facility: ",$J(BWOFAC,6)
 W !?33,"No facility entered............: ",$J(BWNOFAC,6)
 Q
 ;
 ;---> NEXT LINE USED TO CREATE BWMDE2 ROUTINE.
 ;S BWX6="ZI R_""() ;EP"","" ;"","" Q"","" ;"" ZS BWMDE2"
 ;
 ;
EXPORT ;EP
 ;---> CALLED BY OPTION "BW CDC EXPORT DATA", EXPORTS DATA AND
 ;---> UPDATES CDC EXPORT DATE AND STATUS FIELDS .16 AND .17 IN
 ;---> THE BW PROCEDURE FILE AND UPDATES CDC EXPORT LOG FILE.
 S BWTITLE="EXPORT MDE DATA FOR CDC"
 ;---> BWCDCV=CDC MDE VERSION# FOR THIS EXPORT.
 S BWXPORT=1,BWCDCV=23
 D START
 Q
 ;
EXTRACT ;EP
 ;---> * !!NOT USED AT THIS POINT, IMS (CDC CONTRACTOR) DECIDED NOT
 ;---> USE FLAGS.  RETAIN FOR FUTURE, IN CASE THEY SWITCH BACK!!
 W !!?5,"NOT CURRENTLY FUNCTIONAL." Q
 ;---> CALLED BY OPTION "BW CDC EXTRACT FOR LOCAL", MERELY EXTRACTS
 ;---> CDC DATA TO HOST FILE FOR EVALUATION OR STATISTICAL ANALYSIS
 ;---> LOCALLY, WITHOUT UPDATING BW PROCEDURE CDC STATUS AND DATE
 ;---> FIELDS.
 S BWTITLE="EXTRACT MDE DATA FOR LOCAL ANALYSIS"
 ;---> BWCDCV=LC FOR "LOCAL" (RATHER THAN CDC MDE VERSION#).
 S BWXPORT=0,BWCDCV="LC"
 D START
 Q

BWPATCH2
BWPATCH2 ;IHS/ANMC/MWR - UTIL: MOSTLY PATIENT DATA  [ 01/23/97  4:37 PM ]
 ;;2.0;WOMEN'S HEALTH;**2**;JAN 21, 1997
 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
 ;;  PATCH ROUTINE TO FIX "AOPEN" XREF IN ^BWNOT( GLOBAL
 ;;  (BW NOTIFICATION FILE).
 ;
 ;----------
START ;EP
 D INIT
 D MAIN
 D EOJ
 Q
 ;
 ;----------
INIT ;EP - Initialization.
 D SETVARS^BWUTL5
 S IOP=$I D ^%ZIS
 S BWPTITL="v2.0 PATCH PROGRAM"
 Q
 ;
 ;----------
MAIN ;EP - Main program.
 D TITLE^BWUTL5(BWPTITL)
 D TEXT1
 W !!,"   Do you wish to apply the patch and reindex the data now?"
 S DIR("?")="     Enter YES to apply the patch, enter NO to abort."
 S DIR(0)="Y",DIR("A")="   Enter Yes or No"
 D ^DIR W !
 I $D(DIRUT)!(Y<1) D NOCHANGE Q
 ;
 D TITLE^BWUTL5(BWPTITL)
 I '$D(^DD(9002086.4))!('$D(^BWNOT(0))) D TEXT2,NOCHANGE Q
 ;
 ;---> Correct xref logic in ^DD.
 N BWY
 S BWY="I ""o""[$P(^BWNOT(DA,0),U,14) S ^BWNOT(""AOPEN"",X,DA)="""""
 S ^DD(9002086.4,.02,1,1,1)=BWY
 S BWY="K ^BWNOT(""AOPEN"",X,DA)"
 S ^DD(9002086.4,.02,1,1,2)=BWY
 ;
 ;---> Reindex AOPEN xref.
 K ^BWNOT("AOPEN")
 S BWINC=$J(($P(^BWNOT(0),U,4))/50,0,0) S:BWINC<1 BWINC=1
 W !!?14,"Reindexing..."
 W !!!?14,"0%                      50%                     100%"
 W !?14,"----------------------------------------------------"
 W !?14,"["
 N I,Y S BWIEN=0,BWCOUNT=0
 F I=1:1 S BWIEN=$O(^BWNOT(BWIEN)) Q:'BWIEN  D
 .I '(I#BWINC)&(BWCOUNT<51) W "=" S BWCOUNT=BWCOUNT+1
 .S Y=^BWNOT(BWIEN,0)
 .Q:"o"'[$P(Y,U,14)
 .S ^BWNOT("AOPEN",$P(Y,U,2),BWIEN)=""
 I BWCOUNT<50 F I=1:1:50-BWCOUNT W "="
 W "]"
 W !!!!?14,"Patch applied successfully!  Job complete.",!!
 D DIRZ^BWUTL3
 Q
 ;
 ;----------
EOJ ;EP - End of job.
 D KILLALL^BWUTL8 K BWINC
 Q
 ;
 ;----------
TEXT1 ;EP
 ;;This routine will correct an error in the crossreference logic
 ;;in the data dictionary for Women's Health Notifications.  It will
 ;;then reindex the "AOPEN" crossreference on field .02 of the
 ;;BW NOTIFICATIONS File #9002086.4.
 ;;
 ;;NO user/programmer action is required.  The program will present a
 ;;progress bar 0%-100% during the job, which may take several minutes.
 ;;
 S BWTAB=5,BWLINL="TEXT1" D PRINTX
 Q
 ;
 ;----------
TEXT2 ;EP
 ;;The BW NOTIFICATIONS File does not appear to be loaded on this
 ;;system.  Please contact your Women's Health support person or
 ;;Mike Remillard at (907)696-7472."
 ;;
 S BWTAB=5,BWLINL="TEXT2" D PRINTX
 Q
 ;
 ;----------
NOCHANGE ;EP
 W !?25,"NO CHANGES MADE!" D DIRZ^BWUTL3
 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

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

BWRPSNP1
BWRPSNP1 ;IHS/ANMC/MWR - REPORT: SNAPSHOT OF PROGRAM [ 12/17/98  3:46 PM ]
 ;;2.0;WOMEN'S HEALTH;**4**;MAY 16, 1996
 ;IHS/CMI/LAB - removed hard coded year Y2K patch 4
 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
 ;;  DISPLAY CODE FOR SNAPSHOT REPORT.  CALLED BY BWRPSNP.
 ;
 ;---> REQUIRED VARIABLES: BWDT=DATE SNAPSHOT WAS RUN.
 ;--->                     BWFAC=FACILITY IEN IN ^DIC(4 - DUZ(2)
 ;--->                     A-L,P,Q = FIELDS #.03-#.16 IN FILE 9002086.71
 ;
DISPLAY ;EP
 U IO
 S BWTITLE="* * *  PROGRAM SNAPSHOT FOR "_$$TXDT^BWUTL5(BWDT)_"  * * *"
 D CENTERT^BWUTL5(.BWTITLE),TOPHEAD^BWUTL7,HEADER6^BWUTL7
 ;
 N X,Y
 W !
 S X="Total Active Women in Register:",Y=A D PNUM
 S X="Women Who Are Pregnant:",Y=B D PNUM
 ;S X="Woman Who Are DES Daughters:",Y=C D PNUM
 S X="Women with Cervical Tx Needs not specified or not dated:",Y=D
 D PNUM
 S X="Women with Cervical Tx Needs specified and past due:",Y=E D PNUM
 S X="Women with Breast Tx Needs not specified or not dated:",Y=F D PNUM
 S X="Women with Breast Tx Needs specified and past due:",Y=G D PNUM
 W !
 S X="Total Number of Procedures with a Status of ""OPEN"":",Y=H D DOTS
 S X="Number of OPEN Procedures Past Due (or not dated):",Y=S D DOTS
 W:'BWCRT !
 ;beginning Y2K IHS/CMI/LAB
 ;S X="Total Number of PAP Smears done since Jan 1, 19"_$E(BWDT,2,3)_":" ;Y2000 IHS/CMI/LAB
 S X="Total Number of PAP Smears done since Jan 1, "_(1700+$E(BWDT,1,3))_":" ;Y2000 IHS/CMI/LAB
 S Y=P D DOTS
 ;S X="Total Number of CBEs done since Jan 1, 19"_$E(BWDT,2,3)_":" ;Y2000 IHS/CMI/LAB
 S X="Total Number of CBEs done since Jan 1, "_(1700+$E(BWDT,1,3))_":" ;Y2000 IHS/CMI/LAB
 S Y=R D DOTS
 ;S X="Total Number of Mammograms done since Jan 1, 19"_$E(BWDT,2,3)_":" ;Y2000 IHS/CMI/LAB
 S X="Total Number of Mammograms done since Jan 1, "_(1700+$E(BWDT,1,3))_":" ;Y2000 IHS/CMI/LAB
 ;end Y2K IHS/CMI/LAB
 S Y=Q D DOTS
 W !
 S X="Total Number of Notifications with a Status of ""OPEN"":",Y=J
 D DOTS
 S X="Number of OPEN Notifications Past Due (or not dated):",Y=K D DOTS
 S X="Number of Letters Queued (for later printing):",Y=L D DOTS
 ;
 D:'BWCRT
 .N BWTITLE S BWTITLE="-----  End of Report  -----"
 .D CENTERT^BWUTL5(.BWTITLE) W !!!,BWTITLE,@IOF
 I BWCRT&('$D(IO("S"))) D DIRZ^BWUTL3 W @IOF
 D ^%ZISC
 Q
 ;
PNUM ;EP
 ;---> PATIENT NUMBERS
 W:'BWCRT ! W !?3,X F I=1:1:(58-$L(X))/2 W " ."
 W ?61,".",?62,$J(Y,5) W:A>0 ?69,$J(Y/A*100,3,0),"%"
 Q
 ;
DOTS ;EP
 W:'BWCRT ! W !?3,X F I=1:1:(58-$L(X))/2 W " ."
 W ?61,".",?62,$J(Y,5)
 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