11:38 AM 8-JUN-99 WOMEN'S HEALTH VERSION 2.0 PATCH 5 BWBRNED1 BWBRNED1 ;IHS/ANMC/MWR - BROWSE TX NEEDS PAST DUE; [ 05/19/99 2:11 PM ] ;;2.0;WOMEN'S HEALTH;**5**;MAY 16, 1996 ;IHS/CMI/LAB - Y2K ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * ;; DISPLAY CODE FOR BROWSING TX NEEDS. CALLED BY BWBRNED. ; DISPLAY ;EP ;---> BWCONF=DISPLAY "CONFIDENTIAL PT INFO" BANNER. ;---> BWTITLE=TITLE AT TOP OF DISPLAY HEADER. ;---> BWSUBH=CODE TO EXECUTE FOR SUBHEADER (COLUMN TITLES). ;---> BWCODE=CODE TO EXECUTE AS 3RD PIECE OF DIR(0) (AFTER DIR READ). ;---> BWCRT=1 IF OUTPUT IS TO SCREEN (ALLOWS SELECTIONS TO EDIT). ;---> BWTAB=6 IF OUTPUT IS TO SCREEN, =3 IF OUTPUT IS TO PRINTER. ;---> BWPRMT(1,Q)=PROMPTS FOR DIR. ; U IO S BWCONF=1 S BWTITLE1=$S(BWB=1:"BY NEED DATE",BWB=2:"ALPHABETICALLY",1:"?") S BWTITLE="* PATIENTS LISTED "_BWTITLE1_" *" D CENTERT^BWUTL5(.BWTITLE) S BWSUBH="SUBHEAD^BWBRNED1" S BWCODE="D EDIT^BWBRNED1 N N D SORT^BWBRNED,COPYGBL^BWBRNED" S BWPRMT1=" Press RETURN to continue or '^'to exit, or" S BWPRMT=" Select a left column number to edit" S BWPRMTQ=" To edit a Procedure, choose a number from the " S BWPRMTQ=BWPRMTQ_"left column" S (BWPOP,N,Z)=0 D TOPHEAD^BWUTL7 ;---> *SET BWFAC FOR NOW; MAKE BWFAC SELECTABLE IN FUTURE VERSIONS. S BWFAC=DUZ(2) S BWTAB=$S(BWCRT:6,1:3) ; NOMATCH ;EP ;---> QUIT IF NO RECORDS MATCH. I '$D(^TMP("BW",$J,1)) D Q .D HEADER5^BWUTL7 .K BWPRMT,BWPRMT1,BWPRMTQ,DIR .W !!?5,"No records match the selected criteria.",! .D:BWCRT DIRZ^BWUTL3 W @IOF D ^%ZISC S BWPOP=1 ; DISPLAY1 ;EP ;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE ;---> FROM LINELABEL "END" BELOW. N M,Y D HEADER5^BWUTL7 F S N=$O(^TMP("BW",$J,2,N)) Q:'N!(BWPOP) D .I $Y+6>IOSL D:BWCRT DIRPRMT^BWUTL3 Q:BWPOP D ..S BWPAGE=BWPAGE+1 ..D HEADER5^BWUTL7 .S Y=^TMP("BW",$J,2,N),M=N .;---> DON'T WRITE BROWSE SELECTION#'S IF IO IS NOT A CRT (BRCRT). .W !! W:BWCRT $J(N,3),")" ;BROWSE SELECTION# .W ?BWTAB,$P(Y,U) ;CHART# .W ?BWTAB+10,$E($P(Y,U,2),1,16)," " ;NAME .F I=1:1:16-$L($P(Y,U,2)) W "." ;CONNECTING DOTS .W:'BWCRT "..." ;ADD DOTS IF NOT A CRT .;begin Y2K .W ?34,$E($P($P(Y,U,3),","),1,9) ;CASE MANAGER ;IHS/CMI/LAB Y2000 .W ?44,$P(Y,U,4) ;CERVICAL TX NEED&DATE ;IHS/CMI/LAB Y2000 .W !?44,$P(Y,U,5) ;BREAST TX NEED&DATE ;IHS/CMI/LAB Y2000 .;end Y2K ; D:'N .N BWTITLE S BWTITLE="----- End of Report -----" .D CENTERT^BWUTL5(.BWTITLE) W !!,BWTITLE ; END ;EP W:'BWCRT @IOF ;---> IF A PATIENT HAS BEEN EDITED, SET N=N-5 AND START (GOTO) I BWCRT&('$D(IO("S")))&('BWPOP) D DIRPRMT^BWUTL3 I N S N=N-1 G NOMATCH D ^%ZISC Q ; SUBHEAD ;EP ;---> SUB HEADER FOR PATIENT BROWSE OUTPUT. ;begin Y2K W !?BWTAB,$$PNLB^BWUTL5(DUZ(2)),?BWTAB+10,"PATIENT",?34,"CASE MGR" ;IHS/CMI/LAB spacing for 4 digit date Y2000 W ?44,"TREATMENT NEED DUE BY DATE",! ;IHS/CMI/LAB Y2000 ;end Y2K F I=1:1:80 W "-" Q ; EDIT ;EP ;---> FROM BROWSE, BWPOP IN TO EDIT AN INDIVIDUAL PATIENT. N (DT,DTIME,DUZ,M,N,U,X,Z) D SETVARS^BWUTL5 S X=+X,BWDFN=$P(^TMP("BW",$J,2,X),U,6) S BWN=X N X D SCREEN^BWPATE(BWDFN) ;---> BACK UP 5 RECORDS AFTER EDIT. S N=$S(BWN<6:1,1:BWN-5) K BWN Q BWMDE BWMDE ;IHS/ANMC/MWR - EXPORT MDE'S FOR CDC. [ 05/25/99 9:13 AM ] ;;2.0;WOMEN'S HEALTH;**3,5**;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 ;IHS/CMI/THL - patch 5 new cde export format ; 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 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 . ;---> 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 "" ; ;IHS/CMI/THL - patch 5 to use alternate method for cbe/mams ;S (BWNOFAC,BWOFAC)=0 K ^BWTMP($J) K ^BWTMP($J) D ^BWMDET ;END MOD S (BWNOFAC,BWOFAC)=0 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). ..;IHS/CMI/THL - patch 5 to use this section for pap data only ..;Q:(($P(BW0,U,4)'=1)&($P(BW0,U,4)'=28)) ..Q:$P(BW0,U,4)'=1 ..;END MOD ..; ..;---> 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)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))) ..W "#" ..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=40 ;IHS/ANMC/HMW Changed MDE version to 40 per MWR 4-13-99 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 BWMDE1 BWMDE1 ;IHS/ANMC/MWR - COMPILED MDE EXPORT ROUTINE. [ 05/25/99 9:15 AM ] ;;2.0;WOMEN'S HEALTH;**5**;MAY 16, 1996 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * ;; CDC EXPORT, BUILDS ASCII FIXED LENGTH RECORDS FOR EXPORT. ; ;IHS/CMI/THL - new cdc format patch 5 ; BUILD(BWIEN) ; EP D ^BWUTL5,PCDVARS^BWUTL3(BWIEN,0,1) Q:'BWMAM&('BWPAP) S $E(BWCDC(BWIEN),1)=$$STSCR^BWMDE2 S $E(BWCDC(BWIEN),3)=$$CNTYSCR^BWMDE2 S $E(BWCDC(BWIEN),6)=$$CITY^BWMDE2 S $E(BWCDC(BWIEN),21)=$$ENROLL^BWMDE2 S $E(BWCDC(BWIEN),26)=$$PSCRSI^BWMDE2 S $E(BWCDC(BWIEN),31)=$$MSCRSI^BWMDE2 S $E(BWCDC(BWIEN),40)=$$PATID^BWMDE2 S $E(BWCDC(BWIEN),55)=$$RECID^BWMDE2 S $E(BWCDC(BWIEN),61)=$$RECTYP^BWMDE2 S $E(BWCDC(BWIEN),62)=$$CNTYRES^BWMDE2 S $E(BWCDC(BWIEN),65)=$$STRES^BWMDE2 S $E(BWCDC(BWIEN),67)=$$ZIP^BWMDE2 S $E(BWCDC(BWIEN),72)=$$DOB^BWMDE2 S $E(BWCDC(BWIEN),80)=$$RACE^BWMDE2 S $E(BWCDC(BWIEN),81)=$$HISP^BWMDE2 ; ;IHS/CMI/THL - patch 5 new cdc format ;NEW VERSION 4.0 SETS BELOW ; S $E(BWCDC(BWIEN),88)=$$BRSYMP^BWMDE2 S $E(BWCDC(BWIEN),89)=$$CBE^BWMDE2 S $E(BWCDC(BWIEN),90)=$$CBEDT^BWMDE2 S $E(BWCDC(BWIEN),98)=$$CBEPAID^BWMDE2 S $E(BWCDC(BWIEN),99)=$$PPREV^BWMDE2 S $E(BWCDC(BWIEN),100)=$$PPREVDT^BWMDE2 S $E(BWCDC(BWIEN),106)=$$ADQPAP^BWMDE2 S $E(BWCDC(BWIEN),107)=$$PRESLT^BWMDE2 S $E(BWCDC(BWIEN),109)=$$POTHR^BWMDE2 S $E(BWCDC(BWIEN),129)=$$PWKUP^BWMDE2 S $E(BWCDC(BWIEN),130)=$$PSCRDT^BWMDE2 S $E(BWCDC(BWIEN),138)=$$PPAY^BWMDE2 S $E(BWCDC(BWIEN),139)=$$MPREV^BWMDE2 S $E(BWCDC(BWIEN),140)=$$MPREVDT^BWMDE2 S $E(BWCDC(BWIEN),146)=$$MRESLT^BWMDE2 S $E(BWCDC(BWIEN),148)=$$MWKUP^BWMDE2 S $E(BWCDC(BWIEN),149)=$$MDT^BWMDE2 S $E(BWCDC(BWIEN),157)=$$MPAY^BWMDE2 S $E(BWCDC(BWIEN),158)=$$MDEVER^BWMDE2 S $E(BWCDC(BWIEN),160)=$$CONOBX^BWMDE2 S $E(BWCDC(BWIEN),161)=$$COLPBX^BWMDE2 S $E(BWCDC(BWIEN),162)=$$POTHPR^BWMDE2 S $E(BWCDC(BWIEN),163)=$$POTHPR1^BWMDE2 S $E(BWCDC(BWIEN),183)=$$POTHPR2^BWMDE2 S $E(BWCDC(BWIEN),202)=$$CDXPAID^BWMDE2 S $E(BWCDC(BWIEN),203)=$$PFNDX^BWMDE2 S $E(BWCDC(BWIEN),204)=$$PSTGDX^BWMDE2 S $E(BWCDC(BWIEN),205)=$$PFNDXO^BWMDE2 S $E(BWCDC(BWIEN),225)=$$PSTFDX^BWMDE2 S $E(BWCDC(BWIEN),226)=$$PFDXDT^BWMDE2 S $E(BWCDC(BWIEN),234)=$$PSTTX^BWMDE2 S $E(BWCDC(BWIEN),235)=$$PSTXDT^BWMDE2 S $E(BWCDC(BWIEN),243)=$$MFUDXV^BWMDE2 S $E(BWCDC(BWIEN),244)=$$MRBREX^BWMDE2 S $E(BWCDC(BWIEN),245)=$$MULTRA^BWMDE2 S $E(BWCDC(BWIEN),246)=$$MLUMP^BWMDE2 S $E(BWCDC(BWIEN),247)=$$MFINDL^BWMDE2 S $E(BWCDC(BWIEN),248)=$$MOTHPR^BWMDE2 S $E(BWCDC(BWIEN),249)=$$MOTHPR1^BWMDE2 S $E(BWCDC(BWIEN),269)=$$MOTHPR2^BWMDE2 S $E(BWCDC(BWIEN),288)=$$BDXPAID^BWMDE2 S $E(BWCDC(BWIEN),289)=$$MFNDX^BWMDE2 S $E(BWCDC(BWIEN),290)=$$MSTGDX^BWMDE2 S $E(BWCDC(BWIEN),291)=$$MTMRSZ^BWMDE2 S $E(BWCDC(BWIEN),292)=$$MSTFDX^BWMDE2 S $E(BWCDC(BWIEN),293)=$$MFDXDT^BWMDE2 S $E(BWCDC(BWIEN),301)=$$MSTTX^BWMDE2 S $E(BWCDC(BWIEN),302)=$$MSTXDT^BWMDE2 S $E(BWCDC(BWIEN),310)=$$EOR^BWMDE2 ; ;NEW VERSION 4.0 SETS ABOVE ; ;OLD VERSION 2.4 SETS BELOW ; ;S $E(BWCDC(BWIEN),82)=$$ENRLDT^BWMDE2 ;S $E(BWCDC(BWIEN),88)=$$REFER^BWMDE2 ;S $E(BWCDC(BWIEN),89)=$$BRSYMP^BWMDE2 ;S $E(BWCDC(BWIEN),90)=$$CBE^BWMDE2 ;S $E(BWCDC(BWIEN),91)=$$CBEDT^BWMDE2 ;S $E(BWCDC(BWIEN),97)=$$PPREV^BWMDE2 ;S $E(BWCDC(BWIEN),98)=$$PPREVDT^BWMDE2 ;S $E(BWCDC(BWIEN),102)=$$ADQPAP^BWMDE2 ;S $E(BWCDC(BWIEN),103)=$$PRESLT^BWMDE2 ;S $E(BWCDC(BWIEN),105)=$$POTHR^BWMDE2 ;S $E(BWCDC(BWIEN),125)=$$PWKUP^BWMDE2 ;S $E(BWCDC(BWIEN),126)=$$PSCRDT^BWMDE2 ;S $E(BWCDC(BWIEN),132)=$$PPAY^BWMDE2 ;S $E(BWCDC(BWIEN),133)=$$MPREV^BWMDE2 ;S $E(BWCDC(BWIEN),134)=$$MPREVDT^BWMDE2 ;S $E(BWCDC(BWIEN),138)=$$MRESLT^BWMDE2 ;S $E(BWCDC(BWIEN),140)=$$MWKUP^BWMDE2 ;S $E(BWCDC(BWIEN),141)=$$MDT^BWMDE2 ;S $E(BWCDC(BWIEN),147)=$$MPAY^BWMDE2 ;S $E(BWCDC(BWIEN),148)=$$MDEVER^BWMDE2 ;S $E(BWCDC(BWIEN),150)=$$CONOBX^BWMDE2 ;S $E(BWCDC(BWIEN),151)=$$COLPBX^BWMDE2 ;S $E(BWCDC(BWIEN),152)=$$POTHPR^BWMDE2 ;S $E(BWCDC(BWIEN),153)=$$POTHPR1^BWMDE2 ;S $E(BWCDC(BWIEN),173)=$$POTHPR2^BWMDE2 ;S $E(BWCDC(BWIEN),193)=$$PFNDX^BWMDE2 ;S $E(BWCDC(BWIEN),194)=$$PSTGDX^BWMDE2 ;S $E(BWCDC(BWIEN),195)=$$PFNDXO^BWMDE2 ;S $E(BWCDC(BWIEN),215)=$$PSTFDX^BWMDE2 ;S $E(BWCDC(BWIEN),216)=$$PFDXDT^BWMDE2 ;S $E(BWCDC(BWIEN),222)=$$PSTTX^BWMDE2 ;S $E(BWCDC(BWIEN),223)=$$PSTXDT^BWMDE2 ;S $E(BWCDC(BWIEN),229)=$$MFUDXV^BWMDE2 ;S $E(BWCDC(BWIEN),230)=$$MRBREX^BWMDE2 ;S $E(BWCDC(BWIEN),231)=$$MULTRA^BWMDE2 ;S $E(BWCDC(BWIEN),232)=$$MLUMP^BWMDE2 ;S $E(BWCDC(BWIEN),233)=$$MFINDL^BWMDE2 ;S $E(BWCDC(BWIEN),234)=$$MOTHPR^BWMDE2 ;S $E(BWCDC(BWIEN),235)=$$MOTHPR1^BWMDE2 ;S $E(BWCDC(BWIEN),255)=$$MOTHPR2^BWMDE2 ;S $E(BWCDC(BWIEN),275)=$$MFNDX^BWMDE2 ;S $E(BWCDC(BWIEN),276)=$$MSTGDX^BWMDE2 ;S $E(BWCDC(BWIEN),277)=$$MTMRSZ^BWMDE2 ;S $E(BWCDC(BWIEN),278)=$$MSTFDX^BWMDE2 ;S $E(BWCDC(BWIEN),279)=$$MFDXDT^BWMDE2 ;S $E(BWCDC(BWIEN),285)=$$MSTTX^BWMDE2 ;S $E(BWCDC(BWIEN),286)=$$MSTXDT^BWMDE2 ;S $E(BWCDC(BWIEN),292)=$$EOR^BWMDE2 ; ;OLD VERSION 2.4 SETS ABOVE ; S ^BWTMP($J,BWDFN,BWIEN)=BWCDC(BWIEN) S ^TMP("BWEXPORT",$J,BWDFN,BWIEN)=BWCDC(BWIEN) K BWCDC(BWIEN) Q BWMDE2 BWMDE2 ;IHS/ANMC/MWR - MDE FUNCTIONS. [ 05/19/99 2:14 PM ] ;;2.0;WOMEN'S HEALTH;**5**;MAY 16, 1996 ;;Modified for Y2K compliance THL/HJT 5/14/99 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * ;; CDC EXPORT, FUNCTIONS TO RETRIEVE DATA FOR INDIVIDUAL FIELDS ;; FOR EXPORT. ; ; CDCDT(FMDATE) ;EP ;Begin Y2K fix ;---> CHANGE FILEMAN DATE FORMAT TO CDC DATE FORMAT (MMDDYY). ;Q $E(FMDATE,4,5)_$E(FMDATE,6,7)_($E(FMDATE,2,3)) ; ;MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE ; Q:'FMDATE "" Q $E(FMDATE,4,5)_$E(FMDATE,6,7)_($E(FMDATE,1,3)+1700) ;Y2000 ; ;END MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE ;End Y2k fix ; STSCR() ;EP ;---> TRIBAL FIPS CODE. Q:$G(^BWSITE(DUZ(2),0))']"" "" N X S X=$P(^BWSITE(DUZ(2),0),U,11) S:X<10 X=0_X Q X ; CNTYSCR() ;EP ;---> COUNTY OF SCREENING. Q:$G(^BWSITE(DUZ(2),0))']"" 999 N X S X=$P(^BWSITE(DUZ(2),0),U,16) Q:'X 999 S:X<100 X=0_X S:X<10 X=0_X Q X ; CITY() ;EP ;---> CITY OF SCREENING. Q:'$G(^AUTTLOC(DUZ(2),0)) "" Q $P(^AUTTLOC(DUZ(2),0),U,13) ; ENROLL() ;EP ;---> ENROLLMENT SITE - DUZ(2) (INSTITUTION FILE). Q $J($P(BW0,U,10),5) ; PSCRSI() ;EP ;---> PAP SCREENING SITE--OPTIONAL. Q:BWPAP $J($P(BW0,U,10),5) Q "" ; MSCRSI() ;EP ;---> MAM SCREENING SITE--OPTIONAL. Q:BWMAM $J($P(BW0,U,10),5) Q "" ; PATID() ;EP ;---> UNIQUE PATIENT IDENTIFIER. D:$$CDCID^BWUTL1(BWDFN)']"" CDCID^BWPATE(BWDFN) Q $$CDCID^BWUTL1(BWDFN) ; RECID() ;EP ;---> RECORD IDENTIFIER FOR THIS PATIENT. ;---> FIRST DIGIT IS 1 IF IT'S A PAP, 2 IF IT'S A MAM. ;---> SECOND DIGIT IS THE ONES DIGIT OF THE YEAR, LAST FOUR DIGITS ;---> ARE THE 1-10000 DIGITS OF THE ACCESSION#. N X S X=$P(BWACCN,"-",2) Q $S($E(BWACCN)="P":1,1:2)_$E(BWACCN,4)_$E(X,($L(X)-3),$L(X)) ; RECTYP() ;EP ;---> RECORD TYPE: 1=ADD(NEW), 2=UPDATE. ;Q $P(BW0,U,17) ;---> FOR NOW, PER TELEPHONE CONVERSATION WITH BILL HELSEL 3/12/96, ;---> SINCE WE ARE RE-EXPORTING ALL RECORDS WITH EACH SUBMISSION, ;---> IT'S OKAY TO JUST FLAG THEM ALL AS NEW. Q 1 ; CNTYRES() ;EP ;---> COUNTY OF RESIDENCE--OPTIONAL. Q "" ; STRES() ;EP ;---> STATE OF RESIDENCE, FIPS CODE. Q:'$D(^DPT(BWDFN,.11)) "" Q:$P(^DPT(BWDFN,.11),U,5)="" "" Q $P(^DIC(5,$P(^DPT(BWDFN,.11),U,5),0),U,3) ; ZIP() ;EP ;---> ZIP OF RESIDENCE. N X S X=$E($$ZIP^BWUTL1(BWDFN),1,5) Q:+X X Q "" ; DOB() ;EP ;---> DATE OF BIRTH, FORMAT: 09011956. N X S X=$$DOB^BWUTL1(BWDFN) Q:'+X "" Q $E(X,4,5)_$E(X,6,7)_($E(X,1,3)+1700) ; RACE() ;EP ;---> RACE. N X Q:'$D(^AUPNPAT(BWDFN,11)) 6 S X=$P(^AUPNPAT(BWDFN,11),U,8) Q:X=1 5 Q:X=206 3 Q:X=207 3 Q:X=208 3 Q:X=209 3 Q:X=210 3 Q:X=211 3 Q:X=212 3 Q:X=213 3 Q:X=214 1 Q:X=215 5 Q:X=216 2 Q:X=217 3 Q:X=219 5 Q:X=220 5 Q 4 ; HISP() ;EP ;---> HISPANIC: 3=UNKNOWN. Q 2 ; ENRLDT() ;EP ;---> ENROLLMENT DATE. IF PATIENT DOESN'T HAVE ENROLLMENT DATE, ;---> COMPUTE IT AND STUFF IT FOR THE PATIENT, THEN USE IT HERE. N X S X=$P(^BWP(BWDFN,0),U,21) D:'X ENROL^BWMDE5(BWDFN,$P(^BWSITE(DUZ(2),0),U,17),.X) ;---> IF COMPUTED DATE IS MM/YY ONLY, MAKE IT THE FIRST OF THE MONTH. S:$E(X,6,7)="00" $E(X,6,7)="01" Q $$CDCDT(X) ; REFER() ;EP ;---> REFERRAL SOURCE: IF NOT TRACKED, 4="UNKNOWN". N X S X=$P(^BWP(BWDFN,0),U,22) Q:X X Q 4 ; BRSYMP() ;EP ;---> BREAST SYMTOMS: IF NOT TRACKED, 3="UNKNOWN". Q:'BWMAM 3 ;---> IF THIS PCD IS MAM, RETURN FIELD 2.35 OF BW PROCEDURE FILE, ;---> WHICH SHOULD HAVE BEEN ENTERED MANUALLY. Q:$P(BW2,U,35) $P(BW2,U,35) Q 3 ; CBE() ;EP ;---> RETURN FIELD 2.32 OF BW PROCEDURE FILE. ;---> FIELD 2.32 IS ENTERED AUTOMATICALLY IF A CBE IS ADDED FROM ;---> THE "PROCEDURE FOLLOWUP MENU" FOR A PAP; OR, IT IS ENTERED ;---> MANUALLY ON PAGE 2 OF A MAMMOGRAM. ; ;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 12/12/96 ;N Z S Z=$P(BW2,U,32) ;Q:('Z&(BWMAM)) "" ;Q:'Z 3 ;;---> NOW COLLAPSE CDC CLINCAL CATEGORIES TO 4 MDE CATEGORIES. ;Q:'$D(^BWCBE(Z,0)) 0 ;---> IF ZERO, PROBLEM WITH ^BWCBE POINTER. ;Q $P(^BWCBE(Z,0),U,2) ; ; ;---> GET MANUALLY ENTERED CBE RESULT FOR THIS PROCEDURE. N Z S Z=$P(BW2,U,32) ; ;---> IF NO CBE RESULT AND THIS IS A PAP, RETURN 3. Q:('Z&(BWPAP)) 3 ; ;---> IF THERE IS A CBE RESULT, RETURN 1-4 MDE CATEGORIES. ;---> (IF ZERO, PROBLEM WITH ^BWCBE POINTER.) I Z Q:'$D(^BWCBE(Z,0)) 0 Q $P(^BWCBE(Z,0),U,2) ; ;---> IF IT WASN'T A PAP AND ISN'T A MAM, RETURN "" (ERROR). Q:'BWMAM "" ; ;---> IF NO CBE RESULT AND THIS IS A MAM, LOOK FOR LAST CBE. N N,Y K BW("CBE") S N=0 F S N=$O(^BWPCD("C",BWDFN,N)) Q:'N D .S Y=^BWPCD(N,0) .;---> IF THIS IS A CBE, GET DATE AND RESULT. .I $P(Y,U,4)=27 S BWCBEDT=$P(Y,U,12),BWCBERS=$P(Y,U,5) D ..Q:BWCBEDT'<$P(BW0,U,12) ..;---> IF CBE IS >1 YEAR BEFORE MAM, IGNORE IT. ..N X,X1,X2,Y S X1=$P(BW0,U,12),X2=BWCBEDT D ^%DTC Q:X>365 ..S BW("CBE",9999999-BWCBEDT)=BWCBERS ; ;---> IF NO CBE'S, RETURN "". Q:'$D(BW("CBE")) "" ; ;---> GET RESULT AND COLLAPSE TO 4 MDE CATEGORIES. N N S N=$O(BW("CBE",0)) S BWCBERS=$P(BW("CBE",N),U) Q:BWCBERS=11 1 Q:BWCBERS=64 1 Q:BWCBERS=78 "" Q:BWCBERS="" "" Q 2 ; ;===> ANMC MODS END, IHS/ANMC/MWRZ 12/12/96 ; ; CBEDT() ;EP ;---> RETURN THE DATE OF THE CBE. ;---> NOTE: IF THERE'S A DATE, BUT NO RESULT ABOVE, THEN SEND THE DATE ;---> SO THAT ERROR WILL SHOW UP NEED TO ENTER RESULT FOR THAT CBE. ;Q:789[$P(BW2,U,32) "" ; ;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 12/12/96 ;---> IF THE DATE HAS BEEN ENTERED MANUALLY, USE IT. Q:$P(BW2,U,33) $$CDCDT($P(BW2,U,33)) ;---> IF THIS IS A PAP AND NO CBE DATE ENTERED MANUALLY, QUIT "" ;---> (DON'T LOOK AT CBE ARRAY). Q:BWPAP "" ;---> THIS MUST BE A MAM, SO LOOK FOR CBE ARRAY. Q:'$D(BW("CBE")) "" ;---> USE ABOVE BW("CBE") ARRAY TO RETURN DATE OF LAST CBE. N N S N=$O(BW("CBE",0)) Q:'N "" Q $$CDCDT(9999999-N) ;===> ANMC MODS END, IHS/ANMC/MWRZ 12/12/96 ; PPREV() ;EP ;---> BUILD BW("PAP") ARRAY OF PREVIOUS PAPS. RETURN 3 IF NONE. Q:'BWPAP 3 N N,Y K BW("PAP") S N=0 F S N=$O(^BWPCD("C",BWDFN,N)) Q:'N D .S Y=^BWPCD(N,0) .I $P(Y,U,4)=1 S BWPAPDT=$P(Y,U,12) D ..Q:BWPAPDT'<$P(BW0,U,12) ..S BW("PAP",9999999-BWPAPDT)=BWPAPDT Q:$D(BW("PAP")) 1 Q 3 ; PPREVDT() ;EP Q:'BWPAP "" ;---> USE ABOVE BW("PAP") ARRAY TO RETURN DATE OF PREVIOUS PAP. Q:'$D(BW("PAP")) "" N N S N=$O(BW("PAP",0)) ;Begin Y2k fix ;I N S N=BW("PAP",N) K BW("PAP") Q $E(N,4,5)_$E(N,2,3) ; ;MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE ; I N S N=BW("PAP",N) K BW("PAP") Q $E(N,4,5)_($E(N,1,3)+1700) ;Y2000 ; ;END MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE ;End Y2k fix ; Q "" ; ADQPAP() ;EP ;---> ADEQUACY OF SCREENING PAP--OPTIONAL. Q "" ; PRESLT() ;EP ;---> IF THIS PCD IS NOT PAP, RETURN 9 & SET BWPABN=0 (ABNORMAL PAP=0). ;---> (BWPABN=0 WILL BLANK FILL ALL DATA IN ABNORMAL PAP SECTION.) ; I 'BWPAP S BWPABN=0 Q " 9" ;---> THIS PROCEDURE MUST BE A PAP. ;---> IF NO RESULT, RETURN 11 (RESULT PENDING) AND SET BWPABN=0. I 'BWRESN S BWPABN=0 Q 11 ; ;---> RETURN THE CDC CODE FOR THE RESULT (PC 24). IF RESULT IS 3,4,5 ;---> OR 6, SET BWPABN=1 TO EXTRACT DATA FOR ABNORMAL PAP SECTION. N X S X=$P(^BWDIAG(BWRESN,0),U,24) S BWPABN=$S(6543[X:1,1:0) Q $J(X,2) ; POTHR() ;EP ;---> IF RESULT IS "OTHER" (7), RETURN TEXT OF THE RESULT Q:'BWPAP "" Q:'BWRESN "" Q:$P(^BWDIAG(BWRESN,0),U,24)=7 $E(BWRES,1,20) Q "" ; PWKUP() ;EP ;---> RETURN THE DX WORKUP: 1=PLANNED, 2=NOT PLANNED, 3=UNDETERMINED. Q:'BWPAP 2 ;IHS/CMI/THL 04/13/99 PATCH XX TO RETURN CODE 3 Q:$E($G(BWCDC(+$G(BWIEN))),107,108)=11 3 Q:'BWPABN 2 N X S X=$P(BW2,U,20) Q:(BWPAP&(X)) X Q 2 ; PSCRDT() ;EP ;---> IF THIS PCD IS A PAP, RETURN THE DATE OF THIS PCD. Q:BWPAP $$CDCDT($P(BW0,U,12)) Q "" ; PPAY() ;EP ;---> PAP PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW. Q:'BWPAP "" N X S X=$$PRESLT Q:X=9!(X=10)!(X=11) "" Q:BWPAP 1 Q 3 ; MPREV() ;EP ;---> BUILD BW("MAM") ARRAY OF PREVIOUS MAMS. RETURN 3 IF NONE. Q:'BWMAM 3 N N,Y K BW("MAM") S N=0 F S N=$O(^BWPCD("C",BWDFN,N)) Q:'N D .S Y=^BWPCD(N,0) .I $$PMAM^BWUTL6(+$P(Y,U,4)) D ..S BWMAMDT=$P(Y,U,12) ..Q:BWMAMDT'<$P(BW0,U,12) ..S BW("MAM",9999999-BWMAMDT)=BWMAMDT Q:$D(BW("MAM")) 1 Q 3 ; MPREVDT() ;EP ;---> USE ABOVE BW("MAM") ARRAY TO RETURN DATE OF PREVIOUS MAM. Q:'BWMAM "" Q:'$D(BW("MAM")) "" N N S N=$O(BW("MAM",0)) ;Begin Y2k fix ;I N S N=BW("MAM",N) K BW("MAM") Q $E(N,4,5)_$E(N,2,3) ; ;MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE ; I N S N=BW("MAM",N) K BW("MAM") Q $E(N,4,5)_($E(N,1,3)+1700) ;Y2000 ; ;END MOD PER THL 03/25/99 FOR CDC V4.0 AND Y2K COMPLIANCE ;End Y2k fix ; Q "" ; MRESLT() ;EP ;---> IF THIS PCD IS NOT MAM: ;---> RETURN 9 IF BR TX NEED=MAM AND DUE DATE IS BEFORE TODAY. ;---> RETURN 8 IF BR TX NEED'=MAM, OR IF BR TX NEED=MAM BUT DUE DATE ;---> IS AFTER TODAY. ;---> BOTH CASES SET BWMABN=0 (ABNORMAL MAM=0). ;---> (BWMABN=0 WILL BLANK FILL ALL DATA IN ABNORMAL MAM SECTION.) ; I 'BWMAM S BWMABN=0 Q " 8" ;---> THIS PROCEDURE MUST BE A MAM. ;---> IF NO RESULT, RETURN 10 (RESULT PENDING) AND SET BWMABN=0. I 'BWRESN S BWMABN=0 Q 10 ;---> RETURN THE CDC CODE FOR THE RESULT (PC 25). IF RESULT IS 4,5, ;---> OR 6, SET BWMABN=1 TO EXTRACT DATA FOR ABNORMAL MAM SECTION. N X S X=$P(^BWDIAG(BWRESN,0),U,25) S BWMABN=$S(654[X:1,1:0) Q $J(X,2) ; MWKUP() ;EP ;---> RETURN THE DX WORKUP: 1=PLANNED, 2=NOT PLANNED, 3=UNDETERMINED. Q:'BWMAM 2 Q:'BWMABN 2 N X S X=$P(BW2,U,20) Q:(BWMAM&(X)) X Q 2 ; MDT() ;EP ;---> DATE OF THIS MAMMOGRAM. Q:'BWMAM "" Q:'+$P(BW0,U,12) "" Q:BWMAM $$CDCDT($P(BW0,U,12)) Q "" ; MPAY() ;EP ;---> MAM PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW. Q:'BWMAM "" N X S X=$$MRESLT Q:X=8!(X=9)!(X=10) "" Q:BWMAM 1 Q "" BDXPAID() ;EP ;---> BREAST DX PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW. Q:'BWMAM "" N X S X=$$MRESLT Q:X=8!(X=9)!(X=10) "" Q:BWMAM 1 Q "" CBEPAID() ;EP ;---> CBE PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW. Q:'BWMAM "" N X S X=$$MRESLT Q:X=8!(X=9)!(X=10) "" Q:BWMAM 1 Q "" ; CDXPAID() ;EP ;---> CBE PAID FOR BY COOP AGREEMENT FUNDS, 3=DON'T KNOW. Q:'BWPAP "" I '$$CONOBX(),'$$COLPBX(),'$$POTHPR() Q "" Q 1 ; MDEVER() ;EP ;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 07/17/97 ;Q 23 ;Q 24 ;IHS/ANMC/MWRZ 07/17/97 ;CHANGE VERSION# FROM 23 TO 24. Q 40 ;CMI/THL 03/25/99 ;CHANGE VERSION# FROM 24 TO 40. ;===> ANMC MODS END, IHS/ANMC/MWRZ 07/17/97 ; CONOBX() ;EP ;---> COLP DONE WITHOUT BIOPSY. Q:'BWPABN "" Q:$$PWKUP>1 "" ;---> IF THERE IS AN ASSOCIATED COLP, BWC0=ZERO NODE OF THAT PCD. Q:BWC0']"" 2 Q:$P(BWC0,U,26)="" 1 Q 2 ; COLPBX() ;EP ;---> COLP DONE WITH BIOPSY. Q:'BWPABN "" Q:$$PWKUP>1 "" ;---> IF THERE IS AN ASSOCIATED COLP, BWC0=ZERO NODE OF THAT PCD. Q:BWC0']"" 2 Q:$P(BWC0,U,26)]"" 1 Q 2 ; POTHPR() ;EP ;---> OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL PAP. Q:'BWPABN "" Q:$$PWKUP>1 "" Q:$P(BW2,U,21)]"" 1 Q 2 ; POTHPR1() ;EP ;---> LIST OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL PAP. Q:'BWPABN "" Q:$$PWKUP>1 "" Q $E($P(BW2,U,21),1,20) ; POTHPR2() ;EP Q "" ; PFNDX() ;EP ;---> FINAL DIAGNOSIS FOR ASSOCIATED COLP. ;---> FIRST TRY TO GET IT FROM #.33 FIELD; IF NOT, TRY ASSOC'D COLP. Q:'BWPABN "" Q:$$PWKUP>1 "" N X S X=$P(BW0,U,33) S:'X X=$P(BWC0,U,5) Q:'X "" Q:'$D(^BWDIAG(X,0)) "" Q $P(^BWDIAG(X,0),U,26) ; PSTGDX() ;EP ;---> STAGE AT FINAL DIAGNOSIS. GET FROM ASSOC'D COLP. Q:'BWPABN "" Q:$$PWKUP>1 "" Q:$$PFNDX()'=6 "" Q $P(BWC0,U,31) ; PFNDXO() ;EP ;---> FREE TEXT DIAGNOSIS OF "OTHER" FOR ASSOC'D COLP. Q:'BWPABN "" Q:$$PWKUP>1 "" Q:$$PFNDX()'=7 "" N X S X=$P(BW0,U,33) S:'X X=$P(BWC0,U,5) Q:'X "" Q:'$D(^BWDIAG(X,0)) "" Q $E($P(^BWDIAG(X,0),U),1,20) ; PSTFDX() ;EP ;---> PAP STATUS OF FINAL DX. Q:'BWPABN "" Q:$$PWKUP>1 "" Q $P(BW2,U,22) ; PFDXDT() ;EP ;---> PAP DATE OF FINAL DX. Q:'BWPABN "" Q:$$PWKUP>1 "" Q $$CDCDT($P(BW2,U,23)) ; PSTTX() ;EP ;---> STATUS OF TX. Q:'BWPABN "" Q:$$PWKUP>1 "" Q $P(BW2,U,24) ; PSTXDT() ;EP ;---> DATE OF TX STATUS. Q:'BWPABN "" Q:$$PWKUP>1 "" Q $$CDCDT($P(BW2,U,25)) ; MFUDXV() ;EP ;---> MAM FOLLOWUP DIAGNOSTIC VIEWW. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW2,U,34) ; MRBREX() ;EP ;---> MAM REPEAT BREAST EXAM. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW2,U,26) ; MULTRA() ;EP ;---> MAM ULTRASOUND. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW2,U,27) ; MLUMP() ;EP ;---> MAM BIOPSY/LUMPECTOMY. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW2,U,28) ; MFINDL() ;EP ;---> MAM FINE NEEDLE/CYST ASPIRATION. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW2,U,29) ; MOTHPR() ;EP ;---> MAM OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL MAM. Q:'BWMABN "" Q:$$MWKUP>1 "" Q:$P(BW2,U,21)]"" 1 Q 2 ; MOTHPR1() ;EP ;---> LIST OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL PAP. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $E($P(BW2,U,21),1,20) ; MOTHPR2() ;EP ;---> LIST MORE OTHER PROCEDURES PERFORMED WITH THIS ABNORMAL PAP. Q "" Q:'BWMABN "" ; MFNDX() ;EP ;---> MAM FINAL DX. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW2,U,30) ; MSTGDX() ;EP ;---> MAM STAGE AT FINAL DX. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW0,U,31) ; MTMRSZ() ;EP ;---> MAM TUMOR SIZE. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW2,U,31) ; MSTFDX() ;EP ;---> MAM STATUS OF FINAL DX. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW2,U,22) ; MFDXDT() ;EP ;---> MAM DATE OF FINAL DX. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $$CDCDT($P(BW2,U,23)) ; MSTTX() ;EP ;---> MAM STATUS OF TX. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $P(BW2,U,24) ; MSTXDT() ;EP ;---> MAM DATE OF TX STATUS. Q:'BWMABN "" Q:$$MWKUP>1 "" Q $$CDCDT($P(BW2,U,25)) ; EOR() ;EP Q "" ; HRCN() ; ;---> APPEND HEALTH RECORD NUMBER FOR LOCAL PURPOSE. Q $$HRCN1^BWUTL1(BWDFN,DUZ(2)) BWMDET BWMDET ;CMI/THL - NEW METHOD TO EXPORT CBE/MAM DATA; [ 05/25/99 9:17 AM ] ;;2.0;WOMEN'S HEALTH;**5**;MAY 16, 1996 ;; CDC EXPORT, BUILDS ASCII FIXED LENGTH RECORDS FOR EXPORT. ;IHS/CMI/THL - patch 5 new routine for new cdc format ;; ;; BWTCBE(35) = CDC DX CODE ;; BWTCBE(36) = DX WORKUP PLANNED CODE ;; Each of the BWTCBE(n) variables corresponds to the 67 field of the ;; CDC exprt record per version 2.4 ;EVALUATE EACH PROCEDURE FOR CDC EXPORT EN D EN1 EXIT K BWTPN,BWTPNDA,BWTPCDDA,BWTPATDA,BWTI,BWTJ,BWTPDAX,BWTDATE,BWTDAT,BWT0,BWT2,BWTDATX,BWTCBE K ^TMP("BWTBW2",$J) K ^TMP("BWTPCD",$J) K ^TMP("CBEARRAY",$J) Q EN1 ;REVIEW ALL MAMMS AND CBE'S D EXIT S BWTTOT=0 F BWTPNDA=28,25,26 D PCD Q PCD ;FIND EACH PATIENT WHO HAS HAD A MAMM OR CBE I '$D(BWTSEL) D Q .S BWTPCDDA=0 .F S BWTPCDDA=$O(^BWPCD("APCD",BWTPNDA,BWTPCDDA)) Q:'BWTPCDDA D PT I $D(BWTSEL) D Q .S BWTX=0 .F S BWTX=$O(BWTSEL(BWTX)) Q:'BWTX D ..S BWTPCDDA=0 ..F S BWTPCDDA=$O(^BWPCD("C",BWTX,BWTPCDDA)) Q:'BWTPCDDA D:$P(^BWPCD(BWTPCDDA,0),U,4)=BWTPNDA PT Q PT ;EVALUATE ALL MAMM'S AND CBE'S FOR EACH PATIENT N X S X=$G(^BWPCD(BWTPCDDA,0)) Q:X="" S BWTPATDA=$P(X,U,2) Q:'BWTPATDA I $G(BWCUTF),BWCUTF>$$AGE^BWUTL1(BWTPATDA) Q I $G(BWCUTO),BWCUTO<$$AGE^BWUTL1(BWTPATDA) Q ;I $P($P($G(^DPT(BWTPATDA,0)),U),",")="DEMO" W:'$D(^TMP("BWTPCD",$J,BWTPCDDA)) !,BWTPATDA,?10,$P(^DPT(BWTPATDA,0),U)," disregarded." Q N BWTBWPCD,BWTPDA D:'$D(^TMP("BWTPCD",$J,BWTPCDDA)) EVAL Q INTV ;CALCULATE INTERVAL BETWEEN EVENTS S X1=BWTDAT S X2=BWTDATX D ^%DTC S:X<0 X=X*-1 S BWTINTV=X Q EVAL ;EVALUATE MAMMOGRAM K BWTQUIT D ENDATE I $D(BWTQUIT) K BWTQUIT Q K BWT D SETUP S BWTP0=^BWPCD(BWTPCDDA,0) S BWTP2=$G(^BWPCD(BWTPCDDA,2)) S BWTDAT=$P(BWTP0,U,12) I BWTDAT<2950101 D USED Q S BWT("MAM RESULT POINTER")=$P(BWTP0,U,5) S BWTCBE(35)=$P($G(^BWDIAG(+BWT("MAM RESULT POINTER"),0)),U,25) Q:BWTCBE(35)=9!'BWTCBE(35) I BWTCBE(35),BWTCBE(35)<8!(BWTCBE(35)=11!(BWTCBE(35)=10)) S BWTCBE(38)=1 N XX,YY S XX=BWTDAT S YY=37 D F1 D LASTCBE I $D(BWTQUIT) K BWTQUIT Q S ^TMP("BWTPCD",$J,BWTPCDDA)="" S BWIEN=BWTPCDDA I +BWTCBE(35)=1!(+BWTCBE(35)=2)!(+BWTCBE(35)=3) D NORMAM I +BWTCBE(35)=4!(+BWTCBE(35)=5)!(+BWTCBE(35)=6)!(+BWTCBE(35)=11) D ABNORMAM D FILE Q NORMAM ;NORMAL MAMMOGRAM I BWTCBE(21)=1,BWTINTV<361 D NMNC I BWTCBE(21)=2,BWTINTV<61 D AMNC Q ABNORMAM ;ABNORMAL MAMMOGRAM I BWTCBE(21)=1,BWTINTV<361 D AMNC I BWTCBE(21)=2,BWTINTV<61!(BWTCBE(35)=4)!(BWTCBE(35)=5) D AMAC Q LASTCBE ;FIND LAST CBE D CBEARRAY Q:'$D(^TMP("CBEARRAY",$J,BWTPATDA)) K BWTQUIT N BWTX,BWTDATX S BWTZ="" ;CHECK FOR CBE ON SAME DAY UP IEN S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDAT,BWTPCDDA)) I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)),$P($G(^BWPCD(BWTX,0)),U,4)=27 S BWTZ=BWTX D L1 Q ;CHECK FOR CBE ON SAME DAY BACK IEN S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDAT,BWTPCDDA),-1) I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)),$P($G(^BWPCD(BWTX,0)),U,4)=27 S BWTZ=BWTX D L1 Q ;CHECK FOR CBE ON PREVIOUS VISIT DAY FOR UP TO 2 VISITS ON THAT DATE S BWTDATX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDAT),-1) I 'BWTDATX D L0 Q S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDATX,0)) I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)),$P($G(^BWPCD(BWTX,0)),U,4)=27 S BWTZ=BWTX D L1 Q S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDATX,BWTX)) I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)),$P($G(^BWPCD(BWTX,0)),U,4)=27 S BWTZ=BWTX D L1 Q ;CHECK FOR CBE ON NEXT VISIT DAY FOR UP TO 2 VISITS ON THAT DATE S BWTDATX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDAT)) I 'BWTDATX D L0 Q S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDATX,0)) I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)),$P($G(^BWPCD(BWTX,0)),U,4)=27 S BWTZ=BWTX D L1 Q S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDATX,BWTX)) I BWTX,'$D(^TMP("BWTPCD",$J,BWTX)),$P($G(^BWPCD(BWTX,0)),U,4)=27 S BWTZ=BWTX D L1 Q L0 I 'BWTZ S BWTQUIT="" Q L1 D ENDATE Q:$D(BWTQUIT) S ^TMP("BWTPCD",$J,BWTZ)="" S X=$G(^BWPCD(BWTZ,0)) I $P(X,U,5)=8!'$P(X,U,5) S BWTQUIT="" Q S BWT("CBE RESULT POINTER")=$P($G(^BWDIAG(+$P(X,U,5),0)),U,27) S BWTCBE(21)=$P($G(^BWCBE(+BWT("CBE RESULT POINTER"),0)),U,2) I BWTCBE(21),BWTCBE(21)<3 S BWTCBE("CBE PAID")=1 S BWTDATX=$P(X,U,12) S BWTDAT=$P(BWTDAT,".") N XX,YY S XX=BWTDATX S YY=22 D F1:BWTCBE(21)<3 D INTV Q FUPCD ;FOLLOW-UP PROCEDURES N J,YY,Z,ZZ,ZZZ,BWTDATX S BWTDATX=BWTDAT-1 F S BWTDATX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDATX)) Q:'BWTDATX D FU1 Q FU1 S BWTX=BWTPCDDA F S BWTX=$O(^TMP("CBEARRAY",$J,BWTPATDA,BWTDATX,BWTX)) Q:'BWTX!$D(BWTQUIT) D .S BWTDATX=$P($G(^BWPCD(BWTX,0)),U,12) .D INTV .Q:BWTINTV>60 .S X=$G(^BWPCD(BWTX,0)) .S Y=$P(X,U,4) .S YY=$G(^BWPCD(BWTX,2)) .S Z=$P(X,U,5) .S ZZ=$P($G(^BWDIAG(+Z,0)),U,25) .S ZZZ=$P($G(^BWDIAG(+Z,0)),U,27) .I Y=27 D 27 .I Y=25!(Y=26) D 25 .I Y=38!(Y=30)!(Y=31)!(Y=34) D 38 .S ^TMP("BWTPCD",$J,BWTX)="" .I $G(BWTCBE(63))=1 D ..N XX,YY ..S XX=$P(X,U,12) ..S YY=64 ..D F1 .I $G(BWTCBE(60)),BWTCBE(60)<3 D ..I BWTCBE(60)=2 D ...S BWTCBE(61)=$S($P(X,U,31):$P(X,U,31),1:8) ...S BWTCBE(62)=$S($P(YY,U,31):$P(YY,U,31),1:5) ..S BWTCBE(65)=1 ..S XX=$P(X,U,12) ..S YY=66 ..D F1 K BWTQUIT Q 27 S BWTCBE(53)=1 S ZZZ=$P($G(^BWCBE(+ZZZ,0)),U,2) I ZZZ,ZZZ<3 D .I $G(BWTCBE(60)),BWTCBE(60)<3 .E S BWTCBE(60)=3 .S BWTCBE(63)=1 I ZZZ>2,ZZZ<7 D .S BWTCBE(60)=1 .S BWTCBE(63)=1 Q 25 S BWTCBE(52)=1 S BWTCBE(63)=2 I ZZ<4 D .I $G(BWTCBE(60)),BWTCBE(60)<3 .E S BWTCBE(60)=3 .S BWTCBE(63)=1 I ZZ=4!(ZZ=5) D .S BWTCBE(60)=1 .S BWTCBE(63)=1 Q 38 I Y'=38 D .S Z=$P($G(^BWDIAG(+Z,0)),U) .S Z=$TR(Z,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") .I Z["SITU" S BWTCBE(60)=1 .I Z["INVASIVE" S BWTCBE(60)=2 .E D ..S ZZ=3 ..I $G(BWTCBE(60)),BWTCBE(60)<3 ..E S BWTCBE(60)=3 ..S BWTCBE(63)=1 .S BWTCBE(63)=1 .S:Y=34 BWTCBE(56)=1 .S:Y=30!(Y=31) BWTCBE(55)=1 I Y=38,ZZ<4 D .I $G(BWTCBE(60)),BWTCBE(60)<3 .E S BWTCBE(60)=3 .S BWTCBE(63)=1 I Y=38,ZZ=4!(ZZ=5) D .S BWTCBE(60)=1 .S BWTCBE(63)=1 S:Y=38 BWTCBE(54)=1 Q F1 Q:'$G(XX)!'$G(YY) Q:XX'?7N S:XX<2950101 XX=2950101 S BWTCBE(YY)=$E(XX,4,7)_($E(XX,1,3)+1700) Q NMNC ;NORMAL MAM NORMAL CBE Q AMNC ;NORMAM MAM ABNORMAL CBE D DXWU D FUPCD Q NMAC ;NORMAL MAM ABNORMAL CBE D DXWU Q AMAC ;ABNORMAM MAM ABNORMAL CBE D DXWU D FUPCD Q DXWU ;DIAGNOSTIC WORKUP PLANNED S BWTCBE(36)=1 F X=52:1:57 S BWTCBE(X)=2 Q FILE ;FILE NEW EXPORT RECORD S BWTTOT=BWTTOT+1 U 0 W "." D ^BWUTL5,PCDVARS^BWUTL3(BWIEN,0,1) S BWMAM=1 S BWPAP=0 S $E(BWCDC(BWIEN),1)=$$STSCR^BWMDE2 S $E(BWCDC(BWIEN),3)=$$CNTYSCR^BWMDE2 S $E(BWCDC(BWIEN),6)=$$CITY^BWMDE2 S $E(BWCDC(BWIEN),21)=$$ENROLL^BWMDE2 S $E(BWCDC(BWIEN),26)=$$PSCRSI^BWMDE2 S $E(BWCDC(BWIEN),31)=$$MSCRSI^BWMDE2 S $E(BWCDC(BWIEN),40)=$$PATID^BWMDE2 S $E(BWCDC(BWIEN),55)=$$RECID^BWMDE2 S $E(BWCDC(BWIEN),61)=$$RECTYP^BWMDE2 S $E(BWCDC(BWIEN),62)=$$CNTYRES^BWMDE2 S $E(BWCDC(BWIEN),65)=$$STRES^BWMDE2 S $E(BWCDC(BWIEN),67)=$$ZIP^BWMDE2 S $E(BWCDC(BWIEN),72)=$$DOB^BWMDE2 S $E(BWCDC(BWIEN),80)=$$RACE^BWMDE2 S $E(BWCDC(BWIEN),81)=$$HISP^BWMDE2 S $E(BWCDC(BWIEN),88)=$G(BWTCBE(20)) S $E(BWCDC(BWIEN),89)=$G(BWTCBE(21)) S $E(BWCDC(BWIEN),90)=$G(BWTCBE(22)) S $E(BWCDC(BWIEN),98)=$G(BWTCBE("CBE PAID")) S $E(BWCDC(BWIEN),99)=$G(BWTCBE(23)) S $E(BWCDC(BWIEN),107)=$G(BWTCBE(27)) S $E(BWCDC(BWIEN),129)=$G(BWTCBE(29)) S $E(BWCDC(BWIEN),139)=$G(BWTCBE(32)) S $E(BWCDC(BWIEN),140)=$G(BWTCBE(33)) S $E(BWCDC(BWIEN),146)=$G(BWTCBE(35)) S $E(BWCDC(BWIEN),148)=$G(BWTCBE(36)) S $E(BWCDC(BWIEN),149)=$G(BWTCBE(37)) S $E(BWCDC(BWIEN),157)=$G(BWTCBE(38)) S $E(BWCDC(BWIEN),158)=40 S $E(BWCDC(BWIEN),243)=$G(BWTCBE(52)) S $E(BWCDC(BWIEN),244)=$G(BWTCBE(53)) S $E(BWCDC(BWIEN),245)=$G(BWTCBE(54)) S $E(BWCDC(BWIEN),246)=$G(BWTCBE(55)) S $E(BWCDC(BWIEN),247)=$G(BWTCBE(56)) S $E(BWCDC(BWIEN),248)=$G(BWTCBE(57)) S $E(BWCDC(BWIEN),249)=$G(BWTCBE(58)) S $E(BWCDC(BWIEN),269)=$G(BWTCBE(59)) S X=$E(BWCDC(BWIEN),243,248) F J=1:1:6 I $E(X,J)=1 S $E(BWCDC(BWIEN),288)=1 I X=222222 S $E(BWCDC(BWIEN),288)=2 S $E(BWCDC(BWIEN),289)=$G(BWTCBE(60)) S $E(BWCDC(BWIEN),290)=$G(BWTCBE(61)) S $E(BWCDC(BWIEN),291)=$G(BWTCBE(62)) I $G(BWTCBE(63)) S $E(BWCDC(BWIEN),292)=$G(BWTCBE(63)) E I X=222222 S $E(BWCDC(BWIEN),292)=2 S $E(BWCDC(BWIEN),293)=$G(BWTCBE(64)) S $E(BWCDC(BWIEN),301)=$G(BWTCBE(65)) S $E(BWCDC(BWIEN),302)=$G(BWTCBE(66)) S $E(BWCDC(BWIEN),310)=$$EOR^BWMDE2 S ^BWTMP($J,BWDFN,BWIEN)=BWCDC(BWIEN) S ^TMP("BWEXPORT",$J,BWDFN,BWIEN)=BWCDC(BWIEN) K BWCDC(BWIEN),BWTCBE Q SETUP ; S BWTCBE(20)=2 S BWTCBE(21)=1 S BWTCBE(23)=3 S BWTCBE(27)=" 9" S BWTCBE(29)=2 S BWTCBE(32)=2 S BWTCBE(35)="01" S BWTCBE(36)=2 Q CBEARRAY ;CREATE ARRAY OF ALL VISITS FOR A PATIENT Q:$D(^TMP("CBEARRAY",$J,BWTPATDA)) N X,Y,Z S X=0 F S X=$O(^BWPCD("C",BWTPATDA,X)) Q:'X D .S Y=$G(^BWPCD(X,0)) .Q:'$P(Y,U,12) .Q:"^27^28^25^26^30^31^34^38^"'[(U_$P(Y,U,4)_U) .S Z=$P(Y,U,12) .S ^TMP("CBEARRAY",$J,BWTPATDA,Z,X)=$P($G(^BWPCD(X,0)),U,1,12) Q ENDATE ;CHECK ENROLLMENT DATE N BWTDAT,BWTDATX S X1=$P($G(^BWP(BWTPATDA,0)),U,21) S X2=$P($G(^BWPCD(+$G(BWTPCDDA),0)),U,12) Q:'X1!'X2!(X159 S BWTQUIT="" D USED Q USED ;ENTRY EVALUATED AND SHOULD NOT BE USED AGAIN S ^TMP("BWTPCD",$J,BWTPCDDA)="" 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 BWPROF3 BWPROF3 ;IHS/ANMC/MWR - DISPLAY PATIENT PROFILE; [ 05/19/99 2:12 PM ] ;;2.0;WOMEN'S HEALTH;**5**;MAY 16, 1996 ;IHS/CMI/LAB - Y2K ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * ;; DISPLAY CODE FOR PATIENT PROFILE. CALLED BY BWPROF1. ; NOMATCH ;EP ;---> QUIT IF NO RECORDS MATCH. I '$D(^TMP("BW",$J,1)) D Q .D HEADER2^BWUTL7 .K BWPRMT,BWPRMT1,BWPRMTQ,DIR .W !!?5,"No records match the selected criteria.",! .D:BWCRT DIRZ^BWUTL3 W @IOF D ^%ZISC S BWPOP=1 ; ;---> BWD=1:DETAILED DISPLAY, BWD=0:BRIEF DISPLAY. I BWD D DISPLAY1 Q D DISPLAY2 Q ; ; DISPLAY1 ;EP ;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE ;---> FROM LINELABEL "END" BELOW. D HEADER2^BWUTL7 F S N=$O(^TMP("BW",$J,2,N)) Q:'N!(BWPOP) D .I $Y+9>IOSL D:BWCRT DIRPRMT^BWUTL3 Q:BWPOP D ..S BWPAGE=BWPAGE+1 ..D HEADER2^BWUTL7 S (BWACCP,Z)=0 .S Y=^TMP("BW",$J,2,N),M=N .W ! .; .;---> ********************** .;---> DISPLAY PROCEDURES .;---> IF PIECE 1=1 DISPLAY AS A PROCEDURE. .I $P(Y,U)=1 D Q ..W !,"------------------------------< " ..W "PROCEDURE: ",$P(Y,U,5)," >" ;PROCEDURE ABBREVIATION ..F I=1:1:(6-$L($P(Y,U,5))) W "-" ..W "-----------------------------" ..W ! W:BWCRT $J(N,3),")" W ?BWTAB ;BROWSE SELECTION# ..W $P(Y,U,6) ;ACCESSION# ..;begin Y2K ..W ?16,$P(Y,U,4) ;DATE OF PROCEDURE ;IHS/CMI/LAB 17 to 16 Y2000 ..;end Y2K ..W ?27,"Res/Diag: ",$P(Y,U,7) ;RESULTS/DIAGNOSIS ..W !?27,"Provider: ",$E($P(Y,U,8),1,14) ;PROVIDER ..W ?62,"Status: ",$P(Y,U,9) ;STATUS ..S BWACCP=$P(Y,U,6) ;STORE AS PREVIOUS ACCESS# .; .;---> ********************** .;---> DISPLAY NOTIFICATIONS .;---> IF PIECE 1=2 DISPLAY AS A NOTIFICATION. .I $P(Y,U)=2 D Q ..S BWACC=$P(Y,U,5) ..I BWACC'=Z D ...;begin Y2K ...W ! W:BWACC["NO ACC#" "-----------------" W ?16 ;IHS/CMI/LAB 17 to 16 Y2000 ...;end Y2K ...W "-------------< NOTIFICATIONS >---------------------------------" ..W ! W:BWCRT $J(N,3),")" W ?BWTAB ;BROWSE SELECTION# ..W:BWACC'=BWACCP!(BWACC["NO ACC#") BWACC ;ACCESSION# ..;begin Y2K ..W ?16,$P(Y,U,4) ;DATE OF PROCEDURE;IHS/CMI/LAB 17 to 16 Y2000 ..;end Y2K ..W ?27,$E($P(Y,U,6)_": "_$P(Y,U,7),1,53) ;TYPE AND PURPOSE ..W !?27,"Outcome: ",$E($P(Y,U,8),1,23) ;OUTCOME OF NOTIFICATION ..W ?62,"Status: ",$P(Y,U,9) ;STATUS ..S (BWACCP,Z)=BWACC ;STORE AS PREVIOUS ACC# ..; ..;---> TWO VARIABLES (BWACCP & Z) USED ABOVE: "Z" SAYS "IF THIS NOTIF ..;---> ACC# IS NOT THE SAME AS THE LAST ONE, DISPLAY ---- BANNER. ..;---> "BWACCP" SAYS "IF THIS NOTIF ACC# MATCHES THE LAST PROCEDURE'S ..;---> ACC#, DON'T DISPLAY THE ACCESSION#." ..;---> BOTH VARIABLES ARE RESET AFTER A FORMFEED, IN ORDER TO DISPLAY ..;---> ON THE NEW PAGE. .; .;---> ********************** .;---> DISPLAY PAP REGIMENS .;---> IF PIECE 1=3 DISPLAY AS A PAP REGIMEN. .I $P(Y,U)=3 D Q ..W !,"------------------------------< PAP REGIMEN CHANGE" ..W " >----------------------------" ..;begin Y2K ..W !?9,"Began:" ;IHS/CMI/LAB - 10 to 9 Y2000 ..W ?16,$P(Y,U,4) ;DATE OF REGIMEN ENTRY ;IHS/CMI/LAB 17 to 16 Y2000 ..;end Y2K ..W ?27,"Regimen: ",$P(Y,U,5) ;PAP REGIMEN .; .;---> ********************** .;---> DISPLAY PREGNANCIES .;---> IF PIECE 1=4 DISPLAY AS A PREGNANCY. .I $P(Y,U)=4 D Q ..W !,"------------------------------< PREGNANCY STATUS" ..W " >------------------------------" ..;begin Y2K ..W !?6,"Entered:" ;IHS/CMI/LAB - 8 to 6 patch 5 Y2000 ..W ?15,$P(Y,U,4) ;DATE OF PREGNANCY EDIT. ;IHS/CMI/LAB - 17 to 15 Y2000 ..;end Y2K ..W ?27,$P(Y,U,5) ;PREGNANT/NOT ..W:$P(Y,U,6)]"" ?50,"EDC: ",$P(Y,U,6) ;EDC ; END ;EP W:'BWCRT @IOF ;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-5 AND START (GOTO) ;---> DISPLAY1 OVER AGAIN FROM 5 RECORDS PREVIOUS. I BWCRT&('$D(IO("S")))&('BWPOP) D DIRPRMT^BWUTL3 I N S N=N-1 G NOMATCH D ^%ZISC K N,Z Q ; ; ; DISPLAY2 ;EP ;---> IF A PROCEDURE IS EDITED ON THE LAST PAGE, GOTO HERE ;---> FROM LINELABEL "END" BELOW. S BWSUBH="SUBHEAD^BWPROF1" D HEADER2^BWUTL7 F S N=$O(^TMP("BW",$J,2,N)) Q:'N!(BWPOP) D .I $Y+9>IOSL D:BWCRT DIRPRMT^BWUTL3 Q:BWPOP D ..S BWPAGE=BWPAGE+1 ..D HEADER2^BWUTL7 S (BWACCP,Z)=0 .S Y=^TMP("BW",$J,2,N),M=N .;---> QUIT IF NOT A PROCEDURE (PIECE 1'=1). .Q:$P(Y,U)'=1 .W ! W:BWCRT $J(N,3),")" W ?BWTAB ;BROWSE SELECTION# .W $P(Y,U,4) ;DATE OF PROCEDURE .W ?17,$P(Y,U,5) ;PROCEDURE ABBREVIATION .W ?27,$P(Y,U,7) ;RESULT .W ?71,$P(Y,U,9) ;STATUS .S BWACCP=$P(Y,U,6) ;STORE AS PREVIOUS ACCESS# END2 ;EP W:'BWCRT @IOF ;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-1 AND START (GOTO) ;---> DISPLAY2 OVER AGAIN FROM 5 RECORDS PREVIOUS. I BWCRT&('$D(IO("S")))&('BWPOP) D DIRPRMT^BWUTL3 I N S N=N-1 G NOMATCH D ^%ZISC K N,Z 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 BWUTL5 BWUTL5 ;IHS/ANMC/MWR/HJT - UTIL: ACC#, TITLES, SL/TX DATES; [ 05/17/99 2:50 PM ] ;;2.0;WOMEN'S HEALTH;**5**;MAY 16, 1996 ;Modified for Y2k Compliance 5/14/1999 IHS/DSD/HJT ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * ;; UTILITY: SETVARS, GENERATE ACCESSION#, MENUT, TITLE, CENTERT, ;; COPYLET, UPPERCASE XREF, CDC, SL/TX DATES. ; ; SETVARS ;EP D XBKVAR S:'$D(IOF) IOF="#" S:'$D(BWPOP) BWPOP=0 Q ;************** ;---> XBKVAR INCORPORATED HERE FOR VA COMPATIBILITY. XBKVAR ;SET MINIMUM KERNEL VARIABLES; ; FROM ;;2.5;XB;;MAR 20, 1991 ; FROM ;IHS/DSD/JCM 7/6/92 Added Set of DUZ("AG") ; S U="^" I '$D(DUZ(2)),$D(^AUTTSITE(1,0)) S DUZ(2)=+^(0) I '$D(DUZ(2)),$D(^AUTTLOC("SITE")) S DUZ(2)=+^(0) I '$D(DUZ("AG")) S DUZ("AG")=$S($P($G(^XMB(1,0)),"^",8)]"":$P(^XMB(1,0),"^",8),1:"I") ;IHS/DSD/JCM 7/6/92 S:'($D(DUZ)#2) DUZ=0 S:'($D(DUZ(0))#2) DUZ(0)="" S:'($D(DUZ(2))#2) DUZ(2)=0 I '$D(DT) D NOW^%DTC S DT=X S:'$D(DTIME) DTIME=999 K %,%H,%I Q ;************** ; ; ACCSSN(PCDTYPE) ;EP ;---> GENERATE ACCESSION# FOR BW PROCEDURE FILE ENTRY. ;---> REQUIRED VARIABLE: PCDTYPE=IEN OF PROCEDURE TYPE (#9002086.2) N A,C,L,N,P,X Q:'$D(PCDTYPE) "" Q:'$D(^BWPN(PCDTYPE,0)) "" S X=^BWPN(PCDTYPE,0) ;X=0-NODE OF PROC TYPE S P=$P(X,U,4) ;P=PREFIX S L=$P(X,U,6) ;L=LAST ASSIGNED ACCESSION# FOR THIS PROC S A=$P(L,"-") ;A=ACC YEAR S C=$P(L,"-",2) ;C=COUNTER D NOW^%DTC S N=$E(%I(3),2,3) ;N=YEAR NOW: 94 I A'=N S C=0 F L +^BWPN(PCDTYPE,0):1 Q:$T F S C=C+1 S R=P_N_"-"_C Q:'$D(^BWPCD("B",R)) S $P(^BWPN(PCDTYPE,0),U,6)=N_"-"_C L -^BWPN(PCDTYPE,0) Q R ;R=RESULT(NEW ACCESSION#) ; MENUT(TITLE) ;EP ;---> DISPLAY MENU TITLE FROM BW MENU OPTIONS. ;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED. ;---> DUZ(2)=CURRENT LOCATION TO BE DISPLAYED. N BWTTAB,BWFAC,BWUNL,I S:'$D(TITLE) TITLE="* NO TITLE SUPPLIED *" S TITLE="* "_TITLE_" *" S BWTTAB=39-($L(TITLE)/2) W:$D(IOF) @IOF W !?3,"WOMEN'S HEALTH:" W ?BWTTAB,TITLE W ?60,$E($$INSTTX^BWUTL6(DUZ(2)),1,20) S BWUNL="" F I=1:1:$L(TITLE) S BWUNL=BWUNL_"=" W !?BWTTAB,BWUNL Q ; TITLE(TITLE) ;EP ;---> DISPLAY A TITLE. ;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED. N BWTTAB S:'$D(TITLE) TITLE="* NO TITLE SUPPLIED *" S TITLE="* * * WOMEN'S HEALTH: "_TITLE_" * * *" S BWTTAB=39-($L(TITLE)/2) W:$D(IOF) @IOF W !?BWTTAB,TITLE,!! Q ; CENTERT(TEXT) ;EP ;---> ADD LEADING SPACES TO CENTER TEXT. S:'$D(TEXT) TEXT="* NO TEXT SUPPLIED *" N I F I=1:1:(39-($L(TEXT)/2)) S TEXT=" "_TEXT Q ; UPPER() ;EP S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") Q X ; COPYLET ;EP ;---> COPY TEXT OF GENERIC SAMPLE LETTER TO ONE OR MORE BW PURPOSES. ;---> EDIT NEXT LINE TO INCLUDE IENS OF BW PURPOSES TO BE CHANGED. ;F DA=15,16,18,19 D S DA=0 F S DA=$O(^BWNOTP(DA)) Q:'DA D .K ^BWNOTP(DA,1) .S N=0 .F S N=$O(^BWLET(1,1,N)) Q:'N D ..S ^BWNOTP(DA,1,N,0)=^BWLET(1,1,N,0) .S ^BWNOTP(DA,1,0)=^BWLET(1,1,0) Q ; ; UPXREF(X,BWGBL) ;EP ;---> SET UPPERCASE XREF FOR X. CALLED FROM MUMPS XREFS ON MIXED CASE ;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED. ;---> REQUIRED VARIABLES: BWGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE ;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN. Q:'$D(BWGBL)!('$D(X)) N BWX S BWX=X,X=$$UPPER S @(BWGBL_"""U"",$E(X,1,30),DA)")="" S X=BWX K BWGBL Q ; KUPXREF(X,BWGBL) ;EP ;---> KILL UPPERCASE XREF FOR X. CALLED FROM MUMPS XREFS ON MIXED CASE ;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED. ;---> REQUIRED VARIABLES: BWGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE ;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN. Q:'$D(BWGBL)!('$D(X)) N BWX S BWX=X,X=$$UPPER K @(BWGBL_"""U"",$E(X,1,30),DA)") S X=BWX K BWGBL Q ; CDC(SITE) ;EP ;---> RETURN 1 IF THIS SITE IS EXPORTING DATA TO CDC. Q:'$G(SITE) "" Q:'$D(^BWSITE(SITE,0)) "" Q $P(^BWSITE(SITE,0),U,12) ; AGENCY(SITE) ;EP ;---> RETURN TYPE OF AGENCY ("i"=IHS, "s"=STATE, "v"=VA, ETC.). ;---> REQUIRED VARIABLE: SITE=DUZ(2) ;---> IF SITE NOT PASSED OR PARAMETER NOT SET, IT DEFAULTS TO IHS. Q:'$G(SITE) "i" Q:'$D(^BWSITE(SITE,0)) "i" Q $P(^BWSITE(SITE,0),U,15) ; PNLAB(SITE) ;EP ;---> RETURN TEXT FOR PATIENT NUMBER: "Chart#: " OR " SSN: ". I $$AGENCY(SITE)="i" Q "Chart#: " Q " SSN: " ; PNLB(SITE) ;EP ;---> RETURN UPPERCASE TEXT FOR PATIENT NUMBER, NO COLON/SPACES. I $$AGENCY(SITE)="i" Q "CHART#" Q "SSN" ; CDCID(DFN,SITE) ;EP ;---> GENERATE A UNIQUE PATIENT INDENTIFIER FOR CDC MDE EXPORT. Q:'$$CDC(SITE) "" ;---> QUIT IF ONE ALREADY EXISTS FOR THIS PATIENT. I $D(^BWP(DFN,0)) Q:$P(^(0),U,20)]"" "" N I,Y,Z ;---> TAKE FIRST 4 CHARS OF LAST NAME (EXCHG PUNCTUATION FOR ZEROS). S Y=$E($P($$NAME^BWUTL1(DFN),","),1,4) S Y=$TR(Y," '-.,","00000") F I=1:1:(4-$L(Y)) S Y=Y_0 ;---> TAKE FIRST INITIAL. S Z=$E($P($$NAME^BWUTL1(DFN),",",2)) S:Z="" Z=0 ;---> CONCATENATE IN REVERSE ORDER. S Y=$E(Y,4)_$E(Y,3)_$E(Y,2)_$E(Y)_Z ;---> CONCATENATE FILEMAN DATE OF BIRTH. S Y=Y_$E($$DOB^BWUTL1(DFN),2,7) ;---> CONCATENATE LAST 4 DIGITS OF SSN (OR 9999 IF NO SSN). S I=$E($$SSN^BWUTL1(DFN),6,9) S:'+I I=9999 Q Y_I ; CDCEXP(IEN,SITE) ;EP ;---> RETURNS 1 IF THIS PROCEDURE AT THIS SITE SHOULD BE FLAGGED FOR ;---> EXPORT TO CDC. IEN=IEN IN BW PROCEDURE TYPE FILE #9002086.2. Q:'$G(IEN) "" ;---> QUIT IF SITE NOT EXPORTING MDE'S TO CDC. Q:'$$CDC(SITE) "" Q:'$D(^BWPN(IEN)) "" ;---> QUIT IF PROCEDURE SHOULD NOT BE EXPORTED. Q:'$P(^BWPN(IEN,0),U,13) "" Q 1 ; SLDT2(DATE) ;EP ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YY. ;---> DATE=DATE IN FILEMAN FORMAT. Q:'$G(DATE) "NO DATE" S DATE=$P(DATE,".") Q:$L(DATE)'=7 DATE Q:'$E(DATE,4,5) $E(DATE,1,3)+1700 ;Begin Y2k fix 5/14/1999 IHS/DSD/HJT ;Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3) Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_($E(DATE,1,3)+1700) ;Y2000 ;Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700) ;Y2000 ;End Y2k fix ; ; SLDT1(DATE) ;EP ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YY ;---> PLUS TIME. N Y Q:'$D(DATE) "unknown" S Y=DATE,DATE=$P(DATE,".") Q:'DATE "NO DATE" Q:$L(DATE)'=7 DATE Q:'$E(DATE,4,5) $E(DATE,1,3)+1700 ;Begin Y2k fix ;Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3) Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_($E(DATE,1,3)+1700) ;Y2000 D DD^%DT S:Y["@" Y=" @ "_$P($P(Y,"@",2),":",1,2) ;Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)_Y Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)_Y ;Y2000 ;End Y2k fix ; TXDT(DATE) ;EP ;---> CONVERT FILEMAN INTERNAL DATE TO "TEXT" FORMAT: MMM DD,YYYY. N Y Q:'$D(DATE) "UNKNOWN" S Y=DATE D DD^%DT I Y[", " S Y=$P(Y,", ")_","_$P(Y,", ",2) I Y["@" S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2) Q Y BWUTL7 BWUTL7 ;IHS/ANMC/MWR - UTIL: HEADERS & TRAILERS; [ 05/19/99 2:13 PM ] ;;2.0;WOMEN'S HEALTH;**5**;MAY 16, 1996 ;IHS/CMI/LAB - spacing 4 digit years ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * ;; UTILITY: HEADERS AND TRAILERS. ; S(S) ;EP ;---> RETURN A VALUE OF SPACES EQUAL IN LENGTH TO THE NUMBER S. N I,SP S SP="" F I=1:1:8 S SP=SP_" " Q $E(SP,1,$G(S)) ; TOPHEAD ;EP ;---> CODE TO SET VARIABLES FOR HEADER. N X D NOW^%DTC S BWNOW=$$SLDT1^BWUTL5(%) S BWLINE="" F I=1:1:8 S BWLINE=BWLINE_"----------" S BWPAGE=1 S BWCRT=$S($E(IOST)="C":1,1:0) S BWCONFF="*********************** CONFIDENTIAL PATIENT INFORMATION " S BWCONFF=BWCONFF_"***********************" S BWTIMLN=$E(BWLINE,1,26)_" printed: "_BWNOW_" "_$E(BWLINE,1,27) Q ; ; HEADER1 ;EP ;---> BROWSE/REPORT HEADER: MULTIPLE PATIENTS, MULTIPLE PROCEDURES. ;---> REQUIRED VARIABLES: BWBEGDT,BWCRT,BWENDDT,BWPAGE,BWTITLE,DUZ(2) ;---> OPTIONAL VARIABLE: BWCONF (CONFIDENTIAL), BWSUBH (SUBHEADER). N X W:BWPAGE>1!BWCRT @IOF,! W:$D(BWCONF) BWCONFF,! W:'BWCRT BWTIMLN,! W !,BWTITLE W:'BWCRT ?70,"page: ",BWPAGE W !!,"Case Mgr: " D .I '$D(BWE) W "ALL" Q .I BWE W "ALL" Q .I '$D(BWCMGR) W "UNKNOWN" Q .I BWCMGR="" W "UNKNOWN" Q .I '$D(^VA(200,BWCMGR,0)) W "UNKNOWN" Q .W $P(^VA(200,BWCMGR,0),U) W ?56,"For period: ",$$TXDT^BWUTL5(BWBEGDT) W !,"Facility: ",$$INSTTX^BWUTL6(DUZ(2)) W ?64,"To: ",$$TXDT^BWUTL5(BWENDDT) W ! F I=1:1:80 W "=" I $D(BWSUBH) D @BWSUBH Q ; ; HEADER2 ;EP ;---> PATIENT REPORT HEADER: ONE PATIENT, MULTIPLE PROCEDURES. ;---> REQUIRED VARIABLES: BWBEGDT,BWCRT,BWENDDT,BWPAGE,BWTITLE,DUZ(2) ;---> OPTIONAL VARIABLE: BWCONF (CONFIDENTIAL), BWSUBH (SUBHEADER). N X W:BWPAGE>1!BWCRT @IOF,! W:$D(BWCONF) BWCONFF,! W:'BWCRT BWTIMLN,! W !,BWTITLE W:'BWCRT ?70,"page: ",BWPAGE W !!,"Patient Name: ",BWNAMAGE,?52,$$PNLAB^BWUTL5(DUZ(2)),BWCHRT W !,"Case Manager: ",BWCMGR W ?50,"Facility: ",$E($$INSTTX^BWUTL6(DUZ(2)),1,19) W !,"Cx Tx Need : ",BWCNEED ;W ?52,"Period:" ;---> XDATES ;W ?60,$$SLDT2^BWUTL5(BWBEGDT)," to " ;---> XDATES ;W $$SLDT2^BWUTL5(BWENDDT) ;---> XDATES W !,"PAP Regimen : ",BWPAPRG W !,"Br Tx Need : ",BWBNEED W ! F I=1:1:49 W "=" ;begin Y2K W $S(BWEDC]"":BWEDC_"====",1:"===============================") ;IHS/CMI/LAB - format 4 digit year Y2000 ;end Y2K I $D(BWSUBH) D @BWSUBH Q ; ; HEADER3 ;EP ;---> LAB LOG REPORT HEADER: MULTIPLE PATIENTS, MULTIPLE PROCEDURES. ;---> REQUIRED VARIABLES: BWBEGDT,BWCRT,BWENDDT,BWPAGE,BWTITLE,DUZ(2) ;---> OPTIONAL VARIABLE: BWCONF (CONFIDENTIAL), BWSUBH (SUBHEADER). N X W:BWPAGE>1!BWCRT @IOF,! W:$D(BWCONF) BWCONFF,! W:'BWCRT BWTIMLN,! W !,BWTITLE W:'BWCRT ?70,"page: ",BWPAGE W !!,"Facility: ",$$INSTTX^BWUTL6($S($G(BWFAC):BWFAC,1:DUZ(2))) ;begin Y2K W ?49,"From: ",$$SLDT2^BWUTL5(BWBEGDT) ;IHS/CMI/LAB 53 to 49 Y2000 ;end Y2K W " to ",$$SLDT2^BWUTL5(BWENDDT) W ! F I=1:1:80 W "=" I $D(BWSUBH) D @BWSUBH Q ; ; HEADER4 ;EP ;---> PATIENT REPORT HEADER: ONE PATIENT, ONE PROCEDURE. ;---> REQUIRED VARIABLES: BWBEGDT,BWCRT,BWENDDT,BWPAGE,BWTITLE1,DUZ(2) ;---> OPTIONAL VARIABLE: BWCONF (CONFIDENTIAL), BWSUBH (SUBHEADER). W:BWPAGE>1!BWCRT @IOF,! W BWCONFF W:'BWCRT !,BWTIMLN W !!,BWTITLE1,?70,"page: ",BWPAGE S BWPAGE=BWPAGE+1 HEADER41 ;EP ;---> CALLED BY BWPROC; BYPASSES FORMFEED, TITLE, ETC. W !!,"Patient Name: ",BWNAMAGE,?53,$$PNLAB^BWUTL5(DUZ(2)),BWCHRT W !,"Case Manager: ",BWCMGR W ?50,"Procedure: ",$E(BWPN,1,19) W !,"Cx Tx Need : ",BWCNEED W ?55,"Acc#: ",BWACCN W !,"PAP Regimen : ",BWPAPRG W !,"Br Tx Need : ",BWBNEED W ?61,$S($$DES^BWUTL1(BWDFN):"*DES DAUGHTER*",1:"") W ! F I=1:1:49 W "-" W $S(BWEDC]"":BWEDC_"------",1:"-------------------------------") Q ; ; HEADER5 ;EP ;---> DELINQUENT NEEDS REPORT HEADER: MULTIPLE PATIENTS ;---> REQUIRED VARIABLES: BWBEGDT,BWCRT,BWENDDT,BWPAGE,BWTITLE,DUZ(2) ;---> OPTIONAL VARIABLE: BWCONF (CONFIDENTIAL), BWSUBH (SUBHEADER). N X W:BWPAGE>1!BWCRT @IOF,! W:$D(BWCONF) BWCONFF,! W:'BWCRT BWTIMLN,! W !,BWTITLE W:'BWCRT ?70,"page: ",BWPAGE W !!,"Case Mgr: " D .I '$D(BWE) W "ALL" Q .I BWE W "ALL" Q .I $G(BWCMGR)']"" W "UNKNOWN" Q .I '$D(^VA(200,BWCMGR,0)) W "UNKNOWN" Q .W $P(^VA(200,BWCMGR,0),U) W ?46,"Communit" D .I $D(BWCC("ALL")) W "ies: ALL" Q .N I,N S N=0 F I=0:1 S N=$O(BWCC(N)) Q:'N .I I=1 W "y: ",$E($P(^AUTTCOM($O(BWCC(N)),0),U),1,22) Q .W "ies: ",$E($P(^AUTTCOM($O(BWCC(N)),0),U),1,18),",..." Q W !,"Facility: ",$$INSTTX^BWUTL6(BWFAC) W ?46,"Tx Needs Past Due as of ",$$SLDT2^BWUTL5(BWDDATE) W ! F I=1:1:80 W "=" I $D(BWSUBH) D @BWSUBH Q ; ; HEADER6 ;EP ;---> PROGRAM SNAPSHOT HEADER: JUST TITLE AND FACILITY (NO PATIENTS) ;---> REQUIRED VARIABLES: BWCRT,BWTITLE,DUZ(2) N X W:BWPAGE>1!BWCRT @IOF,! W:'BWCRT !,BWTIMLN,! W !,BWTITLE W:'BWCRT ?70,"page: ",BWPAGE W !!," Note: This report includes all facilities" W " using this database." ;W " Facility: ",$$INSTTX^BWUTL6(DUZ(2)) ;W " (This report is not site specific.)" W ! F I=1:1:80 W "=" Q ; ; HEADER7 ;EP ;---> AUTOLOAD OF PATIENTS HEADER ;---> REQUIRED VARIABLES: BWCRT,BWTITLE,DUZ(2) N X W:BWPAGE>1!BWCRT @IOF,! W:$D(BWCONF) BWCONFF,! W:'BWCRT BWTIMLN,! W !,BWTITLE W:'BWCRT ?70,"page: ",BWPAGE S BWPAGE=BWPAGE+1 W !!,"Facility: ",$$INSTTX^BWUTL6(DUZ(2)) W ?64,"Cutoff Age: ",BWAGE W ! F I=1:1:80 W "=" W !,?3,"NAME",?30,$$PNLB^BWUTL5(DUZ(2)),?45,"DOB",?60,"STATUS" W !,BWLINE Q ; ; HEADER8 ;EP ;---> SCREENING RATES REPORT HEADER: (NO PATIENTS) ;---> REQUIRED VARIABLES: BWCRT,BWTITLE,DUZ(2) N X W:BWPAGE>1!BWCRT @IOF,! W:'BWCRT !,BWTIMLN,! W !,BWTITLE W:'BWCRT ?70,"page: ",BWPAGE W !!?4,"For Age Range: ",$S(BWAGRG=1:"ALL",1:BWAGRG) W ?56,"For period: ",$$SLDT2^BWUTL5(BWBEGDT) W !?4,"Communit" D .I $D(BWCC("ALL")) W "ies: ALL" Q .N I,N S N=0 F I=0:1 S N=$O(BWCC(N)) Q:'N .I I=1 W "y: ",$E($P(^AUTTCOM($O(BWCC(N)),0),U),1,22) Q .W "ies: ",$E($P(^AUTTCOM($O(BWCC(N)),0),U),1,18),",..." Q W ?64,"To: ",$$SLDT2^BWUTL5(BWENDDT) W ! F I=1:1:80 W "=" W !?4,"(Note: This report includes all facilities" W " using this database.)",! ;I $D(BWSUBH) D @BWSUBH Q ; ENDREP(X) ;EP ;---> END A REPORT, DO FORMFEED OR "Press " IF NECESSARY. ;---> REQUIRED VARIABLES: BWCRT=1 IF OUTPUT TO SCREEN ;---> BWPOP=1 IF ESCAPING ;---> OPTIONAL VARIABLE: X=1 IF "End of Report" SHOULD NOT DISPLAY. ; S BWTITLE="----- End of Report -----" I '$G(X)&('BWPOP) D CENTERT^BWUTL5(.BWTITLE) W !,BWTITLE W:'BWCRT @IOF,! I BWCRT&('$D(IO("S")))&('BWPOP) D DIRZ^BWUTL3 W @IOF,! D ^%ZISC Q