IVMLDEMD ;ALB/PJR/PHH/BLD - IVM DEMOGRAPHIC UPLOAD FILE DATE OF DEATH FIELDS ; 7/20/05 9:22am
;;2.0;INCOME VERIFICATION MATCH;**102,108,131,148**; 21-OCT-94;Build 34
;;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
;
;added for IVM*2*131
I $$CKINPAT^IVMLDEMB($G(DFN)) D G DODQ
.N DODREJDT
.; DEMBULL^IVMPREC6 already set up the IVMTEXT array so we don't want
.; to send it if the message is to be deleted
.; EN^IVMPREC6 will send a message if IVMCNTR
.I $G(IVMCNTR),$G(XMSUB)["IVM - DEMOGRAPHIC UPLOAD for ",$G(IVMTEXT(1))["Updated demographic information has been received from the",$G(IVMTEXT(2))["Health Eligibilty Center. Please select the 'Demographic Upload'" S IVMCNTR=0 K IVMTEXT
.D AUTOREJ^IVMLDEMB,SNDBULL^IVMLDEMB ;bld 3/15/2011 for Date of Death Changes IVM*2*148
I $P(IVMSEG,"^",9)="""""" D CKAUTO I CKDEL D AUTODEL,DEM5,BULL(+^IVM(301.5,IVMDA2,0)) G DODQ
I $P(IVMSEG,"^",31)'=3,$P($G(^DPT(DFN,.35)),"^",1)="" D
.D CKAUTO I CKDEL D AUTODEL,DEM5,BULL(+^IVM(301.5,IVMDA2,0)) ;G DODQ
.I CKADD D CKDUZ,AUTOADD,DEM5 ;G DODQ
I $P(IVMSEG,"^",31)=3,$P($G(^DPT(DFN,.35)),"^",1)'="" D
.D CKAUTO I CKDEL D AUTODEL,DEM5,BULL(+^IVM(301.5,IVMDA2,0)) ;G DODQ
.I CKADD D CKDUZ,AUTOADD,DEM5 G DODQ
I $P(IVMSEG,"^",31)=3,$P($G(^DPT(DFN,.35)),"^",1)="" D
.D CKDUZ,AUTOADD,DEM5
;
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)
..;
..; 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 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
.D NOW^%DTC
.D UPLOAD(+DFN,.355,.5)
.D UPLOAD(+DFN,.354,%)
.N DA,DIE,DR
.S DIE="^DPT(",DA=DFN,DR=".352////@"
.D ^DIE
Q
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMLDEMD 10168 printed Dec 13, 2024@02:01:53 Page 2
IVMLDEMD ;ALB/PJR/PHH/BLD - IVM DEMOGRAPHIC UPLOAD FILE DATE OF DEATH FIELDS ; 7/20/05 9:22am
+1 ;;2.0;INCOME VERIFICATION MATCH;**102,108,131,148**; 21-OCT-94;Build 34
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
DOD(DFN,IVMDA2,IVMDA1,IVMDA) ; function to upload Date of Death
+1 ; fields and return a flag
+2 ;
+3 ; Input: DFN - as patient IEN
+4 ; IVMDA2 - pointer to case record in (#301.5) file
+5 ; IVMDA1 - pointer to PID msg in (#301.501) sub-file
+6 ; IVMDA - pointer to record in (#301.511) sub-file
+7 ;
+8 ; Output: IVMFLAG - 1 if a Date of Death Field
+9 ; 0 if not a Date of Death field
+10 ;
+11 ;
+12 NEW IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,DODFIELD,DELDATA,CKDEL,DGDAUTO
+13 ;
+14 ; - initialize flags
+15 SET IVMFLAG=0
+16 ;
+17 ; - check for required parameters
+18 IF '$GET(DFN)!('$GET(IVMDA))!('$GET(IVMDA1))!'($GET(IVMDA2))
GOTO DODQ
+19 ;
+20 ; - get pointer to (#301.92) file from (#301.511) sub-file
+21 SET IVMPTR=+$GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0))
if 'IVMPTR
GOTO DODQ
+22 ;
ASK ;;
+1 DO CKDEL
IF CKDEL
GOTO DODDEL
+2 WRITE !
SET DIR("A")="Do you wish to proceed with this action"
+3 SET DIR("A",1)="You have selected to update a Date of Death field."
+4 SET DIR("A",2)="All Date of Death Fields will be uploaded."
+5 SET DIR("?")="Enter 'YES' to continue or 'NO' to abort."
+6 SET DIR(0)="Y"
SET DIR("B")="NO"
+7 DO ^DIR
KILL DIR
+8 SET IVMFLAG=1
if 'Y
GOTO DODQ
+9 WRITE !,"Filing Date of Death fields... "
+10 ;
+11 ;
LOOP ; - loop through DOD fields
+1 SET (DGDAUTO,IVMDODUP)=1
+2 FOR DODFIELD="ZPD09","ZPD31","ZPD32"
Begin DoDot:1
+3 SET IVMI=$ORDER(^IVM(301.92,"C",DODFIELD,""))
IF IVMI=""
QUIT
+4 SET IVMJ=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
if IVMJ']""
QUIT
Begin DoDot:2
+5 ;
+6 ; - check for data node in (#301.511) sub-file
+7 SET IVMNODE=$GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
if '(+IVMNODE)
QUIT
+8 IF DODFIELD="ZPD31"
IF $PIECE(IVMNODE,"^",2)=""!($PIECE(IVMNODE,"^",2)<1)!($PIECE(IVMNODE,"^",2)>9)
SET $PIECE(IVMNODE,"^",2)="@"
+9 IF DODFIELD'="ZPD31"
IF $PIECE(IVMNODE,"^",2)=""!($EXTRACT($PIECE(IVMNODE,"^",2),1,7)'?1.7N)
SET $PIECE(IVMNODE,"^",2)="@"
+10 ;
+11 ; load Date of Death field rec'd from IVM into DHCP (#2) file
+12 DO UPLOAD(+DFN,$PIECE($GET(^IVM(301.92,+IVMNODE,0)),"^",5),$PIECE(IVMNODE,"^",2))
SET IVMFLAG=1
+13 ;
+14 ; - remove entry from (#301.511) sub-file
+15 DO DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
End DoDot:2
End DoDot:1
+16 ;
+17 IF IVMFLAG
Begin DoDot:1
+18 DO UPLOAD(+DFN,.355,$SELECT($GET(DUZ):DUZ,1:.5))
End DoDot:1
WRITE "completed.",!
+19 DO DISCHRGE^DGDEATH
DO XFR^DGDEATH
+20 KILL IVMDODUP
+21 ;
+22 SET VALMBCK="R"
+23 ;
+24 GOTO DODQ
+25 ;
DODDEL ;
+1 WRITE !
SET DIR("A")="Do you wish to proceed with this action"
+2 SET DIR("A",1)="You have selected to update a DELETION of a Date of Death field."
+3 SET DIR("A",2)="All Date of Death Fields will be deleted."
+4 SET DIR("?")="Enter 'YES' to continue or 'NO' to abort."
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
+6 DO ^DIR
KILL DIR
+7 SET IVMFLAG=1
if 'Y
GOTO DODQ
+8 WRITE !,"Filing Date of Death deletions... "
+9 FOR DODFIELD="ZPD09","ZPD31","ZPD32"
Begin DoDot:1
+10 SET IVMI=$ORDER(^IVM(301.92,"C",DODFIELD,""))
IF IVMI=""
QUIT
+11 SET IVMJ=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
if IVMJ']""
QUIT
+12 ;
+13 ; - check for data node in (#301.511) sub-file
+14 SET IVMNODE=$GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
+15 if '(+IVMNODE)
QUIT
+16 ;
+17 ; load Date of Death deletion rec'd from IVM into DHCP (#2) file
+18 IF DODFIELD="ZPD09"
DO UPLOAD(+DFN,.351,"@")
+19 ;
+20 ; - remove entry from (#301.511) sub-file
+21 DO DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
End DoDot:1
+22 ;
+23 IF IVMFLAG
Begin DoDot:1
+24 DO UPLOAD(+DFN,.355,.5)
End DoDot:1
WRITE "completed.",!
+25 ;
+26 SET VALMBCK="R"
+27 ;
+28 GOTO DODQ
CKDEL SET CKDEL=0
+1 SET IVMI=$ORDER(^IVM(301.92,"C","ZPD09",""))
IF IVMI=""
QUIT
+2 SET IVMJ=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
+3 IF IVMJ']""
QUIT
+4 ;
+5 ; - check for data node in (#301.511) sub-file
+6 SET IVMNODE=$GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
+7 if '(+IVMNODE)!($PIECE(IVMNODE,"^",2)']"")
QUIT
+8 ;
+9 IF $PIECE(IVMNODE,"^",2)=""""""
SET CKDEL=1
+10 QUIT
AUTODOD(DFN) ;
+1 ; function to automatically upload Date of Death
+2 ; fields and return a flag
+3 ;
+4 ; Input: DFN - as patient IEN
+5 ;
+6 ; Output: IVMFLAG - 1 if a Date of Death Field
+7 ; 0 if not a Date of Death field
+8 ;
+9 NEW IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,DODFIELD
+10 NEW DELDATA,CKDEL,CKADD,CKDUZ,IVMDA1,IVMDA2,DGDAUTO,IVMENT4
+11 ;
+12 ; - initialize flags
+13 SET (IVMFLAG,CKDEL,CKADD,CKDUZ)=0
SET IVMENT4=999999999
+14 ;
+15 ; - check for required parameters
+16 SET IVMDA2=$GET(IVM3015)
+17 IF 'IVMDA2
GOTO DODQ
+18 SET IVMDA1=$ORDER(^HL(771.3,"B","PID",""))
+19 SET IVMDA1=$ORDER(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
+20 IF 'IVMDA1
GOTO DODQ
+21 ;
+22 ;added for IVM*2*131
+23 IF $$CKINPAT^IVMLDEMB($GET(DFN))
Begin DoDot:1
+24 NEW DODREJDT
+25 ; DEMBULL^IVMPREC6 already set up the IVMTEXT array so we don't want
+26 ; to send it if the message is to be deleted
+27 ; EN^IVMPREC6 will send a message if IVMCNTR
+28 IF $GET(IVMCNTR)
IF $GET(XMSUB)["IVM - DEMOGRAPHIC UPLOAD for "
IF $GET(IVMTEXT(1))["Updated demographic information has been received from the"
IF $GET(IVMTEXT(2))["Health Eligibilty Center. Please select the 'Demographic Upload'"
SET IVMCNTR=0
KILL IVMTEXT
+29 ;bld 3/15/2011 for Date of Death Changes IVM*2*148
DO AUTOREJ^IVMLDEMB
DO SNDBULL^IVMLDEMB
End DoDot:1
GOTO DODQ
+30 IF $PIECE(IVMSEG,"^",9)=""""""
DO CKAUTO
IF CKDEL
DO AUTODEL
DO DEM5
DO BULL(+^IVM(301.5,IVMDA2,0))
GOTO DODQ
+31 IF $PIECE(IVMSEG,"^",31)'=3
IF $PIECE($GET(^DPT(DFN,.35)),"^",1)=""
Begin DoDot:1
+32 ;G DODQ
DO CKAUTO
IF CKDEL
DO AUTODEL
DO DEM5
DO BULL(+^IVM(301.5,IVMDA2,0))
+33 ;G DODQ
IF CKADD
DO CKDUZ
DO AUTOADD
DO DEM5
End DoDot:1
+34 IF $PIECE(IVMSEG,"^",31)=3
IF $PIECE($GET(^DPT(DFN,.35)),"^",1)'=""
Begin DoDot:1
+35 ;G DODQ
DO CKAUTO
IF CKDEL
DO AUTODEL
DO DEM5
DO BULL(+^IVM(301.5,IVMDA2,0))
+36 IF CKADD
DO CKDUZ
DO AUTOADD
DO DEM5
GOTO DODQ
End DoDot:1
+37 IF $PIECE(IVMSEG,"^",31)=3
IF $PIECE($GET(^DPT(DFN,.35)),"^",1)=""
Begin DoDot:1
+38 DO CKDUZ
DO AUTOADD
DO DEM5
End DoDot:1
+39 ;
+40 GOTO DODQ
+41 ;
AUTOADD ;
+1 SET DGDAUTO=1
+2 ; - loop through DOD fields
+3 FOR DODFIELD="ZPD09","ZPD31","ZPD32"
Begin DoDot:1
+4 SET IVMI=$ORDER(^IVM(301.92,"C",DODFIELD,""))
IF IVMI=""
QUIT
+5 SET IVMJ=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
if IVMJ']""
QUIT
Begin DoDot:2
+6 ;
+7 ; - check for data node in (#301.511) sub-file
+8 SET IVMNODE=$GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
if '(+IVMNODE)
QUIT
+9 ;
+10 ; load Date of Death field rec'd from IVM into DHCP (#2) file
+11 DO UPLOAD(+DFN,$PIECE($GET(^IVM(301.92,+IVMNODE,0)),"^",5),$PIECE(IVMNODE,"^",2))
SET IVMFLAG=1
+12 ; - remove entry from (#301.511) sub-file
+13 DO DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
End DoDot:2
End DoDot:1
+14 ;
+15 IF IVMFLAG
DO UPLOAD(+DFN,.355,$SELECT(CKDUZ:CKDUZ,1:.5))
+16 DO CLEAN(IVMDA2)
+17 QUIT
AUTODEL ;
+1 NEW DFNDOD,DODMPI
SET DFNDOD=0
IF $PIECE($GET(^DPT(+DFN,.35)),U)>0
SET DFNDOD=1
+2 FOR DODFIELD="ZPD09","ZPD31","ZPD32"
Begin DoDot:1
+3 SET IVMI=$ORDER(^IVM(301.92,"C",DODFIELD,""))
IF IVMI=""
QUIT
+4 SET IVMJ=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
if IVMJ']""
QUIT
+5 ; - check for data node in (#301.511) sub-file
+6 SET IVMNODE=$GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
+7 if '(+IVMNODE)
QUIT
+8 ; load Date of Death deletion rec'd from IVM into DHCP (#2) file
+9 IF DODFIELD="ZPD09"
IF DFNDOD
DO UPLOAD(+DFN,.351,"@")
SET DODMPI=$$A31^MPIFA31B(+DFN)
SET IVMFLAG=1
+10 ; - remove entry from (#301.511) sub-file
+11 DO DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
End DoDot:1
+12 ;
+13 IF IVMFLAG
Begin DoDot:1
+14 DO NOW^%DTC
+15 DO UPLOAD(+DFN,.355,.5)
+16 DO UPLOAD(+DFN,.354,%)
+17 NEW DA,DIE,DR
+18 SET DIE="^DPT("
SET DA=DFN
SET DR=".352////@"
+19 DO ^DIE
End DoDot:1
+20 QUIT
+21 DO CLEAN(IVMDA2)
+22 QUIT
DEM5 ;
+1 IF '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0)
IF '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1)
Begin DoDot:1
+2 ; Dummy up name parameter
DO DELETE^IVMLDEM5(IVMDA2,IVMDA1," ")
End DoDot:1
+3 QUIT
CKAUTO SET (CKDEL,CKADD)=0
+1 SET IVMI=$ORDER(^IVM(301.92,"C","ZPD09",""))
IF IVMI=""
QUIT
+2 SET IVMJ=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
+3 IF IVMJ']""
QUIT
+4 ;
+5 ; - check for data node in (#301.511) sub-file
+6 SET IVMNODE=$GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
+7 if '(+IVMNODE)!($PIECE(IVMNODE,"^",2)']"")
QUIT
+8 ;
+9 IF $PIECE(IVMNODE,"^",2)=""""""
SET CKDEL=1
QUIT
+10 IF $PIECE(IVMNODE,"^",2)=$PIECE($GET(^DPT(DFN,.35)),"^",1)
SET CKADD=1
+11 QUIT
CKDUZ ; Check to preserve DUZ for "Last Edited By"
+1 SET IVMI=$ORDER(^IVM(301.92,"C","ZPD32",""))
IF IVMI=""
QUIT
+2 SET IVMJ=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
+3 IF IVMJ']""
QUIT
+4 ;
+5 ; - check for data node in (#301.511) sub-file
+6 SET IVMNODE=$GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
+7 if '(+IVMNODE)!($PIECE(IVMNODE,"^",2)']"")
QUIT
+8 ;
+9 IF $PIECE(IVMNODE,"^",2)=$PIECE($GET(^DPT(DFN,.35)),"^",4)
Begin DoDot:1
+10 SET CKDUZ=$PIECE($GET(^DPT(DFN,.35)),"^",5)
End DoDot:1
+11 QUIT
UPLOAD(DFN,IVMFIELD,IVMVALUE) ; - file Date of Death fields received from IVM
+1 ; Input: DFN - as patient IEN
+2 ; IVMFIELD - as the field number to be updated
+3 ; IVMVALUE - as the value of the field
+4 ;
+5 ; Output: None
+6 ;
+7 NEW DA,DIE,DR
+8 SET DIE="^DPT("
SET DA=DFN
SET DR=IVMFIELD_"////^S X=IVMVALUE"
+9 DO ^DIE
+10 QUIT
+11 ;
DODQ ; - return --> 1 if uploadable field is a Date of Death field
+1 ; --> 0 if nothing uploadable
+2 ;
+3 IF IVMFLAG
DO RESET^IVMLDEMU
+4 QUIT IVMFLAG
+5 ;
CLEAN(IVMI) ;
+1 ; Remove any Date of Death related entries from IVM UPLOAD DEM
+2 NEW IVMJ,IVMN,IVM92,OTHFLG
+3 SET IVMJ=0
FOR
SET IVMJ=$ORDER(^IVM(301.5,"ASEG","PID",IVMI,IVMJ))
if 'IVMJ
QUIT
Begin DoDot:1
+4 IF '$DATA(^IVM(301.5,IVMI,"IN",IVMJ))
DO REMASEG(IVMI,IVMJ)
QUIT
+5 SET (OTHFLG,IVMN)=0
FOR
SET IVMN=$ORDER(^IVM(301.5,IVMI,"IN",IVMJ,"DEM",IVMN))
if 'IVMN
QUIT
Begin DoDot:2
+6 SET IVM92=$PIECE(^IVM(301.5,IVMI,"IN",IVMJ,"DEM",IVMN,0),U)
+7 IF "^15^36^37^"[(U_IVM92_U)
DO REM511(IVMI,IVMJ,IVMN)
+8 IF "^15^36^37^"'[(U_IVM92_U)
SET OTHFLG=1
End DoDot:2
+9 IF 'OTHFLG
DO REM501(IVMI,IVMJ)
End DoDot:1
+10 QUIT
+11 ;
REM501(IVMI,IVMJ) ;
+1 ; Delete 301.501 entry to remove from ASEG x-ref
+2 NEW DA,DIE,DR
+3 SET DA=IVMJ
SET DA(1)=IVMI
+4 SET DIE="^IVM(301.5,"_DA(1)_",""IN"","
+5 SET DR=".02////@"
DO ^DIE
+6 QUIT
+7 ;
REM511(IVMI,IVMJ,IVMN) ;
+1 ; Delete 301.511 entry to remove from IVM UPLOAD DEM
+2 NEW DA,DIK
+3 SET DA(1)=IVMJ
SET DA(2)=IVMI
SET DA=IVMN
+4 SET DIK="^IVM(301.5,"_DA(2)_",""IN"","_DA(1)_",""DEM"","
+5 DO ^DIK
+6 QUIT
+7 ;
REMASEG(IVMI,IVMJ) ;
+1 ; Delete invalid ASEG x-ref entries
+2 KILL ^IVM(301.5,"ASEG","PID",IVMI,IVMJ)
+3 QUIT
BULL(DFN) ; Date of Death Deletion Bulletin
+1 IF '$DATA(^DPT(DFN,0))
QUIT
+2 IF '(+$GET(^DPT(DFN,.35)))
QUIT
+3 ;
+4 NEW DGDEATH,DGB,DGPCMM,XMSUB,X
+5 SET DGDEATH=+$GET(^DPT(DFN,.35))
SET XMSUB="Patient Death has been Deleted"
SET DGCT=0
+6 DO ^DGPATV
+7 DO LINE^DGDEATH("The date of death for the following patient has been deleted.")
+8 DO LINE^DGDEATH("")
+9 DO DEMOG^DGDEATH
+10 DO LINE^DGDEATH("")
+11 ;creates xmy array
SET DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0)
+12 SET DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
+13 SET DGB=1
DO ^DGBUL
SET X=DGDEATH
+14 KILL DGCT,DGDEATH
DO KILL^DGPATV
+15 ;
+16 QUIT
