WVUTL9 ;HCIOFO/FT-Women's Health Utility Routine; ;3/18/03 15:44
;;1.0;WOMEN'S HEALTH;**3,7,9,10,17**;Sep 30, 1998
;
; This routine uses the following IAs:
; #10035 - ^DPT references (supported)
; #10056 - ^DIC(5 references (supported)
; #10061 - ^VADPT calls (supported)
; #10103 - ^XLFDT calls (supported)
;
DCM(SITE) ; Default case manager check
; If there is a default case manager return 1 else 0.
I 'SITE Q 0
I $P($G(^WV(790.02,SITE,0)),U,2) Q 1
Q 0
;
NODCM ; No Default Case Manager message
W !,"Sorry, but a DEFAULT CASE MANAGER must be assigned for your facility"
W !,"before a patient can be entered into the Women's Health database.",!
W !,"Please use the EDIT SITE PARAMETERS option on the FILE MAINTENANCE"
W !,"menu to designate a DEFAULT CASE MANAGER.",!
D DIRZ^WVUTL3
Q
;
AGE(DFN) ;EP
;---> YIELD PATIENT'S AGE IN YEARS.
;---> REQUIRED VARIABLE: DFN=IEN PATIENT FILE
; Different from AGE^WVUTL1. This EP returns age at date of death.
N X,X1,X2
Q:'$G(DFN) "NO PATIENT"
S X2=$$DOB^WVUTL1(DFN)
Q:'+X2 "UNKNOWN"
S X1=DT
I $$DECEASED^WVUTL1(DFN) S X1=+^DPT(DFN,.35)
D ^%DTC
Q $P(X/365.25,".")_"y/o"
;
GAPPT(DFN) ; Get future appointments from SDA^VADPT
; Returns ^UTILITY("VASD",$J,#,"I") <-internal values
; ^UTILITY("VASD",$J,#,"E") <-external vlaues
; piece 1: appointment date/time
; 2: clinic
; 3: status
; 4: type
Q:'$G(DFN)
N VASD,VAERR
S VASD("F")=$$NOW^XLFDT,VASD("W")=1 ;get active/kept appts
D SDA^VADPT
Q
KAPPT(DFN) ; Kill APPOINTMENTS multiple
Q:'$G(DFN)
N DA,DIK
S DA=0,DA(1)=DFN
F S DA=$O(^WV(790,DFN,2,DA)) Q:'DA D
.S DIK="^WV(790,"_DFN_",2,"
.D ^DIK
.Q
Q
SAPPT(DFN) ; Set APPOINTMENTS multiple
Q:'$G(DFN)
Q:'$D(^WV(790,DFN))
N DA,DIC,DLAYGO,LOOP,X
S LOOP=0,DIC="^WV(790,"_DFN_",2,",DIC(0)="L",DA(1)=DFN,DLAYGO=790
I '$D(^UTILITY("VASD",$J)) D Q ;no appts passed from SDA^VADPT
.S X="No Future Appointments"
.D ^DIC
.Q
F S LOOP=$O(^UTILITY("VASD",$J,LOOP)) Q:'LOOP D
.S X=$G(^UTILITY("VASD",$J,LOOP,"E"))
.Q:X=""
.S X=$P(X,U,1)_" Clinic: "_$P(X,U,2)
.D ^DIC
.Q
Q
KILLUG ; Kill Utility Global created by SDA^VADPT call
K ^UTILITY("VASD",$J)
Q
IEN(WVFILE,WVALUE) ; Return ien of entry
; input: WVFILE - File number
; WVALUE - value of the .01 field
I 'WVFILE!(WVALUE="") Q 0
Q +$O(^WV(WVFILE,"B",WVALUE,0))
;
GADD(DFN) ; Get COMPLETE ADDRESS with ADD^VADPT
; Returns VAPA array
Q:'$G(DFN)
D ADD^VADPT
Q
KADD(DFN) ; Kill COMPLETE ADDRESS multiple
Q:'$G(DFN)
N DA,DIK
S DA=0,DA(1)=DFN
F S DA=$O(^WV(790,DFN,3,DA)) Q:'DA D
.S DIK="^WV(790,"_DFN_",3,"
.D ^DIK
.Q
Q
SADD(DFN) ; Set COMPLETE ADDRESS multiple
Q:'$G(DFN)
Q:'$D(^WV(790,DFN))
N DA,DIC,DLAYGO,LOOP,WVERR,WVSTATE,X
S LOOP=0,DIC="^WV(790,"_DFN_",3,",DIC(0)="L",DA(1)=DFN,DLAYGO=790
I '$D(VAPA) D Q ;no address passed from ADD^VADPT
.S X="No Address on file"
.D ^DIC
.Q
; look for confidential address
I $G(VAPA(12))'=1 D RA Q ;no confidential address, use regular address
I $P($G(VAPA(22,2)),U,3)="Y" D CC Q ;category 2 - appointments
I $P($G(VAPA(22,4)),U,3)="Y" D CC Q ;category 4 - medical records
D RA
Q
RA ; get regular address
F LOOP=1,2,3 D
.S X=$G(VAPA(LOOP))
.Q:X=""
.S:$E(X)'?1N X=" "_X
.D ^DIC
.Q
S WVSTATE=""
I $P(VAPA(5),U,1) D
.S WVSTATE=$$GET1^DIQ(5,$P(VAPA(5),U,1),1,"E","","WVERR")
.Q
S X=VAPA(4)_", "_WVSTATE_" "_VAPA(6)
Q:X=", "
D ^DIC
Q
CC ; get Confidential Communication address
F LOOP=13,14,15 D
.S X=$G(VAPA(LOOP))
.Q:X=""
.S:$E(X)'?1N X=" "_X
.D ^DIC
.Q
S WVSTATE=""
I $P(VAPA(17),U,1) D
.S WVSTATE=$$GET1^DIQ(5,$P(VAPA(17),U,1),1,"E","","WVERR")
.Q
S X=$P(VAPA(16),U,1)_", "_WVSTATE_" "_$P(VAPA(18),U,1)
Q:X=", "
D ^DIC
Q
KVAR ; Kill off VADPT variables used
D KVAR^VADPT
Q
ELIG(WVDFN) ; Get patient's eligibilty code.
; Input: patient DFN
; Output: internal^external values
N DFN,I,VAEL,VAERR,X,Y
S DFN=WVDFN
D ELIG^VADPT ;get elibility code
Q $G(VAEL(1)) ;VAEL(1)=internal^external
;
HELP(WVDA,WVA,WVB) ; Display message for eligiblity codes
; WVDA - the FILE 790.02 ien
; WVA - the node number where the eligibilty codes are stored
; WVB - the package name associated with those eligibility codes
Q:'$O(^WV(790.02,WVDA,WVA,0)) ;no eligibility codes for lab data
N WVMSG
S WVMSG(1)="The ELIGIBILITY CODE(S) defined for "_WVB_" will be deleted when you"
S WVMSG(2)="exit and save your changes."
D HLP^DDSUTL(.WVMSG)
Q
DELETE(WVDA) ; Delete eligibility codes, if necessary
; task as a background job?
Q:'WVDA
N WVLAV,WVLSP,WVNODE,WVRAV,WVRSP,X,Y
S WVNODE=$G(^WV(790.02,WVDA,0))
Q:WVNODE=""
S WVRSP=$P(WVNODE,U,10) ;import mams from radiology
S WVRAV=$P(WVNODE,U,25) ;include all non-veterans (rad)
S WVLSP=$P(WVNODE,U,24) ;import tests from lab
S WVLAV=$P(WVNODE,U,26) ;include all non-veterans (lab)
; Delete eligibility codes related to radiology if
; 1) import mams from radiology = YES, or
; 2) include all non-veterans (rad) = YES, or
; 3) include all non-veterans (rad) = null
I WVRSP'=1!(WVRAV=1)!(WVRAV="") D
.N DA,DIK
.S DA(1)=WVDA,DA=0,DIK="^WV(790.02,DA(1),5,"
.F S DA=$O(^WV(790.02,DA(1),5,DA)) Q:'DA D ^DIK
.Q
; Delete eligibility codes related to laboratory if
; 1) import tests from lab = YES, or
; 2) include all non-veterans (lab) = YES, or
; 3) include all non-veterans (lab) = null
I WVLSP'=1!(WVLAV=1)!(WVLAV="") D
.N DA,DIK
.S DA(1)=WVDA,DA=0,DIK="^WV(790.02,DA(1),6,"
.F S DA=$O(^WV(790.02,DA(1),6,DA)) Q:'DA D ^DIK
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVUTL9 5726 printed Sep 23, 2025@20:24:36 Page 2
WVUTL9 ;HCIOFO/FT-Women's Health Utility Routine; ;3/18/03 15:44
+1 ;;1.0;WOMEN'S HEALTH;**3,7,9,10,17**;Sep 30, 1998
+2 ;
+3 ; This routine uses the following IAs:
+4 ; #10035 - ^DPT references (supported)
+5 ; #10056 - ^DIC(5 references (supported)
+6 ; #10061 - ^VADPT calls (supported)
+7 ; #10103 - ^XLFDT calls (supported)
+8 ;
DCM(SITE) ; Default case manager check
+1 ; If there is a default case manager return 1 else 0.
+2 IF 'SITE
QUIT 0
+3 IF $PIECE($GET(^WV(790.02,SITE,0)),U,2)
QUIT 1
+4 QUIT 0
+5 ;
NODCM ; No Default Case Manager message
+1 WRITE !,"Sorry, but a DEFAULT CASE MANAGER must be assigned for your facility"
+2 WRITE !,"before a patient can be entered into the Women's Health database.",!
+3 WRITE !,"Please use the EDIT SITE PARAMETERS option on the FILE MAINTENANCE"
+4 WRITE !,"menu to designate a DEFAULT CASE MANAGER.",!
+5 DO DIRZ^WVUTL3
+6 QUIT
+7 ;
AGE(DFN) ;EP
+1 ;---> YIELD PATIENT'S AGE IN YEARS.
+2 ;---> REQUIRED VARIABLE: DFN=IEN PATIENT FILE
+3 ; Different from AGE^WVUTL1. This EP returns age at date of death.
+4 NEW X,X1,X2
+5 if '$GET(DFN)
QUIT "NO PATIENT"
+6 SET X2=$$DOB^WVUTL1(DFN)
+7 if '+X2
QUIT "UNKNOWN"
+8 SET X1=DT
+9 IF $$DECEASED^WVUTL1(DFN)
SET X1=+^DPT(DFN,.35)
+10 DO ^%DTC
+11 QUIT $PIECE(X/365.25,".")_"y/o"
+12 ;
GAPPT(DFN) ; Get future appointments from SDA^VADPT
+1 ; Returns ^UTILITY("VASD",$J,#,"I") <-internal values
+2 ; ^UTILITY("VASD",$J,#,"E") <-external vlaues
+3 ; piece 1: appointment date/time
+4 ; 2: clinic
+5 ; 3: status
+6 ; 4: type
+7 if '$GET(DFN)
QUIT
+8 NEW VASD,VAERR
+9 ;get active/kept appts
SET VASD("F")=$$NOW^XLFDT
SET VASD("W")=1
+10 DO SDA^VADPT
+11 QUIT
KAPPT(DFN) ; Kill APPOINTMENTS multiple
+1 if '$GET(DFN)
QUIT
+2 NEW DA,DIK
+3 SET DA=0
SET DA(1)=DFN
+4 FOR
SET DA=$ORDER(^WV(790,DFN,2,DA))
if 'DA
QUIT
Begin DoDot:1
+5 SET DIK="^WV(790,"_DFN_",2,"
+6 DO ^DIK
+7 QUIT
End DoDot:1
+8 QUIT
SAPPT(DFN) ; Set APPOINTMENTS multiple
+1 if '$GET(DFN)
QUIT
+2 if '$DATA(^WV(790,DFN))
QUIT
+3 NEW DA,DIC,DLAYGO,LOOP,X
+4 SET LOOP=0
SET DIC="^WV(790,"_DFN_",2,"
SET DIC(0)="L"
SET DA(1)=DFN
SET DLAYGO=790
+5 ;no appts passed from SDA^VADPT
IF '$DATA(^UTILITY("VASD",$JOB))
Begin DoDot:1
+6 SET X="No Future Appointments"
+7 DO ^DIC
+8 QUIT
End DoDot:1
QUIT
+9 FOR
SET LOOP=$ORDER(^UTILITY("VASD",$JOB,LOOP))
if 'LOOP
QUIT
Begin DoDot:1
+10 SET X=$GET(^UTILITY("VASD",$JOB,LOOP,"E"))
+11 if X=""
QUIT
+12 SET X=$PIECE(X,U,1)_" Clinic: "_$PIECE(X,U,2)
+13 DO ^DIC
+14 QUIT
End DoDot:1
+15 QUIT
KILLUG ; Kill Utility Global created by SDA^VADPT call
+1 KILL ^UTILITY("VASD",$JOB)
+2 QUIT
IEN(WVFILE,WVALUE) ; Return ien of entry
+1 ; input: WVFILE - File number
+2 ; WVALUE - value of the .01 field
+3 IF 'WVFILE!(WVALUE="")
QUIT 0
+4 QUIT +$ORDER(^WV(WVFILE,"B",WVALUE,0))
+5 ;
GADD(DFN) ; Get COMPLETE ADDRESS with ADD^VADPT
+1 ; Returns VAPA array
+2 if '$GET(DFN)
QUIT
+3 DO ADD^VADPT
+4 QUIT
KADD(DFN) ; Kill COMPLETE ADDRESS multiple
+1 if '$GET(DFN)
QUIT
+2 NEW DA,DIK
+3 SET DA=0
SET DA(1)=DFN
+4 FOR
SET DA=$ORDER(^WV(790,DFN,3,DA))
if 'DA
QUIT
Begin DoDot:1
+5 SET DIK="^WV(790,"_DFN_",3,"
+6 DO ^DIK
+7 QUIT
End DoDot:1
+8 QUIT
SADD(DFN) ; Set COMPLETE ADDRESS multiple
+1 if '$GET(DFN)
QUIT
+2 if '$DATA(^WV(790,DFN))
QUIT
+3 NEW DA,DIC,DLAYGO,LOOP,WVERR,WVSTATE,X
+4 SET LOOP=0
SET DIC="^WV(790,"_DFN_",3,"
SET DIC(0)="L"
SET DA(1)=DFN
SET DLAYGO=790
+5 ;no address passed from ADD^VADPT
IF '$DATA(VAPA)
Begin DoDot:1
+6 SET X="No Address on file"
+7 DO ^DIC
+8 QUIT
End DoDot:1
QUIT
+9 ; look for confidential address
+10 ;no confidential address, use regular address
IF $GET(VAPA(12))'=1
DO RA
QUIT
+11 ;category 2 - appointments
IF $PIECE($GET(VAPA(22,2)),U,3)="Y"
DO CC
QUIT
+12 ;category 4 - medical records
IF $PIECE($GET(VAPA(22,4)),U,3)="Y"
DO CC
QUIT
+13 DO RA
+14 QUIT
RA ; get regular address
+1 FOR LOOP=1,2,3
Begin DoDot:1
+2 SET X=$GET(VAPA(LOOP))
+3 if X=""
QUIT
+4 if $EXTRACT(X)'?1N
SET X=" "_X
+5 DO ^DIC
+6 QUIT
End DoDot:1
+7 SET WVSTATE=""
+8 IF $PIECE(VAPA(5),U,1)
Begin DoDot:1
+9 SET WVSTATE=$$GET1^DIQ(5,$PIECE(VAPA(5),U,1),1,"E","","WVERR")
+10 QUIT
End DoDot:1
+11 SET X=VAPA(4)_", "_WVSTATE_" "_VAPA(6)
+12 if X=", "
QUIT
+13 DO ^DIC
+14 QUIT
CC ; get Confidential Communication address
+1 FOR LOOP=13,14,15
Begin DoDot:1
+2 SET X=$GET(VAPA(LOOP))
+3 if X=""
QUIT
+4 if $EXTRACT(X)'?1N
SET X=" "_X
+5 DO ^DIC
+6 QUIT
End DoDot:1
+7 SET WVSTATE=""
+8 IF $PIECE(VAPA(17),U,1)
Begin DoDot:1
+9 SET WVSTATE=$$GET1^DIQ(5,$PIECE(VAPA(17),U,1),1,"E","","WVERR")
+10 QUIT
End DoDot:1
+11 SET X=$PIECE(VAPA(16),U,1)_", "_WVSTATE_" "_$PIECE(VAPA(18),U,1)
+12 if X=", "
QUIT
+13 DO ^DIC
+14 QUIT
KVAR ; Kill off VADPT variables used
+1 DO KVAR^VADPT
+2 QUIT
ELIG(WVDFN) ; Get patient's eligibilty code.
+1 ; Input: patient DFN
+2 ; Output: internal^external values
+3 NEW DFN,I,VAEL,VAERR,X,Y
+4 SET DFN=WVDFN
+5 ;get elibility code
DO ELIG^VADPT
+6 ;VAEL(1)=internal^external
QUIT $GET(VAEL(1))
+7 ;
HELP(WVDA,WVA,WVB) ; Display message for eligiblity codes
+1 ; WVDA - the FILE 790.02 ien
+2 ; WVA - the node number where the eligibilty codes are stored
+3 ; WVB - the package name associated with those eligibility codes
+4 ;no eligibility codes for lab data
if '$ORDER(^WV(790.02,WVDA,WVA,0))
QUIT
+5 NEW WVMSG
+6 SET WVMSG(1)="The ELIGIBILITY CODE(S) defined for "_WVB_" will be deleted when you"
+7 SET WVMSG(2)="exit and save your changes."
+8 DO HLP^DDSUTL(.WVMSG)
+9 QUIT
DELETE(WVDA) ; Delete eligibility codes, if necessary
+1 ; task as a background job?
+2 if 'WVDA
QUIT
+3 NEW WVLAV,WVLSP,WVNODE,WVRAV,WVRSP,X,Y
+4 SET WVNODE=$GET(^WV(790.02,WVDA,0))
+5 if WVNODE=""
QUIT
+6 ;import mams from radiology
SET WVRSP=$PIECE(WVNODE,U,10)
+7 ;include all non-veterans (rad)
SET WVRAV=$PIECE(WVNODE,U,25)
+8 ;import tests from lab
SET WVLSP=$PIECE(WVNODE,U,24)
+9 ;include all non-veterans (lab)
SET WVLAV=$PIECE(WVNODE,U,26)
+10 ; Delete eligibility codes related to radiology if
+11 ; 1) import mams from radiology = YES, or
+12 ; 2) include all non-veterans (rad) = YES, or
+13 ; 3) include all non-veterans (rad) = null
+14 IF WVRSP'=1!(WVRAV=1)!(WVRAV="")
Begin DoDot:1
+15 NEW DA,DIK
+16 SET DA(1)=WVDA
SET DA=0
SET DIK="^WV(790.02,DA(1),5,"
+17 FOR
SET DA=$ORDER(^WV(790.02,DA(1),5,DA))
if 'DA
QUIT
DO ^DIK
+18 QUIT
End DoDot:1
+19 ; Delete eligibility codes related to laboratory if
+20 ; 1) import tests from lab = YES, or
+21 ; 2) include all non-veterans (lab) = YES, or
+22 ; 3) include all non-veterans (lab) = null
+23 IF WVLSP'=1!(WVLAV=1)!(WVLAV="")
Begin DoDot:1
+24 NEW DA,DIK
+25 SET DA(1)=WVDA
SET DA=0
SET DIK="^WV(790.02,DA(1),6,"
+26 FOR
SET DA=$ORDER(^WV(790.02,DA(1),6,DA))
if 'DA
QUIT
DO ^DIK
+27 QUIT
End DoDot:1
+28 QUIT
