263 lines
8.8 KiB
Mathematica
263 lines
8.8 KiB
Mathematica
IVMLDEMD ;ALB/PJR/PHH - IVM DEMOGRAPHIC UPLOAD FILE DATE OF DEATH FIELDS ; 7/20/05 9:22am
|
|
;;2.0;INCOME VERIFICATION MATCH;**102,108**; 21-OCT-94
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
;
|
|
DOD(DFN,IVMDA2,IVMDA1,IVMDA) ; function to upload Date of Death
|
|
; fields and return a flag
|
|
;
|
|
; Input: DFN - as patient IEN
|
|
; IVMDA2 - pointer to case record in (#301.5) file
|
|
; IVMDA1 - pointer to PID msg in (#301.501) sub-file
|
|
; IVMDA - pointer to record in (#301.511) sub-file
|
|
;
|
|
; Output: IVMFLAG - 1 if a Date of Death Field
|
|
; 0 if not a Date of Death field
|
|
;
|
|
;
|
|
N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,DODFIELD,DELDATA,CKDEL,DGDAUTO
|
|
;
|
|
; - initialize flags
|
|
S IVMFLAG=0
|
|
;
|
|
; - check for required parameters
|
|
I '$G(DFN)!('$G(IVMDA))!('$G(IVMDA1))!'($G(IVMDA2)) G DODQ
|
|
;
|
|
; - get pointer to (#301.92) file from (#301.511) sub-file
|
|
S IVMPTR=+$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)) G DODQ:'IVMPTR
|
|
;
|
|
ASK ;;
|
|
D CKDEL I CKDEL G DODDEL
|
|
W ! S DIR("A")="Do you wish to proceed with this action"
|
|
S DIR("A",1)="You have selected to update a Date of Death field."
|
|
S DIR("A",2)="All Date of Death Fields will be uploaded."
|
|
S DIR("?")="Enter 'YES' to continue or 'NO' to abort."
|
|
S DIR(0)="Y",DIR("B")="NO"
|
|
D ^DIR K DIR
|
|
S IVMFLAG=1 G DODQ:'Y
|
|
W !,"Filing Date of Death fields... "
|
|
;
|
|
;
|
|
LOOP ; - loop through DOD fields
|
|
S (DGDAUTO,IVMDODUP)=1
|
|
F DODFIELD="ZPD09","ZPD31","ZPD32" D
|
|
.S IVMI=$O(^IVM(301.92,"C",DODFIELD,"")) I IVMI="" Q
|
|
.S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,"")) Q:IVMJ']"" D
|
|
..;
|
|
..; - check for data node in (#301.511) sub-file
|
|
..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) Q:'(+IVMNODE)
|
|
..I DODFIELD="ZPD31",$P(IVMNODE,"^",2)=""!($P(IVMNODE,"^",2)<1)!($P(IVMNODE,"^",2)>9) S $P(IVMNODE,"^",2)="@"
|
|
..I DODFIELD'="ZPD31",$P(IVMNODE,"^",2)=""!($E($P(IVMNODE,"^",2),1,7)'?1.7N) S $P(IVMNODE,"^",2)="@"
|
|
..;
|
|
..; load Date of Death field rec'd from IVM into DHCP (#2) file
|
|
..D UPLOAD(+DFN,$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),$P(IVMNODE,"^",2)) S IVMFLAG=1
|
|
..;
|
|
..; - remove entry from (#301.511) sub-file
|
|
..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
|
|
;
|
|
I IVMFLAG D W "completed.",!
|
|
.D UPLOAD(+DFN,.355,$S($G(DUZ):DUZ,1:.5))
|
|
D DISCHRGE^DGDEATH,XFR^DGDEATH
|
|
K IVMDODUP
|
|
;
|
|
S VALMBCK="R"
|
|
;
|
|
G DODQ
|
|
;
|
|
DODDEL ;
|
|
W ! S DIR("A")="Do you wish to proceed with this action"
|
|
S DIR("A",1)="You have selected to update a DELETION of a Date of Death field."
|
|
S DIR("A",2)="All Date of Death Fields will be deleted."
|
|
S DIR("?")="Enter 'YES' to continue or 'NO' to abort."
|
|
S DIR(0)="Y",DIR("B")="NO"
|
|
D ^DIR K DIR
|
|
S IVMFLAG=1 G DODQ:'Y
|
|
W !,"Filing Date of Death deletions... "
|
|
F DODFIELD="ZPD09","ZPD31","ZPD32" D
|
|
.S IVMI=$O(^IVM(301.92,"C",DODFIELD,"")) I IVMI="" Q
|
|
.S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,"")) Q:IVMJ']""
|
|
.;
|
|
.; - check for data node in (#301.511) sub-file
|
|
.S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
|
|
.Q:'(+IVMNODE)
|
|
.;
|
|
.; load Date of Death deletion rec'd from IVM into DHCP (#2) file
|
|
.I DODFIELD="ZPD09" D UPLOAD(+DFN,.351,"@")
|
|
.;
|
|
.; - remove entry from (#301.511) sub-file
|
|
.D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
|
|
;
|
|
I IVMFLAG D W "completed.",!
|
|
.D UPLOAD(+DFN,.355,.5)
|
|
;
|
|
S VALMBCK="R"
|
|
;
|
|
G DODQ
|
|
CKDEL S CKDEL=0
|
|
S IVMI=$O(^IVM(301.92,"C","ZPD09","")) I IVMI="" Q
|
|
S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
|
|
I IVMJ']"" Q
|
|
;
|
|
; - check for data node in (#301.511) sub-file
|
|
S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
|
|
Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"")
|
|
;
|
|
I $P(IVMNODE,"^",2)="""""" S CKDEL=1
|
|
Q
|
|
AUTODOD(DFN) ;
|
|
; function to automatically upload Date of Death
|
|
; fields and return a flag
|
|
;
|
|
; Input: DFN - as patient IEN
|
|
;
|
|
; Output: IVMFLAG - 1 if a Date of Death Field
|
|
; 0 if not a Date of Death field
|
|
;
|
|
N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,DODFIELD
|
|
N DELDATA,CKDEL,CKADD,CKDUZ,IVMDA1,IVMDA2,DGDAUTO,IVMENT4
|
|
;
|
|
; - initialize flags
|
|
S (IVMFLAG,CKDEL,CKADD,CKDUZ)=0,IVMENT4=999999999
|
|
;
|
|
; - check for required parameters
|
|
S IVMDA2=$G(IVM3015)
|
|
I 'IVMDA2 G DODQ
|
|
S IVMDA1=$O(^HL(771.3,"B","PID",""))
|
|
S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
|
|
I 'IVMDA1 G DODQ
|
|
;
|
|
D CKAUTO I CKDEL D AUTODEL,DEM5,BULL(+^IVM(301.5,IVMDA2,0)) G DODQ
|
|
I CKADD D CKDUZ,AUTOADD,DEM5 G DODQ
|
|
G DODQ
|
|
AUTOADD ;
|
|
S DGDAUTO=1
|
|
; - loop through DOD fields
|
|
F DODFIELD="ZPD09","ZPD31","ZPD32" D
|
|
.S IVMI=$O(^IVM(301.92,"C",DODFIELD,"")) I IVMI="" Q
|
|
.S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,"")) Q:IVMJ']"" D
|
|
..;
|
|
..; - check for data node in (#301.511) sub-file
|
|
..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) Q:'(+IVMNODE)
|
|
..I DODFIELD="ZPD31",$P(IVMNODE,"^",2)=""!($P(IVMNODE,"^",2)<1)!($P(IVMNODE,"^",2)>9) S $P(IVMNODE,"^",2)="@"
|
|
..I DODFIELD'="ZPD31",$P(IVMNODE,"^",2)=""!($E($P(IVMNODE,"^",2),1,7)'?1.7N) S $P(IVMNODE,"^",2)="@"
|
|
..;
|
|
..; load Date of Death field rec'd from IVM into DHCP (#2) file
|
|
..I DODFIELD'="ZPD09" D UPLOAD(+DFN,$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),$P(IVMNODE,"^",2)) S IVMFLAG=1
|
|
..; - remove entry from (#301.511) sub-file
|
|
..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
|
|
;
|
|
I IVMFLAG D UPLOAD(+DFN,.355,$S(CKDUZ:CKDUZ,1:.5))
|
|
D CLEAN(IVMDA2)
|
|
Q
|
|
AUTODEL ;
|
|
N DFNDOD,DODMPI S DFNDOD=0 I $P($G(^DPT(+DFN,.35)),U)>0 S DFNDOD=1
|
|
F DODFIELD="ZPD09","ZPD31","ZPD32" D
|
|
.S IVMI=$O(^IVM(301.92,"C",DODFIELD,"")) I IVMI="" Q
|
|
.S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,"")) Q:IVMJ']""
|
|
.; - check for data node in (#301.511) sub-file
|
|
.S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
|
|
.Q:'(+IVMNODE)
|
|
.; load Date of Death deletion rec'd from IVM into DHCP (#2) file
|
|
.I DODFIELD="ZPD09" I DFNDOD D UPLOAD(+DFN,.351,"@") S DODMPI=$$A31^MPIFA31B(+DFN),IVMFLAG=1
|
|
.; - remove entry from (#301.511) sub-file
|
|
.D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
|
|
;
|
|
I IVMFLAG D UPLOAD(+DFN,.355,.5)
|
|
D CLEAN(IVMDA2)
|
|
Q
|
|
DEM5 ;
|
|
I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D
|
|
.D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up name parameter
|
|
Q
|
|
CKAUTO S (CKDEL,CKADD)=0
|
|
S IVMI=$O(^IVM(301.92,"C","ZPD09","")) I IVMI="" Q
|
|
S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
|
|
I IVMJ']"" Q
|
|
;
|
|
; - check for data node in (#301.511) sub-file
|
|
S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
|
|
Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"")
|
|
;
|
|
I $P(IVMNODE,"^",2)="""""" S CKDEL=1 Q
|
|
I $P(IVMNODE,"^",2)=$P($G(^DPT(DFN,.35)),"^",1) S CKADD=1
|
|
Q
|
|
CKDUZ ; Check to preserve DUZ for "Last Edited By"
|
|
S IVMI=$O(^IVM(301.92,"C","ZPD32","")) I IVMI="" Q
|
|
S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
|
|
I IVMJ']"" Q
|
|
;
|
|
; - check for data node in (#301.511) sub-file
|
|
S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
|
|
Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"")
|
|
;
|
|
I $P(IVMNODE,"^",2)=$P($G(^DPT(DFN,.35)),"^",4) D
|
|
.S CKDUZ=$P($G(^DPT(DFN,.35)),"^",5)
|
|
Q
|
|
UPLOAD(DFN,IVMFIELD,IVMVALUE) ; - file Date of Death fields received from IVM
|
|
; Input: DFN - as patient IEN
|
|
; IVMFIELD - as the field number to be updated
|
|
; IVMVALUE - as the value of the field
|
|
;
|
|
; Output: None
|
|
;
|
|
N DA,DIE,DR
|
|
S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
|
|
D ^DIE
|
|
Q
|
|
;
|
|
DODQ ; - return --> 1 if uploadable field is a Date of Death field
|
|
; --> 0 if nothing uploadable
|
|
;
|
|
I IVMFLAG D RESET^IVMLDEMU
|
|
Q IVMFLAG
|
|
;
|
|
CLEAN(IVMI) ;
|
|
; Remove any Date of Death related entries from IVM UPLOAD DEM
|
|
N IVMJ,IVMN,IVM92,OTHFLG
|
|
S IVMJ=0 F S IVMJ=$O(^IVM(301.5,"ASEG","PID",IVMI,IVMJ)) Q:'IVMJ D
|
|
.I '$D(^IVM(301.5,IVMI,"IN",IVMJ)) D REMASEG(IVMI,IVMJ) Q
|
|
.S (OTHFLG,IVMN)=0 F S IVMN=$O(^IVM(301.5,IVMI,"IN",IVMJ,"DEM",IVMN)) Q:'IVMN D
|
|
..S IVM92=$P(^IVM(301.5,IVMI,"IN",IVMJ,"DEM",IVMN,0),U)
|
|
..I "^15^36^37^"[(U_IVM92_U) D REM511(IVMI,IVMJ,IVMN)
|
|
..I "^15^36^37^"'[(U_IVM92_U) S OTHFLG=1
|
|
.I 'OTHFLG D REM501(IVMI,IVMJ)
|
|
Q
|
|
;
|
|
REM501(IVMI,IVMJ) ;
|
|
; Delete 301.501 entry to remove from ASEG x-ref
|
|
N DA,DIE,DR
|
|
S DA=IVMJ,DA(1)=IVMI
|
|
S DIE="^IVM(301.5,"_DA(1)_",""IN"","
|
|
S DR=".02////@" D ^DIE
|
|
Q
|
|
;
|
|
REM511(IVMI,IVMJ,IVMN) ;
|
|
; Delete 301.511 entry to remove from IVM UPLOAD DEM
|
|
N DA,DIK
|
|
S DA(1)=IVMJ,DA(2)=IVMI,DA=IVMN
|
|
S DIK="^IVM(301.5,"_DA(2)_",""IN"","_DA(1)_",""DEM"","
|
|
D ^DIK
|
|
Q
|
|
;
|
|
REMASEG(IVMI,IVMJ) ;
|
|
; Delete invalid ASEG x-ref entries
|
|
K ^IVM(301.5,"ASEG","PID",IVMI,IVMJ)
|
|
Q
|
|
BULL(DFN) ; Date of Death Deletion Bulletin
|
|
I '$D(^DPT(DFN,0)) Q
|
|
I '(+$G(^DPT(DFN,.35))) Q
|
|
;
|
|
N DGDEATH,DGB,DGPCMM,XMSUB,X
|
|
S DGDEATH=+$G(^DPT(DFN,.35)),XMSUB="Patient Death has been Deleted",DGCT=0
|
|
D ^DGPATV
|
|
D LINE^DGDEATH("The date of death for the following patient has been deleted.")
|
|
D LINE^DGDEATH("")
|
|
D DEMOG^DGDEATH
|
|
D LINE^DGDEATH("")
|
|
S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
|
|
S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
|
|
S DGB=1 D ^DGBUL S X=DGDEATH
|
|
K DGCT,DGDEATH D KILL^DGPATV
|
|
;
|
|
Q
|