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