Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: WVUTL9

WVUTL9.m

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