WVUTL3 ;HCIOFO/FT,JR - UTIL: DATE, LOCK, DIR, PATVARS;08/08/2017 08:47
;;1.0;WOMEN'S HEALTH;**24**;Sep 30, 1998;Build 582
;* IHS/ANMC/MWR
;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
; UTILITY: ASK DATE RANGE, LOCKS, DIR PROMPTS,
; STORE PAP REGIMEN, PCDVARS & PATVARS.
;
OUT ;EP
;---> CALLED AFTER ERROR MESSAGES ARE DISPLAYED.
S WVPOP=1 D DIRZ
Q
;
ASKDATES(WVB,WVE,WVPOP,WVBDF,WVEDF,WVSAME,WVTIME) ;EP
;---> ASK DATE RANGE.
;---> PARAMETERS:
; 1 - WVB (RETURNED) BEGIN DATE, FILEMAN FORMAT
; 2 - WVE (RETURNED) END DATE, FILEMAN FORMAT
; 3 - WVPOP (RETURNED) WVPOP=1 IF QUIT,FAIL,DTOUT,DUOUT
; 4 - WVBDF (OPTIONAL) BEGIN DATE DEFAULT, FILEMAN FORMAT
; 5 - WVEDF (OPTIONAL) END DATE DEFAULT, FILEMAN FORMAT
; 6 - WVSAME (OPTIONAL) FORCE END DATE DEFAULT=BEGIN DATE
; 7 - WVTIME (OPTIONAL) ASK TIMES
;
;---> EXAMPLE:
; D ASKDATES^WVUTL3(.WVBEGDT,.WVENDDT,.WVPOP,"T-365","T")
;
S WVPOP=0 N %DT,Y
W !!," *** Date Range Selection ***"
S %DT="APEX"_$S($D(WVTIME):"T",1:"")
S %DT("A")=" Begin with DATE: "
I $G(WVBDF)]"" S Y=WVBDF D DD^%DT S %DT("B")=Y
D ^%DT K %DT
I Y<0 S WVPOP=1 Q
S (%DT(0),WVB)=Y K %DT("B")
S %DT="APEX"_$S($D(WVTIME):"T",1:"")
S %DT("A")=" End with DATE: "
I $G(WVEDF)]"" S Y=WVEDF D DD^%DT S %DT("B")=Y
I $D(WVSAME) S Y=WVB D DD^%DT S %DT("B")=Y
D ^%DT K %DT
I Y<0 S WVPOP=1 Q
S WVE=Y
Q
;
LOCKED ;EP
Q:$D(ZTQUEUED) ;quit if called from a background (tasked) job.
W !?5,"Another user is editing this entry. Please, try again later."
D DIRZ
Q
;
LOCKEDE ;EP
;---> LOCKED PREGNANCY LOG ENTRY.
W !?5,"Another user is editing the Pregnancy Log for this patient"
W !?5,"for this day. Please, try again later."
D DIRZ
Q
;
LOCKEDP ;EP
;---> LOCKED PAP Regimen Log ENTRY.
W !?5,"Another user is editing the PAP Regimen Log for this patient"
W !?5,"for this day. Please, try again later."
D DIRZ
Q
;
LOCKEDL ;EP
;---> LOCKED LACTATION LOG ENTRY.
W !?5,"Another user is editing the Lactation Log for this patient"
W !?5,"for this day. Please, try again later."
D DIRZ
Q
;
LOCKEDM ;EP
;---> LOCKED MENSTRUAL CYCLE LOG ENTRY.
W !?5,"Another user is editing the Menstrual Cycle Log for this patient"
W !?5,"for this day. Please, try again later."
D DIRZ
Q
;
DIRZ ;EP
;---> PRESS RETURN TO CONTINUE.
N DIR,DIRUT,X,Y,DTOUT,DUOUT,DIROUT
I $D(WVPRMT) S DIR("A")=WVPRMT
I $D(WVPRMT1) S DIR("A",1)=WVPRMT1
I $D(WVPRMT2) S DIR("A",2)=WVPRMT2
I $D(WVPRMTQ) S DIR("?")=WVPRMTQ
S DIR(0)="E" W ! D ^DIR W !
S WVPOP=$S($D(DIRUT):1,Y<1:1,1:0)
Q
;
DIRPRMT ;EP
;---> REQUIRED VARIABLE: WVPROMPT,M (M=LAST SELECTION# DISPLAYED)
;---> OPTIONAL VARIABLE: WVCODE (EXECUTABLE CODE ACTING ON INPUT X)
;---> WVD=1 IF RANGE OF SELECTION NUMBERS SHOULD BE DISPLAYED.
N DIR,DIRUT,Y,X,DTOUT,DUOUT,DIROUT
W ! S:'$D(WVD) WVD=0
S DIR(0)="LO^"_$S(WVD:":"_M,1:"1:"_M)
I $D(WVPRMT) S DIR("A")=WVPRMT
I $D(WVPRMT1) S DIR("A",1)=WVPRMT1
I $D(WVPRMT2) S DIR("A",2)=WVPRMT2
I $D(WVPRMTQ) S DIR("?")=WVPRMTQ
I $D(WVCODE) S DIR(0)=DIR(0)_U_WVCODE
D ^DIR
S:$D(DTOUT)!($D(DUOUT)) WVPOP=1
Q
;
STORPAP ;EP
;---> STORE PAP REGIMEN, START DATE AND DATE ENTERED; CALLED BY
;---> MUMPS XREF ON FIELDS #.16 AND #.17 IN WV PATIENT FILE.
;---> REQUIRED VARIABLES: WVLDAT=BEGIN DATE, WVLPRG=PAP REGIMEN, WVDFN.
Q:'$D(WVLDAT)!('$D(WVLPRG))!('$D(WVDFN))
Q:'WVLDAT!('WVLPRG)!('WVDFN)
N DA,DIC,DIE,DLAYGO,DR,N,WVQUIT,X,DG
D SETVARS^WVUTL5
S WVQUIT=0,DLAYGO=790
S DIE="^WV(790.04,"
S DR=".01////"_WVLDAT_";.03////"_WVLPRG
S N=0
F S N=$O(^WV(790.04,"C",WVDFN,N)) Q:'N!(WVQUIT) D
.I $D(^WV(790.04,"B",WVLDAT,N)) S DA=N D
..L +^WV(790.04,DA):0 I '$T D LOCKEDP S WVQUIT=1 Q
..D DIE^WVFMAN(790.04,DR,DA,.WVPOP) L -^WV(790.04,DA) S WVQUIT=1
Q:WVQUIT
;
K DD,DO
S DIC="^WV(790.04,",DIC(0)="L",X=WVLDAT,DLAYGO=790
S DIC("DR")=".02////"_WVDFN_";.03////"_WVLPRG
D FILE^DICN
Q
;
PCDVARS(DA,TEXTDATE,COLP) ;EP
;---> SET VARIABLES FOR PROCEDURE DATA FOR HEADERS.
;---> REQUIRED VARIABLES: DA=IEN OF PROCEDURE IN PROC FILE 790.1.
;---> TEXTDATE=1 PROVIDE DATE IN TEXT FORMAT,
;---> OTHERWISE IN NUMERIC FORMAT (1/1/95)
;---> COLP=1 TO SET WVC0=ASSOC'D COLP IF THIS IS
;---> A PAP.
;---> Y=ZERO NODE OF PROCEDURE, WVACCN=ACCESSION#,
;---> WVPCDN=IEN OF PROCEDURE TYPE,
;---> WVRESN=IEN OF RESULT/DIAG,WVRES=TEXT OF RESULT/DIAG
;---> WVPN=PROCEDURE TYPE, WVDFN=DFN OF PATIENT.
;---> WV0=ZERO NODE OF THIS PROCEDURE, WV2=TWO NODE.
;---> WVPAP=1=PCD IS A PAP, WVMAM=1=PCD IS A SCREENING MAM.
;---> WVC0=ZERO NODE OF ASSOCIATED COLP (IF THIS IS A PAP).
;
N X,Y S (WV0,Y)=^WV(790.1,DA,0),WVC0=""
S WV2=$S($D(^WV(790.1,DA,2)):^(2),1:"")
S COLP=$G(COLP) S:COLP WVC0=$$COLP0^WVUTL4(DA)
S TEXTDATE=$G(TEXTDATE)
S WVACCN=$$ACC^WVUTL1(DA)
S WVPCDN=$P(Y,U,4)
S X=DA,WVPN=$$PROC^WVUTL1A
S WVRESN=$P(Y,U,5),WVRES=$$DIAG^WVUTL4(WVRESN)
S X=$P(Y,U,7),WVPROV=$$PROV^WVUTL6
S WVDFN=$P(Y,U,2) D PATVARS(WVDFN,TEXTDATE)
S (WVMAM,WVPAP)=0
S:WVPCDN=28 WVMAM=1 S:WVPCDN=1 WVPAP=1
Q
;
PATVARS(DFN,TEXTDATE) ;EP
;---> SET VARIABLES FO PATIENT DATA FOR HEADERS.
;---> REQUIRED VARIABLES: WVDFN=IEN OF PATIENT
;---> YIELDS: WVNAME=PATIENT NAME, WVCHRT=SSN#
;---> WVCMGR=CASE MANAGER, WVCNEED=CX TX NEED,
;---> WVPAPRG=PAP REGIMEN, WVBNEED=BR TX NEED, WVEDC=EDC.
S TEXTDATE=$G(TEXTDATE)
S WVNAME=$$NAME^WVUTL1(DFN)
S WVNAMAGE=$$NAMAGE^WVUTL1(DFN)
S WVCHRT=$$SSN^WVUTL1(DFN)
S WVCMGR=$$CMGR^WVUTL1(DFN)
S WVCNEED=$$CNEED^WVUTL1(DFN,TEXTDATE)
S WVPAPRG=$$PAPRG^WVUTL1(DFN,TEXTDATE)
S WVBNEED=$$BNEED^WVUTL1(DFN,TEXTDATE)
S WVEDC=$$EDC^WVUTL1(DFN)
Q
;
SETFMVAR ;SAVE FILEMAN VARIABLES FOR RESTORATION
S:$D(DI) WVDI=DI
S:$D(DQ) WVDQ=DQ
S:$D(DC) WVDC=DC
S:$D(DM) WVDM=DM
S:$D(DK) WVDK=DK
S:$D(DP) WVDP=DP
S:$D(DL) WVDL=DL
S:$D(DIU) WVDIU=DIU
Q
;
GETFMVAR ;RESTORE FILEMAN VARIABLS
S:$D(WVDI) DI=WVDI
S:$D(WVDQ) DQ=WVDQ
S:$D(WVDC) DC=WVDC
S:$D(WVDM) DM=WVDM
S:$D(WVDK) DK=WVDK
S:$D(WVDP) DP=WVDP
S:$D(WVDL) DL=WVDL
S:$D(WVDIU) DIU=WVDIU
K WVDI,WVDQ,WVDC,WVDM,WVDK,WVDP,WVDL,WVDIU
Q
;
FMADD(WVDAYS,WVPDT) ; This function adds the date offset indicated to the
; specified date to calculate a future date.
; Input: WVDAYS - date offset (e.g., 90D, 6M, 1Y) [required]
; WVPDT - date of procedure [optional]
; default is today
; Output: FileMan date. Returns null if a FileMan date could not
; be calculated.
;
Q:'WVDAYS ""
S:'$G(WVPDT) WVPDT=DT
N WVARRAY,WVERR,WVLOOP,WVMONTH,WVNEWDT,WVYEAR,X
S WVNEWDT=""
S X=WVDAYS
D DMYCHECK^WVPURP ;check offset value
S WVDAYS=X
I X=-1 Q WVNEWDT
I WVDAYS["D" D
.S WVARRAY=$$FMADD^XLFDT(WVPDT,+WVDAYS)
.S:WVARRAY>0 WVNEWDT=WVARRAY
.Q
I WVDAYS["M" D
.S WVMONTH=+$E(WVPDT,4,5),WVYEAR=0
.F WVLOOP=1:1:+WVDAYS D
..S WVMONTH=WVMONTH+1
..I WVMONTH>12 S WVMONTH=1,WVYEAR=WVYEAR+1
..Q
.S WVNEWDT=WVPDT+(+WVYEAR*10000)
.S WVMONTH=$S(WVMONTH<10:"0"_WVMONTH,1:WVMONTH)
.S WVNEWDT=$E(WVNEWDT,1,3)_WVMONTH_$E(WVNEWDT,6,7)
.Q
I WVDAYS["Y" S WVNEWDT=WVPDT+(+WVDAYS*10000)
Q WVNEWDT
;
PSTATCHG(OLDVAL,NEWVAL,DA) ;UPDATE RELATED FIELDS WHEN PREGNANCY STATUS
; FIELD VALUE CHANGES ('AF' CROSS-REFERENCE
; IN PREGNANCY STATUSES SUB-FILE #790.05)
; INPUT: OLDVAL - The original value in internal format
; NEWVAL - The new value in internal format
; DA - Reference to a FileMan DA array containing the IEN values
; that identify the entry the user is modifying
N DIK,DIH,DIG,DIV,DIW
I ($G(NEWVAL)=1)&(($G(OLDVAL)=0)!($G(OLDVAL)=2)) D
.S $P(^WV(790,DA(1),4,DA,2),U,4)="",$P(^WV(790,DA(1),4,DA,4),U,4)=""
.S $P(^WV(790,DA(1),4,DA,4),U,5)=""
.S DIK="^WV(790,"_DA(1)_",4,"
.F DIK(1)=24,44,45 D EN^DIK
.D METHOD^WVTDALRT(DA(1),.DA,0)
I ((+$G(NEWVAL)=0)!($G(NEWVAL)=2)!($G(NEWVAL)=3))&($G(OLDVAL)=1) D
.S $P(^WV(790,DA(1),4,DA,4),U)="",$P(^WV(790,DA(1),4,DA,4),U,2)=""
.S $P(^WV(790,DA(1),4,DA,4),U,3)=""
.S DIK="^WV(790,"_DA(1)_",4,"
.F DIK(1)=41,42,43 D EN^DIK
I ($G(NEWVAL)=3)&(($G(OLDVAL)=0)!($G(OLDVAL)=2)) D
.S $P(^WV(790,DA(1),4,DA,2),U,4)=""
.S DIK="^WV(790,"_DA(1)_",4,",DIK(1)=24 D EN^DIK
Q
EIECHG(OLDVAL,NEWVAL,DA,NODE) ;UPDATE RELATED FIELDS WHEN ENTERED IN ERROR FIELD
; VALUE CHANGES ('AN' CROSS-REFERENCE IN PREGNANCY
; STATUSES SUB-FILE #790.05 AND 'AG' CROSS-REFERENCE IN
; LACTATION STATUSES SUB-FILE #790.16)
; INPUT: OLDVAL - The original value in internal format
; NEWVAL - The new value in internal format
; DA - Reference to a FileMan DA array containing the IEN values
; that identify the entry the user is modifying
; NODE - THE SUBSCRIPT THAT CONTAINS THE DATA
N DIK,STAT,DIH,DIG,DIV,DIW
I $G(OLDVAL)="",$G(NEWVAL)=1 D
.S $P(^WV(790,DA(1),NODE,DA,0),U,7)=DUZ,$P(^(0),U,8)=$$NOW^XLFDT
.S DIK="^WV(790,"_DA(1)_","_NODE_","
.F DIK(1)=4,5 D EN2^DIK
.S $P(^WV(790,DA(1),NODE,DA,0),U,4)=""
.S $P(^WV(790,DA(1),NODE,DA,0),U,5)=""
.S STAT("CSTAT")=$P($G(^WV(790,DA(1),NODE,DA,2)),U),STAT("CDATE")=$P($G(^WV(790,DA(1),NODE,DA,0)),U)
.S STAT("PDATE")=$O(^WV(790,DA(1),NODE,"B",STAT("CDATE")),-1)
.I STAT("PDATE")>0 D
..S STAT("PIEN")=$O(^WV(790,DA(1),NODE,"B",STAT("PDATE"),0)),STAT("PSTAT")=$P($G(^WV(790,DA(1),NODE,STAT("PIEN"),2)),U)
.I STAT("CSTAT")=1,$G(STAT("PSTAT"))'=1 D @($S(NODE=4:"PREG",NODE=5:"LACT",1:"")_U_"WVTDALRT(DA(1),0)")
.I NODE=4 D
..S STAT("CTRY")=$P($G(^WV(790,DA(1),NODE,DA,2)),U,4)
..S STAT("CLIKE")=$$COBP^WVUTL11(DA(1),DA)
..I $G(STAT("PIEN"))>0 D
...S STAT("PTRY")=$P($G(^WV(790,DA(1),NODE,STAT("PIEN"),2)),U,4)
...S STAT("PLIKE")=$$COBP^WVUTL11(DA(1),STAT("PIEN"))
..I STAT("CTRY")=1,$G(STAT("PTRY"))'=1 D TRY^WVTDALRT(DA(1),0)
..I STAT("CLIKE")<$G(STAT("PLIKE"))!(+$G(STAT("PLIKE"))=0&(STAT("CLIKE")=1)) D DELALERT^WVTDALRT($$MTEXT^WVTDALRT,DA(1))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVUTL3 10221 printed Apr 09, 2024@21:50 Page 2
WVUTL3 ;HCIOFO/FT,JR - UTIL: DATE, LOCK, DIR, PATVARS;08/08/2017 08:47
+1 ;;1.0;WOMEN'S HEALTH;**24**;Sep 30, 1998;Build 582
+2 ;* IHS/ANMC/MWR
+3 ;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ; UTILITY: ASK DATE RANGE, LOCKS, DIR PROMPTS,
+5 ; STORE PAP REGIMEN, PCDVARS & PATVARS.
+6 ;
OUT ;EP
+1 ;---> CALLED AFTER ERROR MESSAGES ARE DISPLAYED.
+2 SET WVPOP=1
DO DIRZ
+3 QUIT
+4 ;
ASKDATES(WVB,WVE,WVPOP,WVBDF,WVEDF,WVSAME,WVTIME) ;EP
+1 ;---> ASK DATE RANGE.
+2 ;---> PARAMETERS:
+3 ; 1 - WVB (RETURNED) BEGIN DATE, FILEMAN FORMAT
+4 ; 2 - WVE (RETURNED) END DATE, FILEMAN FORMAT
+5 ; 3 - WVPOP (RETURNED) WVPOP=1 IF QUIT,FAIL,DTOUT,DUOUT
+6 ; 4 - WVBDF (OPTIONAL) BEGIN DATE DEFAULT, FILEMAN FORMAT
+7 ; 5 - WVEDF (OPTIONAL) END DATE DEFAULT, FILEMAN FORMAT
+8 ; 6 - WVSAME (OPTIONAL) FORCE END DATE DEFAULT=BEGIN DATE
+9 ; 7 - WVTIME (OPTIONAL) ASK TIMES
+10 ;
+11 ;---> EXAMPLE:
+12 ; D ASKDATES^WVUTL3(.WVBEGDT,.WVENDDT,.WVPOP,"T-365","T")
+13 ;
+14 SET WVPOP=0
NEW %DT,Y
+15 WRITE !!," *** Date Range Selection ***"
+16 SET %DT="APEX"_$SELECT($DATA(WVTIME):"T",1:"")
+17 SET %DT("A")=" Begin with DATE: "
+18 IF $GET(WVBDF)]""
SET Y=WVBDF
DO DD^%DT
SET %DT("B")=Y
+19 DO ^%DT
KILL %DT
+20 IF Y<0
SET WVPOP=1
QUIT
+21 SET (%DT(0),WVB)=Y
KILL %DT("B")
+22 SET %DT="APEX"_$SELECT($DATA(WVTIME):"T",1:"")
+23 SET %DT("A")=" End with DATE: "
+24 IF $GET(WVEDF)]""
SET Y=WVEDF
DO DD^%DT
SET %DT("B")=Y
+25 IF $DATA(WVSAME)
SET Y=WVB
DO DD^%DT
SET %DT("B")=Y
+26 DO ^%DT
KILL %DT
+27 IF Y<0
SET WVPOP=1
QUIT
+28 SET WVE=Y
+29 QUIT
+30 ;
LOCKED ;EP
+1 ;quit if called from a background (tasked) job.
if $DATA(ZTQUEUED)
QUIT
+2 WRITE !?5,"Another user is editing this entry. Please, try again later."
+3 DO DIRZ
+4 QUIT
+5 ;
LOCKEDE ;EP
+1 ;---> LOCKED PREGNANCY LOG ENTRY.
+2 WRITE !?5,"Another user is editing the Pregnancy Log for this patient"
+3 WRITE !?5,"for this day. Please, try again later."
+4 DO DIRZ
+5 QUIT
+6 ;
LOCKEDP ;EP
+1 ;---> LOCKED PAP Regimen Log ENTRY.
+2 WRITE !?5,"Another user is editing the PAP Regimen Log for this patient"
+3 WRITE !?5,"for this day. Please, try again later."
+4 DO DIRZ
+5 QUIT
+6 ;
LOCKEDL ;EP
+1 ;---> LOCKED LACTATION LOG ENTRY.
+2 WRITE !?5,"Another user is editing the Lactation Log for this patient"
+3 WRITE !?5,"for this day. Please, try again later."
+4 DO DIRZ
+5 QUIT
+6 ;
LOCKEDM ;EP
+1 ;---> LOCKED MENSTRUAL CYCLE LOG ENTRY.
+2 WRITE !?5,"Another user is editing the Menstrual Cycle Log for this patient"
+3 WRITE !?5,"for this day. Please, try again later."
+4 DO DIRZ
+5 QUIT
+6 ;
DIRZ ;EP
+1 ;---> PRESS RETURN TO CONTINUE.
+2 NEW DIR,DIRUT,X,Y,DTOUT,DUOUT,DIROUT
+3 IF $DATA(WVPRMT)
SET DIR("A")=WVPRMT
+4 IF $DATA(WVPRMT1)
SET DIR("A",1)=WVPRMT1
+5 IF $DATA(WVPRMT2)
SET DIR("A",2)=WVPRMT2
+6 IF $DATA(WVPRMTQ)
SET DIR("?")=WVPRMTQ
+7 SET DIR(0)="E"
WRITE !
DO ^DIR
WRITE !
+8 SET WVPOP=$SELECT($DATA(DIRUT):1,Y<1:1,1:0)
+9 QUIT
+10 ;
DIRPRMT ;EP
+1 ;---> REQUIRED VARIABLE: WVPROMPT,M (M=LAST SELECTION# DISPLAYED)
+2 ;---> OPTIONAL VARIABLE: WVCODE (EXECUTABLE CODE ACTING ON INPUT X)
+3 ;---> WVD=1 IF RANGE OF SELECTION NUMBERS SHOULD BE DISPLAYED.
+4 NEW DIR,DIRUT,Y,X,DTOUT,DUOUT,DIROUT
+5 WRITE !
if '$DATA(WVD)
SET WVD=0
+6 SET DIR(0)="LO^"_$SELECT(WVD:":"_M,1:"1:"_M)
+7 IF $DATA(WVPRMT)
SET DIR("A")=WVPRMT
+8 IF $DATA(WVPRMT1)
SET DIR("A",1)=WVPRMT1
+9 IF $DATA(WVPRMT2)
SET DIR("A",2)=WVPRMT2
+10 IF $DATA(WVPRMTQ)
SET DIR("?")=WVPRMTQ
+11 IF $DATA(WVCODE)
SET DIR(0)=DIR(0)_U_WVCODE
+12 DO ^DIR
+13 if $DATA(DTOUT)!($DATA(DUOUT))
SET WVPOP=1
+14 QUIT
+15 ;
STORPAP ;EP
+1 ;---> STORE PAP REGIMEN, START DATE AND DATE ENTERED; CALLED BY
+2 ;---> MUMPS XREF ON FIELDS #.16 AND #.17 IN WV PATIENT FILE.
+3 ;---> REQUIRED VARIABLES: WVLDAT=BEGIN DATE, WVLPRG=PAP REGIMEN, WVDFN.
+4 if '$DATA(WVLDAT)!('$DATA(WVLPRG))!('$DATA(WVDFN))
QUIT
+5 if 'WVLDAT!('WVLPRG)!('WVDFN)
QUIT
+6 NEW DA,DIC,DIE,DLAYGO,DR,N,WVQUIT,X,DG
+7 DO SETVARS^WVUTL5
+8 SET WVQUIT=0
SET DLAYGO=790
+9 SET DIE="^WV(790.04,"
+10 SET DR=".01////"_WVLDAT_";.03////"_WVLPRG
+11 SET N=0
+12 FOR
SET N=$ORDER(^WV(790.04,"C",WVDFN,N))
if 'N!(WVQUIT)
QUIT
Begin DoDot:1
+13 IF $DATA(^WV(790.04,"B",WVLDAT,N))
SET DA=N
Begin DoDot:2
+14 LOCK +^WV(790.04,DA):0
IF '$TEST
DO LOCKEDP
SET WVQUIT=1
QUIT
+15 DO DIE^WVFMAN(790.04,DR,DA,.WVPOP)
LOCK -^WV(790.04,DA)
SET WVQUIT=1
End DoDot:2
End DoDot:1
+16 if WVQUIT
QUIT
+17 ;
+18 KILL DD,DO
+19 SET DIC="^WV(790.04,"
SET DIC(0)="L"
SET X=WVLDAT
SET DLAYGO=790
+20 SET DIC("DR")=".02////"_WVDFN_";.03////"_WVLPRG
+21 DO FILE^DICN
+22 QUIT
+23 ;
PCDVARS(DA,TEXTDATE,COLP) ;EP
+1 ;---> SET VARIABLES FOR PROCEDURE DATA FOR HEADERS.
+2 ;---> REQUIRED VARIABLES: DA=IEN OF PROCEDURE IN PROC FILE 790.1.
+3 ;---> TEXTDATE=1 PROVIDE DATE IN TEXT FORMAT,
+4 ;---> OTHERWISE IN NUMERIC FORMAT (1/1/95)
+5 ;---> COLP=1 TO SET WVC0=ASSOC'D COLP IF THIS IS
+6 ;---> A PAP.
+7 ;---> Y=ZERO NODE OF PROCEDURE, WVACCN=ACCESSION#,
+8 ;---> WVPCDN=IEN OF PROCEDURE TYPE,
+9 ;---> WVRESN=IEN OF RESULT/DIAG,WVRES=TEXT OF RESULT/DIAG
+10 ;---> WVPN=PROCEDURE TYPE, WVDFN=DFN OF PATIENT.
+11 ;---> WV0=ZERO NODE OF THIS PROCEDURE, WV2=TWO NODE.
+12 ;---> WVPAP=1=PCD IS A PAP, WVMAM=1=PCD IS A SCREENING MAM.
+13 ;---> WVC0=ZERO NODE OF ASSOCIATED COLP (IF THIS IS A PAP).
+14 ;
+15 NEW X,Y
SET (WV0,Y)=^WV(790.1,DA,0)
SET WVC0=""
+16 SET WV2=$SELECT($DATA(^WV(790.1,DA,2)):^(2),1:"")
+17 SET COLP=$GET(COLP)
if COLP
SET WVC0=$$COLP0^WVUTL4(DA)
+18 SET TEXTDATE=$GET(TEXTDATE)
+19 SET WVACCN=$$ACC^WVUTL1(DA)
+20 SET WVPCDN=$PIECE(Y,U,4)
+21 SET X=DA
SET WVPN=$$PROC^WVUTL1A
+22 SET WVRESN=$PIECE(Y,U,5)
SET WVRES=$$DIAG^WVUTL4(WVRESN)
+23 SET X=$PIECE(Y,U,7)
SET WVPROV=$$PROV^WVUTL6
+24 SET WVDFN=$PIECE(Y,U,2)
DO PATVARS(WVDFN,TEXTDATE)
+25 SET (WVMAM,WVPAP)=0
+26 if WVPCDN=28
SET WVMAM=1
if WVPCDN=1
SET WVPAP=1
+27 QUIT
+28 ;
PATVARS(DFN,TEXTDATE) ;EP
+1 ;---> SET VARIABLES FO PATIENT DATA FOR HEADERS.
+2 ;---> REQUIRED VARIABLES: WVDFN=IEN OF PATIENT
+3 ;---> YIELDS: WVNAME=PATIENT NAME, WVCHRT=SSN#
+4 ;---> WVCMGR=CASE MANAGER, WVCNEED=CX TX NEED,
+5 ;---> WVPAPRG=PAP REGIMEN, WVBNEED=BR TX NEED, WVEDC=EDC.
+6 SET TEXTDATE=$GET(TEXTDATE)
+7 SET WVNAME=$$NAME^WVUTL1(DFN)
+8 SET WVNAMAGE=$$NAMAGE^WVUTL1(DFN)
+9 SET WVCHRT=$$SSN^WVUTL1(DFN)
+10 SET WVCMGR=$$CMGR^WVUTL1(DFN)
+11 SET WVCNEED=$$CNEED^WVUTL1(DFN,TEXTDATE)
+12 SET WVPAPRG=$$PAPRG^WVUTL1(DFN,TEXTDATE)
+13 SET WVBNEED=$$BNEED^WVUTL1(DFN,TEXTDATE)
+14 SET WVEDC=$$EDC^WVUTL1(DFN)
+15 QUIT
+16 ;
SETFMVAR ;SAVE FILEMAN VARIABLES FOR RESTORATION
+1 if $DATA(DI)
SET WVDI=DI
+2 if $DATA(DQ)
SET WVDQ=DQ
+3 if $DATA(DC)
SET WVDC=DC
+4 if $DATA(DM)
SET WVDM=DM
+5 if $DATA(DK)
SET WVDK=DK
+6 if $DATA(DP)
SET WVDP=DP
+7 if $DATA(DL)
SET WVDL=DL
+8 if $DATA(DIU)
SET WVDIU=DIU
+9 QUIT
+10 ;
GETFMVAR ;RESTORE FILEMAN VARIABLS
+1 if $DATA(WVDI)
SET DI=WVDI
+2 if $DATA(WVDQ)
SET DQ=WVDQ
+3 if $DATA(WVDC)
SET DC=WVDC
+4 if $DATA(WVDM)
SET DM=WVDM
+5 if $DATA(WVDK)
SET DK=WVDK
+6 if $DATA(WVDP)
SET DP=WVDP
+7 if $DATA(WVDL)
SET DL=WVDL
+8 if $DATA(WVDIU)
SET DIU=WVDIU
+9 KILL WVDI,WVDQ,WVDC,WVDM,WVDK,WVDP,WVDL,WVDIU
+10 QUIT
+11 ;
FMADD(WVDAYS,WVPDT) ; This function adds the date offset indicated to the
+1 ; specified date to calculate a future date.
+2 ; Input: WVDAYS - date offset (e.g., 90D, 6M, 1Y) [required]
+3 ; WVPDT - date of procedure [optional]
+4 ; default is today
+5 ; Output: FileMan date. Returns null if a FileMan date could not
+6 ; be calculated.
+7 ;
+8 if 'WVDAYS
QUIT ""
+9 if '$GET(WVPDT)
SET WVPDT=DT
+10 NEW WVARRAY,WVERR,WVLOOP,WVMONTH,WVNEWDT,WVYEAR,X
+11 SET WVNEWDT=""
+12 SET X=WVDAYS
+13 ;check offset value
DO DMYCHECK^WVPURP
+14 SET WVDAYS=X
+15 IF X=-1
QUIT WVNEWDT
+16 IF WVDAYS["D"
Begin DoDot:1
+17 SET WVARRAY=$$FMADD^XLFDT(WVPDT,+WVDAYS)
+18 if WVARRAY>0
SET WVNEWDT=WVARRAY
+19 QUIT
End DoDot:1
+20 IF WVDAYS["M"
Begin DoDot:1
+21 SET WVMONTH=+$EXTRACT(WVPDT,4,5)
SET WVYEAR=0
+22 FOR WVLOOP=1:1:+WVDAYS
Begin DoDot:2
+23 SET WVMONTH=WVMONTH+1
+24 IF WVMONTH>12
SET WVMONTH=1
SET WVYEAR=WVYEAR+1
+25 QUIT
End DoDot:2
+26 SET WVNEWDT=WVPDT+(+WVYEAR*10000)
+27 SET WVMONTH=$SELECT(WVMONTH<10:"0"_WVMONTH,1:WVMONTH)
+28 SET WVNEWDT=$EXTRACT(WVNEWDT,1,3)_WVMONTH_$EXTRACT(WVNEWDT,6,7)
+29 QUIT
End DoDot:1
+30 IF WVDAYS["Y"
SET WVNEWDT=WVPDT+(+WVDAYS*10000)
+31 QUIT WVNEWDT
+32 ;
PSTATCHG(OLDVAL,NEWVAL,DA) ;UPDATE RELATED FIELDS WHEN PREGNANCY STATUS
+1 ; FIELD VALUE CHANGES ('AF' CROSS-REFERENCE
+2 ; IN PREGNANCY STATUSES SUB-FILE #790.05)
+3 ; INPUT: OLDVAL - The original value in internal format
+4 ; NEWVAL - The new value in internal format
+5 ; DA - Reference to a FileMan DA array containing the IEN values
+6 ; that identify the entry the user is modifying
+7 NEW DIK,DIH,DIG,DIV,DIW
+8 IF ($GET(NEWVAL)=1)&(($GET(OLDVAL)=0)!($GET(OLDVAL)=2))
Begin DoDot:1
+9 SET $PIECE(^WV(790,DA(1),4,DA,2),U,4)=""
SET $PIECE(^WV(790,DA(1),4,DA,4),U,4)=""
+10 SET $PIECE(^WV(790,DA(1),4,DA,4),U,5)=""
+11 SET DIK="^WV(790,"_DA(1)_",4,"
+12 FOR DIK(1)=24,44,45
DO EN^DIK
+13 DO METHOD^WVTDALRT(DA(1),.DA,0)
End DoDot:1
+14 IF ((+$GET(NEWVAL)=0)!($GET(NEWVAL)=2)!($GET(NEWVAL)=3))&($GET(OLDVAL)=1)
Begin DoDot:1
+15 SET $PIECE(^WV(790,DA(1),4,DA,4),U)=""
SET $PIECE(^WV(790,DA(1),4,DA,4),U,2)=""
+16 SET $PIECE(^WV(790,DA(1),4,DA,4),U,3)=""
+17 SET DIK="^WV(790,"_DA(1)_",4,"
+18 FOR DIK(1)=41,42,43
DO EN^DIK
End DoDot:1
+19 IF ($GET(NEWVAL)=3)&(($GET(OLDVAL)=0)!($GET(OLDVAL)=2))
Begin DoDot:1
+20 SET $PIECE(^WV(790,DA(1),4,DA,2),U,4)=""
+21 SET DIK="^WV(790,"_DA(1)_",4,"
SET DIK(1)=24
DO EN^DIK
End DoDot:1
+22 QUIT
EIECHG(OLDVAL,NEWVAL,DA,NODE) ;UPDATE RELATED FIELDS WHEN ENTERED IN ERROR FIELD
+1 ; VALUE CHANGES ('AN' CROSS-REFERENCE IN PREGNANCY
+2 ; STATUSES SUB-FILE #790.05 AND 'AG' CROSS-REFERENCE IN
+3 ; LACTATION STATUSES SUB-FILE #790.16)
+4 ; INPUT: OLDVAL - The original value in internal format
+5 ; NEWVAL - The new value in internal format
+6 ; DA - Reference to a FileMan DA array containing the IEN values
+7 ; that identify the entry the user is modifying
+8 ; NODE - THE SUBSCRIPT THAT CONTAINS THE DATA
+9 NEW DIK,STAT,DIH,DIG,DIV,DIW
+10 IF $GET(OLDVAL)=""
IF $GET(NEWVAL)=1
Begin DoDot:1
+11 SET $PIECE(^WV(790,DA(1),NODE,DA,0),U,7)=DUZ
SET $PIECE(^(0),U,8)=$$NOW^XLFDT
+12 SET DIK="^WV(790,"_DA(1)_","_NODE_","
+13 FOR DIK(1)=4,5
DO EN2^DIK
+14 SET $PIECE(^WV(790,DA(1),NODE,DA,0),U,4)=""
+15 SET $PIECE(^WV(790,DA(1),NODE,DA,0),U,5)=""
+16 SET STAT("CSTAT")=$PIECE($GET(^WV(790,DA(1),NODE,DA,2)),U)
SET STAT("CDATE")=$PIECE($GET(^WV(790,DA(1),NODE,DA,0)),U)
+17 SET STAT("PDATE")=$ORDER(^WV(790,DA(1),NODE,"B",STAT("CDATE")),-1)
+18 IF STAT("PDATE")>0
Begin DoDot:2
+19 SET STAT("PIEN")=$ORDER(^WV(790,DA(1),NODE,"B",STAT("PDATE"),0))
SET STAT("PSTAT")=$PIECE($GET(^WV(790,DA(1),NODE,STAT("PIEN"),2)),U)
End DoDot:2
+20 IF STAT("CSTAT")=1
IF $GET(STAT("PSTAT"))'=1
DO @($SELECT(NODE=4:"PREG",NODE=5:"LACT",1:"")_U_"WVTDALRT(DA(1),0)")
+21 IF NODE=4
Begin DoDot:2
+22 SET STAT("CTRY")=$PIECE($GET(^WV(790,DA(1),NODE,DA,2)),U,4)
+23 SET STAT("CLIKE")=$$COBP^WVUTL11(DA(1),DA)
+24 IF $GET(STAT("PIEN"))>0
Begin DoDot:3
+25 SET STAT("PTRY")=$PIECE($GET(^WV(790,DA(1),NODE,STAT("PIEN"),2)),U,4)
+26 SET STAT("PLIKE")=$$COBP^WVUTL11(DA(1),STAT("PIEN"))
End DoDot:3
+27 IF STAT("CTRY")=1
IF $GET(STAT("PTRY"))'=1
DO TRY^WVTDALRT(DA(1),0)
+28 IF STAT("CLIKE")<$GET(STAT("PLIKE"))!(+$GET(STAT("PLIKE"))=0&(STAT("CLIKE")=1))
DO DELALERT^WVTDALRT($$MTEXT^WVTDALRT,DA(1))
End DoDot:2
End DoDot:1
+29 QUIT
