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

IVMLDEMD.m

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