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

BWUTL8.m

Go to the documentation of this file. 
  1. BWUTL8 ;IHS/ANMC/MWR - UTIL: PATLKUP, SELECT, KILLALL;15-Feb-2003 22:15;PLS
  1.  ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
  1.  ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
  1.  ;;  UTILITY: PATIENT LOOKUP, SELECT FOR REPORT, KILLALL.
  1.  ;
  1. PATLKUP(Y,BWADD,BWCDC,DUZ2,BWPOP) ;EP
  1.  ;---> BW PATIENT LOOKUP.
  1.  ;---> PARAMETERS:
  1.  ;     1 - Y             (RETURNED) PATIENT DFN OR -1 IF FAILED.
  1.  ;     2 - BWADD         (OPTIONAL) EQUALS "ADD" IF ADD CAPABILITY
  1.  ;     3 - BWCDC         (OPTIONAL) EQUALS "NOCDC" IF CDC UNIQUE ID#
  1.  ;                                  SHOULD NOT BE ASKED.
  1.  ;     4 - DUZ2=DUZ(2)   (OPTIONAL) IF NOT SET, WILL=ENVIROMENTAL DUZ(2)
  1.  ;     5 - BWPOP         (RETURNED) BWPOP=1 IF DTOUT OR DUOUT
  1.  ;
  1.  ;---> EXAMPLE: D PATLKUP^BWUTL8(.Y)
  1.  ;              D PATLKUP^BWUTL8(.Y,"ADD") - MAY ADD PATIENT TO WH.
  1.  ;
  1.  N DFN,DIC,X
  1. PATLKUP1 ;---> RETURN HERE IF LOOKUP FAILED FOR SEX OR AGE.
  1.  ;---> SET VARIABLES: Y=DFN,BWPOP=1 FOR QUIT.
  1.  S BWPOP=0 D SETVARS^BWUTL5
  1.  S:$G(DUZ2)]"" DUZ(2)=DUZ2
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ"
  1.  S DIC("S")="I $P(^DPT(Y,0),U,2)=""F"""
  1.  D ^DIC
  1.  Q:$D(DUOUT)!($D(DTOUT))
  1.  ;
  1.  ;---> IF LOOKUP FAILS, AND IF CDC EXPORT SITE PARAMETER=YES,
  1.  ;---> TRY LOOKUP ON CDC UNIQUE ID#.
  1.  I Y<0,$$CDC^BWUTL5(DUZ(2)),$G(BWCDC)'="NOCDC" D UNIQUE(.Y)
  1.  ;
  1.  Q:Y<0
  1.  S (DFN,Y)=+Y
  1.  ;---> IF PATIENT ALREADY EXISTS IN BW PATIENT FILE, QUIT.
  1.  Q:$D(^BWP(DFN,0))
  1.  ;
  1.  ;---> IF PATIENT IS NOT FEMALE, PROMPT USER.
  1.  I '$$SEX^BWUTL1(DFN) D  G PATLKUP1
  1.  .W !!?3,$$NAME^BWUTL1(DFN)," is not female." D DIRZ^BWUTL3
  1.  ;
  1.  ;---> QUIT IF NO ADD ("LAYGO") CAPABILITY.
  1.  I $G(BWADD)'="ADD" D  G PATLKUP1
  1.  .W !!?3,$$NAME^BWUTL1(DFN)
  1.  .W " is not currently in the Women's Health database." D DIRZ^BWUTL3
  1.  ;
  1.  ;---> ASK TO ADD AS A NEW PATIENT.
  1.  W !!?3,$$NAME^BWUTL1(DFN)
  1.  ;---> IF PATIENT IS UNDER 12 YEARS, PROMPT USER.
  1.  W:+$$AGE^BWUTL1(DFN)<12 " is under 12 years of age,",!?3,"and she"
  1.  W " is not currently in the Women's Health database."
  1.  W !?3,"Do you wish to add her to the Women's Health Database?"
  1.  S DIR("?",1)="     Enter YES to ADD this patient to the Women's Health"
  1.  S DIR("?",1)=DIR("?",1)_" database."
  1.  S DIR("?")="     Enter NO to quit without adding her to the database."
  1.  S DIR(0)="Y",DIR("A")="   Enter Yes or No"
  1.  D ^DIR W !
  1.  I $D(DIRUT) S Y=-1 Q
  1.  G:Y=0 PATLKUP1
  1.  D AUTOADD^BWPATE(DFN,DUZ(2),.Y,1)
  1.  Q
  1.  ;
  1. UNIQUE(Y) ;EP
  1.  ;---> TRY PATIENT LOOKUP ON CDC UNIQUE ID#.
  1.  ;---> PARAMETERS:
  1.  ;     1 - Y             (RETURNED) PATIENT DFN OR -1 IF FAILED.
  1.  ;
  1.  N D,DIC,DIR
  1.  W !!?3,"Do you wish to search for a patient by her CDC Unique ID#?"
  1.  S DIR("?",1)="     Enter YES to search for a patient by entering her"
  1.  S DIR("?",1)=DIR("?",1)_" CDC Unique ID#"
  1.  S DIR("?",2)="     as reported by the MDE Edit Program."
  1.  S DIR("?")="     Enter NO to quit without searching by CDC Unique ID#."
  1.  S DIR(0)="Y",DIR("A")="   Enter Yes or No",DIR("B")="NO"
  1.  D ^DIR W !
  1.  I $D(DIRUT) S Y=-1 Q
  1.  I Y=0 S Y=-1 Q
  1.  S DIC="^BWP(",DIC(0)="QEA",D="CDC"
  1.  D IX^DIC S Y=+Y
  1.  Q
  1.  ;
  1.  ;
  1. KGBL(GBL) ;EP
  1.  ;---> KILL A GLOBAL.  GBL SHOULD INCLUDE THE LEADING "^".
  1.  S:GBL["(" GBL=$P(GBL,"(")
  1.  F  S GBL=$Q(@GBL) Q:GBL=""  K @GBL
  1.  Q
  1.  ;
  1. ZGBL(GBL) ;EP
  1.  ;---> ZERO OUT (DELETE ALL DATA) IN A FILEMAN FILE.
  1.  ;---> GBL SHOULD INCLUDE THE LEADING "^".
  1.  N N,X
  1.  S:GBL["(" GBL=$P(GBL,"(")
  1.  Q:'$D(@(GBL_"(0)"))
  1.  S N=0,X=$P(@(GBL_"(0)"),U,1,2)
  1.  F  S N=$O(@(GBL_"("""_N_""")")) Q:N=""  K @(GBL_"("""_N_""")")
  1.  S @(GBL_"(0)")=X
  1.  Q
  1.  ;
  1. KILLALL ;EP
  1.  ;---> CLEAN UP VARIABLES.
  1.  ;---> MSM
  1.  ;S X="BW" F  S X=$O(@X) Q:$E(X,1,2)'="BW"  K @X
  1.  ;S X="DI" F  S X=$O(@X) Q:$E(X,1,2)'="BW"  K @X
  1.  ;---> DSM
  1.  ;S X="BW" F  S X=$ZSORT(@X) Q:$E(X,1,2)'="BW"  K @X
  1.  ;S X="DI" F  S X=$ZSORT(@X) Q:$E(X,1,2)'="BW"  K @X
  1.  ;
  1.  ;---> REPLACE KILLS BELOW WITH $O COMMANDS ABOVE WHEN AVAILABLE.
  1.  K BW,BW0,BW1,BW1DX,BW2,BW2DX,BWA,BWABBV,BWABBVS,BWACC
  1.  K BWACCN,BWACCP,BWADD,BWAGE,BWAGENCY,BWAGRG,BWAGRP,BWAR,BWAREA
  1.  K BWARR,BWARR1,BWASKTIM,BWATT,BWB,BWBDF,BWBEGDF,BWBEGDT
  1.  K BWBEGDT1,BWBNEED,BWC,BWC0,BWCAPT,BWCBEDA,BWCC,BWCDC,BWCDCV,BWCHAGE
  1.  K BWCHG,BWCHRT,BWCHSSN,BWCMGR,BWCMGR1,BWCNEED,BWCODE,BWCOLPS,BWCONF
  1.  K BWCONFF,BWCOUNT,BWCRT,BWCUR,BWD,BWDA,BWDATE,BWDATE1,BWDD,BWDDATE
  1.  K BWDEF,BWDFLT,BWDFN,BWDIAG,BWDR,BWDT,BWDUZ0,BWDUZ2,BWDX
  1.  K BWE,BWEDC,BWEDCL,BWEDF,BWENDDF,BWENDDT,BWENDDT1,BWENDSAM,BWENDT
  1.  K BWERR,BWERROR,BWERRORS,BWFAC,BWFACIL,BWFILE,BWFLNM,BWGBL
  1.  K BWGBLN,BWHEADER,BWHCF,BWHFS,BWHLOC,BWHRCN,BWI,BWICD,BWIEN,BWION
  1.  K BWITEM,BWITEMS,BWKDT,BWLDAT,BWLFRT,BWLINE,BWLINL,BWLOC,BWLOGO
  1.  K BWLOOP,BWLPRG,BWM,BWMABN,BWMAM,BWMAMDT,BWMATCH,BWMENUT,BWMES,BWN
  1.  K BWNAMAGE,BWNAME,BWNEW,BWNN,BWNODE,BWNOFAC,BWNOFOL,BWNOMAT,BWNORM
  1.  K BWNOW,BWOFAC,BWOLD,BWOLD2,BWOUT,BWPABN,BWPAGE,BWPAP,BWPAPDA,BWPAPDT
  1.  K BWPAPRG,BWPAPRG1,BWPAPS,BWPATH,BWPATS,BWPC,BWPCCN,BWPCCP,BWPCD,BWPCDL
  1.  K BWPCDN,BWPCDS,BWPCDT,BWPDATE,BWPN,BWPNAME,BWPOP,BWPOP1,BWPOST,BWPPAP
  1.  K BWPRE,BWPREG,BWPRIO,BWPRMPT,BWPRMT,BWPRMT1,BWPRMT2,BWPRMTQ,BWPROF
  1.  K BWPROV,BWPRPCD,BWPRV,BWPSTAT,BWPTITL,BWPURP,BWPUSER,BWQUE,BWQUIT
  1.  K BWRCVDT,BWRES,BWRESN,BWRTN,BWS,BWSAME,BWSCRN,BWSITE,BWSL,BWSPEC
  1.  K BWSPTX,BWSS,BWSSN,BWSTART,BWSTAT,BWSTTDT,BWSUB,BWSUBH,BWUSER,BWSV
  1.  K BWTAB,BWTEST,BWTIME,BWTIMLN,BWTITLE,BWTITLE1,BWTITLE2,BWTMP
  1.  K BWTTAB,BWTYPE,BWUNL,BWVER,BWVFIL,BWVGBL,BWX,BWX0,BWX1,BWX2,BWX3
  1.  K BWX4,BWX5,BWX6,BWX7,BWX8,BWX9,BWXPORT,BWXREF,BWY,BWYY
  1.  K COL,COLLEN,LEN,NN,NODE,V,POP
  1.  ;
  1.  ;---> ADDED MANUALLY.
  1.  K BWMDAT,BWMGR,BWPDAT,BWTOT
  1.  K ^TMP("BW",$J)
  1.  ;
  1.  ;---> FILEMAN KILLS.
  1.  D DKILLS^BWFMAN
  1.  K X,Y,Z,ZTRTN,ZTSAVE
  1.  Q