118 lines
4.5 KiB
Mathematica
118 lines
4.5 KiB
Mathematica
WVUTL8 ;HCIOFO/FT,JR IHS/ANMC/MWR - UTIL: PATLKUP, SELECT, KILLALL; ;12/15/98 16:43
|
|
;;1.0;WOMEN'S HEALTH;**3**;Sep 30, 1998
|
|
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
|
|
;; UTILITY: PATIENT LOOKUP, SELECT FOR REPORT, KILLALL.
|
|
;
|
|
PATLKUP(Y,WVADD,DUZ2,WVPOP) ;EP
|
|
;---> WV PATIENT LOOKUP.
|
|
;---> PARAMETERS:
|
|
; 1 - Y (RETURNED) PATIENT DFN OR -1 IF FAILED.
|
|
; 2 - WVADD (OPTIONAL) EQUALS "ADD" IF ADD CAPABILITY
|
|
; 3 - DUZ2=DUZ(2) (OPTIONAL) IF NOT SET, WILL=ENVIROMENTAL DUZ(2)
|
|
; 4 - WVPOP (RETURNED) WVPOP=1 IF DTOUT OR DUOUT
|
|
;
|
|
;---> EXAMPLE: D PATLKUP^WVUTL8(.Y)
|
|
; D PATLKUP^WVUTL8(.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,WVPOP=1 FOR QUIT.
|
|
S WVPOP=0 D SETVARS^WVUTL5
|
|
S:$G(DUZ2)]"" DUZ(2)=DUZ2
|
|
S DIC="^DPT(",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,2)=""F"""
|
|
D ^DIC
|
|
Q:$D(DUOUT)!($D(DTOUT))
|
|
Q:Y<0
|
|
S (DFN,Y)=+Y
|
|
;---> IF PATIENT ALREADY EXISTS IN WV PATIENT FILE, QUIT.
|
|
Q:$D(^WV(790,DFN,0))
|
|
;
|
|
;---> IF PATIENT IS NOT FEMALE, PROMPT USER.
|
|
I '$$SEX^WVUTL1(DFN) D G PATLKUP1
|
|
.W !!?3,$$NAME^WVUTL1(DFN)," is not female." D DIRZ^WVUTL3
|
|
;
|
|
;---> QUIT IF NO ADD ("LAYGO") CAPABILITY.
|
|
I $G(WVADD)'="ADD" D G PATLKUP1
|
|
.W !!?3,$$NAME^WVUTL1(DFN)
|
|
.W " is not currently in the Women's Health database." D DIRZ^WVUTL3
|
|
;
|
|
;---> ASK TO ADD AS A NEW PATIENT.
|
|
W !!?3,$$NAME^WVUTL1(DFN)
|
|
W " ("_$$AGE^WVUTL1(DFN)_")" ;show patient's age
|
|
W !?3,"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^WVPATE(DFN,DUZ(2),.Y,1)
|
|
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="WV" F S X=$O(@X) Q:$E(X,1,2)'="WV" K @X
|
|
;S X="DI" F S X=$O(@X) Q:$E(X,1,2)'="WV" K @X
|
|
;---> DSM
|
|
;S X="WV" F S X=$ZSORT(@X) Q:$E(X,1,2)'="WV" K @X
|
|
;S X="DI" F S X=$ZSORT(@X) Q:$E(X,1,2)'="WV" K @X
|
|
;
|
|
;---> REPLACE KILLS BELOW WITH $O COMMANDS ABOVE WHEN AVAILABLE.
|
|
K WV,WV0,WV1,WV1DX,WV2,WV2DX,WVA,WVABBV,WVABBVS,WVACC
|
|
K WVACCN,WVACCP,WVADD,WVAGE,WVAGENCY,WVAGRG,WVAGRP,WVAR,WVAREA
|
|
K WVARR,WVARR1,WVASKTIM,WVATT,WVB,WVBDF,WVBEGDF,WVBEGDT
|
|
K WVBEGDT1,WVBNEED,WVC,WVC0,WVCAPT,WVCBEDA,WVCC,WVCDC,WVCDCV,WVCHAGE
|
|
K WVCHG,WVCHRT,WVCHSSN,WVCMGR,WVCMGR1,WVCNEED,WVCODE,WVCOLPS,WVCONF
|
|
K WVCONFF,WVCOUNT,WVCRT,WVCUR,WVD,WVDA,WVDATE,WVDATE1,WVDD,WVDDATE
|
|
K WVDEF,WVDFLT,WVDFN,WVDIAG,WVDR,WVDT,WVDUZ0,WVDUZ2,WVDX
|
|
K WVE,WVEDC,WVEDCL,WVEDF,WVENDDF,WVENDDT,WVENDDT1,WVENDSAM,WVENDT
|
|
K WVERR,WVERROR,WVERRORS,WVFAC,WVFACIL,WVFILE,WVFLNM,WVGBL
|
|
K WVGBLN,WVHEADER,WVHCF,WVHFS,WVHLOC,WVHRCN,WVI,WVICD,WVIEN,WVION
|
|
K WVITEM,WVITEMS,WVKDT,WVLDAT,WVLFRT,WVLINE,WVLINL,WVLOC,WVLOGO
|
|
K WVLOOP,WVLPRG,WVM,WVMABN,WVMAM,WVMAMDT,WVMATCH,WVMENUT,WVMES,WVN
|
|
K WVNAMAGE,WVNAME,WVNEW,WVNN,WVNODE,WVNOFAC,WVNOFOL,WVNOMAT,WVNORM
|
|
K WVNOW,WVOFAC,WVOLD,WVOLD2,WVOUT,WVPABN,WVPAGE,WVPAP,WVPAPDA,WVPAPDT
|
|
K WVPAPRG,WVPAPRG1,WVPAPS,WVPATH,WVPATS,WVPC,WVPCCN,WVPCCP,WVPCD,WVPCDL
|
|
K WVPCDN,WVPCDS,WVPCDT,WVPDATE,WVPN,WVPNAME,WVPOP,WVPOP1,WVPOST,WVPPAP
|
|
K WVPRE,WVPREG,WVPRIO,WVPRMPT,WVPRMT,WVPRMT1,WVPRMT2,WVPRMTQ,WVPROF
|
|
K WVPROV,WVPRPCD,WVPRV,WVPSTAT,WVPTITL,WVPURP,WVPUSER,WVQUE,WVQUIT
|
|
K WVRCVDT,WVRES,WVRESN,WVRTN,WVS,WVSAME,WVSCRN,WVSITE,WVSL,WVSPEC
|
|
K WVSPTX,WVSS,WVSSN,WVSTART,WVSTAT,WVSTTDT,WVSUB,WVSUBH,WVUSER,WVSV
|
|
K WVTAB,WVTEST,WVTIME,WVTIMLN,WVTITLE,WVTITLE1,WVTITLE2,WVTMP
|
|
K WVTTAB,WVTYPE,WVUNL,WVVER,WVVFIL,WVVGBL,WVX,WVX0,WVX1,WVX2,WVX3
|
|
K WVX4,WVX5,WVX6,WVX7,WVX8,WVX9,WVXPORT,WVXREF,WVY,WVYY
|
|
K COL,COLLEN,LEN,NN,NODE,V,POP,WVJPCP,WVJDT,WVJDTO,WVJNDA,WVJTOY
|
|
K WVTOY,WVJPAPR,WVJST,WVPR,CN,WVCNT,WVJ,WVJAGER,WVJHDR,WVJTYP
|
|
K WVDTIEN,WVJX,WVJDR,WVCN,WVJRNOW,WVBALL,WVALL,WVBV,WVCALL,WVCIVCN
|
|
K WVCNALL,WVCV,WVET,WVETCN,WVMALL,WVMV,WVNALL,WVST,WVVALL,WVARJ
|
|
K WVJBFAC,WVJCFAC
|
|
;
|
|
;---> ADDED MANUALLY.
|
|
K WVMDAT,WVMGR,WVPDAT,WVTOT
|
|
K ^TMP("WV",$J)
|
|
;
|
|
;---> FILEMAN KILLS.
|
|
D DKILLS^WVFMAN
|
|
K X,Y,Z,ZTRTN,ZTSAVE
|
|
Q
|