- 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 Feb 19, 2025@00:14:45 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