DGENUPL4 ;ALB/CJM,RTK,ISA,KWP,ISD/GSN,PHH,RGL,PJR,BRM,TDM,TMK,EG,BAJ,HM,JAM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;6/28/11 4:36pm
;;5.3;REGISTRATION;**147,177,232,253,327,367,377,514,451,625,673,708,688,841,842,972,952,1111**;Aug 13,1993;Build 18
;
UOBJECTS(DFN,DGPAT,DGELG,DGCDIS,DGOEIF,MSGID,ERRCOUNT,MSGS,OLDPAT,OLDELG,OLDCDIS,OLDOEIF) ;
;Used to update PATIENT, ELIGIBILITY, CATASTROPHIC
;DISABILITY, and OEF/OIF CONFLICT objects 'in memory'.
;
;Input:
; DFN - ien of record in the PATIENT file
; DGPAT - PATIENT object array (pass by reference)
; DGELG - ELIGIBILITY object array (pass by ref)
; DGCDIS - CATASTROPHIC DISABILITY object array (pass by ref)
; DGOEIF - OEF/OIF conflict object array (pass by ref)
; MSGID - message control id of the HL7 message being processed
; ERRCOUNT - count of errors (pass by ref)
; MSGS - array of messages for the site (pass by ref)
;
;Output:
; Function Value: 1 if update was successful 'in memory',
; consistency checks pass and the objects can be stored in
; the local database, 0 otherwise.
; DGPAT - PATIENT object array (pass by reference)
; DGELG - ELIGIBILITY object array (pass by ref)
; DGCDIS - CATASTROPHIC DISABILITY object array (pass by ref)
; ERRCOUNT - count of errors (pass by ref)
; MSGS - array of messages for the site (pass by ref)
; OLDPAT - patient object array as it currently exists in database before the update (pass by ref)
; OLDELG - eligibility object array as it currently exists in database before the update (pass by ref)
; OLDCDIS - catastrophically disability object array as it currently exists in database before the update (pass by ref)
; OLDOEIF - OEF/OIF conflict data as it currently exists in database before the update (pass by ref)
;
N DGPAT3,DGELG3,DGCDIS3,SUCCESS
S SUCCESS=1
D
.;first get local site's current data
.I ('$$GET^DGENPTA(DFN,.OLDPAT))!('$$GET^DGENELA(DFN,.OLDELG))!('$$GET^DGENCDA(DFN,.OLDCDIS))!('$P($$GET^DGENOEIF(DFN,.OLDOEIF,0),U,2)) D Q
..D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"UNABLE TO ACCESS PATIENT RECORD",.ERRCOUNT)
..S SUCCESS=0
.;
.;Phase II CD Consistency Checks (SRS 6.5.1.4) check VISTA against HEC
.S SUCCESS=$$CDCHECK^DGENUPL9()
.Q:'SUCCESS
.;
.;If no 'MH' ZMH segment or Z11 value is null delete VistA value.
.I ($G(DGPAT("MOH"))="")&($G(OLDPAT("MOH"))'="") S DGPAT("MOH")="@",DGPAT("MOHAWRDDATE")="@",DGPAT("MOHSTATDATE")="@",DGPAT("MOHEXEMPDATE")="@" ;DG*5.3*972 HM
.I ($G(DGELG("MOH"))="")&($G(OLDELG("MOH"))'="") S DGELG("MOH")="@",DGELG("MOHAWRDDATE")="@",DGELG("MOHSTATDATE")="@",DGELG("MOHEXEMPDATE")="@" ;DG*5.3*972 HM
.I ($G(DGPAT("MOH"))="N")&($G(OLDPAT("MOH"))'="") S DGPAT("MOH")="N",DGPAT("MOHAWRDDATE")="@",DGPAT("MOHEXEMPDATE")="@" ;DG*5.3*972 HM
.I ($G(DGELG("MOH"))="N")&($G(OLDELG("MOH"))'="") S DGELG("MOH")="N",DGELG("MOHAWRDDATE")="@",DGELG("MOHEXEMPDATE")="@" ;DG*5.3*972 HM
.I ($G(DGPAT("MOH"))="N")&($G(OLDPAT("MOH"))="") S DGPAT("MOH")="N",DGPAT("MOHAWRDDATE")="@",DGPAT("MOHEXEMPDATE")="@" ;DG*5.3*972 HM
.I ($G(DGELG("MOH"))="N")&($G(OLDELG("MOH"))="") S DGELG("MOH")="N",DGELG("MOHAWRDDATE")="@",DGELG("MOHEXEMPDATE")="@" ;DG*5.3*972 HM
.I ($G(DGPAT("MOH"))="Y")&($G(DGPAT("MOHAWRDDATE"))="") S DGPAT("MOHAWRDDATE")="@",DGPAT("MOHEXEMPDATE")="@" ;DG*5.3*972 HM
.I ($G(DGELG("MOH"))="Y")&($G(DGELG("MOHAWRDDATE"))="") S DGELG("MOHAWRDDATE")="@",DGELG("MOHEXEMPDATE")="@" ;DG*5.3*972 HM
.;
.; Don't upload Pension data if site Pension Reason='Original Award'
.; & Site Pension Effective Date <= the Z11 Pension Effective Date
.; & the Z11 does not contain a Termination Date.
.I +$G(OLDPAT("PENAREAS")),$P($G(^DG(27.18,OLDPAT("PENAREAS"),0)),U,2)="00" D
..I (OLDPAT("PENAEFDT")<($G(DGPAT("PENAEFDT"))+1)),($G(DGPAT("PENTRMDT"))<1) D
...N SUB F SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4","PILOCK","PALOCK" S DGPAT(SUB)=""
.;
.;If Z11 Pension fields are set, initialize VistA Lock fields to "@"
.N SUB F SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" I $G(DGPAT(SUB))'="" D
..S:(OLDPAT("PILOCK")'="") DGPAT("PILOCK")="@"
..S:(OLDPAT("PALOCK")'="") DGPAT("PALOCK")="@"
.;
.;If Z11 RECEIVING A VA PENSION? not null, Pension Indicator Lock=Y
.;If Z11 RECEIVING A VA PENSION? deletion, Pension Indicator Lock=@
.S:DGELG("VAPEN")'="" DGPAT("PILOCK")="Y"
.S:DGELG("VAPEN")="@" DGPAT("PILOCK")="@"
.;
.;If any Z11 Pension fields populated, Pension Indicator Lock=Y
.N SUB F SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" I $G(DGPAT(SUB))'="",$G(DGPAT(SUB))'="@" S DGPAT("PILOCK")="Y"
.;
.;If Z11 Pension Termination Reason received, Pension Award Lock=Y
.N SUB F SUB="PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4" I $G(DGPAT(SUB))'="",$G(DGPAT(SUB))'="@" S DGPAT("PALOCK")="Y"
.;
.;If Z11 Pension Award Reason='Original Award', Pension Award Lock=Y
.I +$G(DGPAT("PENAREAS")),$P($G(^DG(27.18,DGPAT("PENAREAS"),0)),U,2)="00" S DGPAT("PALOCK")="Y"
.;
.;now merge with the update
.D MERGE
.;
.;add the assumed values
.D ADD
.;
.;now do the consistency checks
.S SUCCESS=$$CHECK()
.Q:'SUCCESS
.;
.;replace input arrays with fully updated versions
.K DGPAT M DGPAT=DGPAT3
.K DGELG M DGELG=DGELG3
.K DGCDIS M DGCDIS=DGCDIS3
;
I SUCCESS D
.;
.;list of required notifications
.;
.;change in date of death
.I DGPAT("DEATH"),$P(OLDPAT("DEATH"),".")'=$P(DGPAT("DEATH"),".") D
..D ADDMSG^DGENUPL3(.MSGS,"HEC SHOWS DATE OF DEATH = "_$$FMTE^XLFDT(DGPAT("DEATH"),"1"),1)
..D ADDMSG^DGENUPL3(.MSGS,$S('OLDPAT("DEATH"):"SITE DOES NOT HAVE DATE OF DEATH",1:"SITE HAS DATE OF DEATH = "_$$FMTE^XLFDT(OLDPAT("DEATH"),"1")),1)
.;
.I OLDPAT("DEATH"),'DGPAT("DEATH") D
..D ADDMSG^DGENUPL3(.MSGS,"HEC SHOWS NO DATE OF DEATH",1)
..D ADDMSG^DGENUPL3(.MSGS,"SITE HAS DATE OF DEATH = "_$$FMTE^XLFDT(OLDPAT("DEATH"),"1"),1)
.;
.;change in POW
.I OLDELG("POW")="N",DGELG("POW")="Y" D ADDMSG^DGENUPL3(.MSGS,"POW STATUS CHANGED TO YES")
.I OLDELG("POW")="Y",DGELG("POW")="N" D ADDMSG^DGENUPL3(.MSGS,"POW STATUS CHANGED TO NO")
.;
.;SC to NSC
.I OLDELG("SC")="Y",DGELG("SC")="N" D ADDMSG^DGENUPL3(.MSGS,"VETERAN CHANGED TO NON-SERVICE CONNECTED",1)
.;
.; Change from Eligible to Ineligible
.I 'OLDPAT("INELDATE"),DGPAT("INELDATE") D ADDMSG^DGENUPL3(.MSGS,"VETERAN PREVIOUSLY ELIGIBLE FOR VA HEALTH CARE, NOW INELIGIBLE.",1)
.;
.; Check for erroneous CD deletion
.I OLDCDIS("VCD")="","@"[DGCDIS("VCD") Q ;no notification is needed
.;
.; CD Determination Changed
.I OLDCDIS("VCD")'=DGCDIS("VCD") D ADDMSG^DGENUPL3(.MSGS,"VETERANS CD EVALUATION HAS CHANGED.")
D EP^DGENUPLB
Q SUCCESS
;
ADD ;
;Description: adds computed and assumed values to the updated objects
;
;Input: DGELG3(),DGPAT3() created in the UOBJECTS procedure.
;
N SUB,TYPE,DATA
S DGELG3("ELIGENTBY")=.5
S SUB=0 F S SUB=$O(DGELG3("RATEDIS",SUB)) Q:'SUB S DGELG3("RATEDIS",SUB,"RDSC")=1
;
; Default Patient Types
D SCVET^DGENUPL3
;
; If Ineldate apply business rules
I DGPAT3("INELDATE"),DGELG3("SC")'="Y" D
.S DGPAT3("VETERAN")="N",DGPAT3("PATYPE")=$O(^DG(391,"B","NON-VETERAN (OTHER)",0))
.S DGELG3("POS")=$O(^DIC(21,"B","OTHER NON-VETERANS",0))
;
;update/set ELIGIBILITY VERIF. SOURCE field (Ineligible Project):
S DATA(.3613)=$S(DGELG3("ELIGVERIF")["VBA":"H",DGELG3("ELIGVERIF")["CEV":"H",DGELG3("ELIGVERIF")["VIVA":"H",1:"V")
;
; File data fields modified by Ineligible Business Rules
I $$UPD^DGENDBS(2,DFN,.DATA,.ERROR)
Q
;
MERGE ;
;Description: merges arrays with current patient data with the updates
; Merges DGPAT() + OLDPAT() -> DGPAT3()
; DGELG() + OLDELG() -> DGELG3()
; overlays catastrophic disability array with data from HEC
; DGCDIS() is info from HEC
;
N SUB,SUB2,LOC,HEC,NATCODE,ISOTH
M DGPAT3=OLDPAT,DGELG3=OLDELG
;Replace POW in VistA with HEC data
I '$D(DGPAT3("POWI")) S DGELG3("POW")=""
K DGCDIS3 M DGCDIS3=OLDCDIS K DGCDIS3("EXT"),DGCDIS3("PROC"),DGCDIS3("COND"),DGCDIS3("DIAG")
;
;discard MT status from local database - don't ever want to use it during upload
S DGELG3("MTSTA")=DGELG("MTSTA")
;
;patient array
S SUB=""
F S SUB=$O(DGPAT(SUB)) Q:(SUB="") I (DGPAT(SUB)'="") S DGPAT3(SUB)=$S((DGPAT(SUB)="@"):"",1:DGPAT(SUB))
;
;Allow Ineligible info deletion (Ineligible Project):
I $D(DGPAT("INELDEC")),DGPAT("INELDEC")="" S DGPAT("INELDEC")="@"
I $D(DGPAT("INELREA")),DGPAT("INELREA")="" S DGPAT("INELREA")="@"
I $D(DGPAT("INELDATE")),DGPAT("INELDATE")="" S DGPAT("INELDATE")="@"
;
;catastrophic disability array
S SUB=""
F S SUB=$O(DGCDIS(SUB)) Q:(SUB="") D
.I $D(DGCDIS(SUB))=1 I ($G(DGCDIS(SUB))'="") S DGCDIS3(SUB)=DGCDIS(SUB)
.I $D(DGCDIS(SUB))=10 D
..S SUB2=""
..F S SUB2=$O(DGCDIS(SUB,SUB2)) Q:SUB2="" D
...I ($G(DGCDIS(SUB,SUB2))'="") S DGCDIS3(SUB,SUB2)=DGCDIS(SUB,SUB2)
...I SUB="PROC" D
....N CDPROC,CDEXT,LIEN
....S CDPROC=$G(DGCDIS("PROC",SUB2))
....Q:CDPROC=""
....S CDEXT=$G(DGCDIS("EXT",SUB2,1))
....Q:CDEXT=""
....S LIEN=$O(^DGEN(27.17,CDPROC,1,"B",CDEXT,0))
....Q:LIEN=""
....S DGCDIS3("EXT",SUB2,LIEN)=CDEXT
;
;eligibility array
F S SUB=$O(DGELG(SUB)) Q:(SUB="") I ($G(DGELG(SUB))'="") S DGELG3(SUB)=$S((DGELG(SUB)="@"):"",1:DGELG(SUB))
;
;rated disabilities from HEC should replace local sites
D
.K DGELG3("RATEDIS")
.M DGELG3("RATEDIS")=DGELG("RATEDIS")
;
;primary eligibility
I (DGELG("ELIG","CODE")'="") S DGELG3("ELIG","CODE")=$S((DGELG("ELIG","CODE")="@"):"",($$NATCODE^DGENELA(DGELG("ELIG","CODE"))=$$NATCODE^DGENELA(DGELG3("ELIG","CODE"))):DGELG3("ELIG","CODE"),1:DGELG("ELIG","CODE"))
;
;patient eligibilities multiple
;delete veteran type codes not mapped to national codes sent by HEC, but leave non-veteran types and the codes where there is a match
;first find all local codes already in the patient file and the ones sent from HEC, keep in arrays LOC and HEC
S NATCODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE")) I NATCODE S HEC(NATCODE)=""
S SUB=0 F S SUB=$O(DGELG("ELIG","CODE",SUB)) Q:'SUB S NATCODE=$$NATCODE^DGENELA(SUB) I NATCODE S HEC(NATCODE)=""
S SUB=0 F S SUB=$O(DGELG3("ELIG","CODE",SUB)) Q:'SUB S NATCODE=$$NATCODE^DGENELA(SUB) I NATCODE S LOC(NATCODE)=""
;Now discard the codes in the local patient database that don't map to a national code sent by HEC, as well as HUMANIARIAN EMERGENCY code if not sent by HEC:
;Also discard EXPANDED MH CARE NON-ENROLLEE secondary eligibility if primary eligibility is something other than EXPANDED MH CARE NON-ENROLLEE
S ISOTH=($$GET1^DIQ(8,DGELG3("ELIG","CODE")_",",.01)="EXPANDED MH CARE NON-ENROLLEE") ; DG*5.3*952
S SUB=0 F S SUB=$O(DGELG3("ELIG","CODE",SUB)) Q:'SUB D
.I $P($G(^DIC(8,SUB,0)),"^",5)="Y"!($P($G(^DIC(8,SUB,0)),"^")["HUMANITARIAN EMERGENCY"),'$D(HEC($$NATCODE^DGENELA(SUB))) K DGELG3("ELIG","CODE",SUB)
.I 'ISOTH,$$GET1^DIQ(8,SUB_",",.01)="EXPANDED MH CARE NON-ENROLLEE" K DGELG3("ELIG","CODE",SUB) ; DG*5.3*952
.Q
;now add codes included in the update that the local database does not already contain
S SUB=0
F S SUB=$O(DGELG("ELIG","CODE",SUB)) Q:'SUB D
.I '$D(LOC($$NATCODE^DGENELA(SUB))) S DGELG3("ELIG","CODE",SUB)=SUB
;Agent Orange Exp. Location, use local database when upload is NULL
D AO^DGENUPL9
Q
;
CHECK() ;
;
N SUCCESS,ALIVE,ERRMSG,DGENR
S SUCCESS=1
S ERRMSG=""
;
;if upload includes date of death, check for indications that patient is alive
I DGPAT3("DEATH"),'OLDPAT("DEATH") D S:ALIVE SUCCESS=0
.;
.;determine if patient is at the moment being registered
.S ALIVE=$$IFREG^DGREG(DFN)
.;
.;check if an inpatient
.I 'ALIVE,$$INPAT^DGENPTA(DFN,DT,DT) S ALIVE=1
.;
.; DG*5.3*1111 - ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comment below modified
.;Phase II locally enrolled with enrollment date after death date and status of unverified and deferred-initial application by vamc (SRS 6.5.1.2 e)
.N CURIEN,CURENR
.S CURIEN=$$FINDCUR^DGENA(DFN)
.I CURIEN,$$GET^DGENA(CURIEN,.CURENR),CURENR("DATE")>DGPAT3("DEATH"),CURENR("STATUS")=1!(CURENR("STATUS")=14) S ALIVE=1
.;there is an indication that he patient may not be dead
.; DG*5.3*1111 - Change "REJECTED" to 'DEFERRED"
.D:ALIVE ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"LOCAL SITE VERIFY PATIENT DEATH",.ERRCOUNT),ADDMSG^DGENUPL3(.MSGS,"ELIBILITY UPLOAD CONTAINED DATE OF DEATH AND WAS DEFERRED, PLEASE VERIFY PATIENT DEATH",1),NOTIFY^DGENUPL3(.DGPAT,.MSGS)
;
;only do consistency checks on this data if it is verified
I SUCCESS,(DGELG3("ELIGSTA")="V") D
.I $$CHECK^DGENPTA1(.DGPAT3,.ERRMSG),$$CHECK^DGENELA1(.DGELG3,.DGPAT3,.DGCDIS3,.ERRMSG),$$CHECK^DGENCDA1(.DGCDIS3,.ERRMSG)
.E D
..S SUCCESS=0
..D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
Q SUCCESS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENUPL4 12939 printed Nov 22, 2024@17:53:19 Page 2
DGENUPL4 ;ALB/CJM,RTK,ISA,KWP,ISD/GSN,PHH,RGL,PJR,BRM,TDM,TMK,EG,BAJ,HM,JAM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;6/28/11 4:36pm
+1 ;;5.3;REGISTRATION;**147,177,232,253,327,367,377,514,451,625,673,708,688,841,842,972,952,1111**;Aug 13,1993;Build 18
+2 ;
UOBJECTS(DFN,DGPAT,DGELG,DGCDIS,DGOEIF,MSGID,ERRCOUNT,MSGS,OLDPAT,OLDELG,OLDCDIS,OLDOEIF) ;
+1 ;Used to update PATIENT, ELIGIBILITY, CATASTROPHIC
+2 ;DISABILITY, and OEF/OIF CONFLICT objects 'in memory'.
+3 ;
+4 ;Input:
+5 ; DFN - ien of record in the PATIENT file
+6 ; DGPAT - PATIENT object array (pass by reference)
+7 ; DGELG - ELIGIBILITY object array (pass by ref)
+8 ; DGCDIS - CATASTROPHIC DISABILITY object array (pass by ref)
+9 ; DGOEIF - OEF/OIF conflict object array (pass by ref)
+10 ; MSGID - message control id of the HL7 message being processed
+11 ; ERRCOUNT - count of errors (pass by ref)
+12 ; MSGS - array of messages for the site (pass by ref)
+13 ;
+14 ;Output:
+15 ; Function Value: 1 if update was successful 'in memory',
+16 ; consistency checks pass and the objects can be stored in
+17 ; the local database, 0 otherwise.
+18 ; DGPAT - PATIENT object array (pass by reference)
+19 ; DGELG - ELIGIBILITY object array (pass by ref)
+20 ; DGCDIS - CATASTROPHIC DISABILITY object array (pass by ref)
+21 ; ERRCOUNT - count of errors (pass by ref)
+22 ; MSGS - array of messages for the site (pass by ref)
+23 ; OLDPAT - patient object array as it currently exists in database before the update (pass by ref)
+24 ; OLDELG - eligibility object array as it currently exists in database before the update (pass by ref)
+25 ; OLDCDIS - catastrophically disability object array as it currently exists in database before the update (pass by ref)
+26 ; OLDOEIF - OEF/OIF conflict data as it currently exists in database before the update (pass by ref)
+27 ;
+28 NEW DGPAT3,DGELG3,DGCDIS3,SUCCESS
+29 SET SUCCESS=1
+30 Begin DoDot:1
+31 ;first get local site's current data
+32 IF ('$$GET^DGENPTA(DFN,.OLDPAT))!('$$GET^DGENELA(DFN,.OLDELG))!('$$GET^DGENCDA(DFN,.OLDCDIS))!('$PIECE($$GET^DGENOEIF(DFN,.OLDOEIF,0),U,2))
Begin DoDot:2
+33 DO ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"UNABLE TO ACCESS PATIENT RECORD",.ERRCOUNT)
+34 SET SUCCESS=0
End DoDot:2
QUIT
+35 ;
+36 ;Phase II CD Consistency Checks (SRS 6.5.1.4) check VISTA against HEC
+37 SET SUCCESS=$$CDCHECK^DGENUPL9()
+38 if 'SUCCESS
QUIT
+39 ;
+40 ;If no 'MH' ZMH segment or Z11 value is null delete VistA value.
+41 ;DG*5.3*972 HM
IF ($GET(DGPAT("MOH"))="")&($GET(OLDPAT("MOH"))'="")
SET DGPAT("MOH")="@"
SET DGPAT("MOHAWRDDATE")="@"
SET DGPAT("MOHSTATDATE")="@"
SET DGPAT("MOHEXEMPDATE")="@"
+42 ;DG*5.3*972 HM
IF ($GET(DGELG("MOH"))="")&($GET(OLDELG("MOH"))'="")
SET DGELG("MOH")="@"
SET DGELG("MOHAWRDDATE")="@"
SET DGELG("MOHSTATDATE")="@"
SET DGELG("MOHEXEMPDATE")="@"
+43 ;DG*5.3*972 HM
IF ($GET(DGPAT("MOH"))="N")&($GET(OLDPAT("MOH"))'="")
SET DGPAT("MOH")="N"
SET DGPAT("MOHAWRDDATE")="@"
SET DGPAT("MOHEXEMPDATE")="@"
+44 ;DG*5.3*972 HM
IF ($GET(DGELG("MOH"))="N")&($GET(OLDELG("MOH"))'="")
SET DGELG("MOH")="N"
SET DGELG("MOHAWRDDATE")="@"
SET DGELG("MOHEXEMPDATE")="@"
+45 ;DG*5.3*972 HM
IF ($GET(DGPAT("MOH"))="N")&($GET(OLDPAT("MOH"))="")
SET DGPAT("MOH")="N"
SET DGPAT("MOHAWRDDATE")="@"
SET DGPAT("MOHEXEMPDATE")="@"
+46 ;DG*5.3*972 HM
IF ($GET(DGELG("MOH"))="N")&($GET(OLDELG("MOH"))="")
SET DGELG("MOH")="N"
SET DGELG("MOHAWRDDATE")="@"
SET DGELG("MOHEXEMPDATE")="@"
+47 ;DG*5.3*972 HM
IF ($GET(DGPAT("MOH"))="Y")&($GET(DGPAT("MOHAWRDDATE"))="")
SET DGPAT("MOHAWRDDATE")="@"
SET DGPAT("MOHEXEMPDATE")="@"
+48 ;DG*5.3*972 HM
IF ($GET(DGELG("MOH"))="Y")&($GET(DGELG("MOHAWRDDATE"))="")
SET DGELG("MOHAWRDDATE")="@"
SET DGELG("MOHEXEMPDATE")="@"
+49 ;
+50 ; Don't upload Pension data if site Pension Reason='Original Award'
+51 ; & Site Pension Effective Date <= the Z11 Pension Effective Date
+52 ; & the Z11 does not contain a Termination Date.
+53 IF +$GET(OLDPAT("PENAREAS"))
IF $PIECE($GET(^DG(27.18,OLDPAT("PENAREAS"),0)),U,2)="00"
Begin DoDot:2
+54 IF (OLDPAT("PENAEFDT")<($GET(DGPAT("PENAEFDT"))+1))
IF ($GET(DGPAT("PENTRMDT"))<1)
Begin DoDot:3
+55 NEW SUB
FOR SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4","PILOCK","PALOCK"
SET DGPAT(SUB)=""
End DoDot:3
End DoDot:2
+56 ;
+57 ;If Z11 Pension fields are set, initialize VistA Lock fields to "@"
+58 NEW SUB
FOR SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4"
IF $GET(DGPAT(SUB))'=""
Begin DoDot:2
+59 if (OLDPAT("PILOCK")'="")
SET DGPAT("PILOCK")="@"
+60 if (OLDPAT("PALOCK")'="")
SET DGPAT("PALOCK")="@"
End DoDot:2
+61 ;
+62 ;If Z11 RECEIVING A VA PENSION? not null, Pension Indicator Lock=Y
+63 ;If Z11 RECEIVING A VA PENSION? deletion, Pension Indicator Lock=@
+64 if DGELG("VAPEN")'=""
SET DGPAT("PILOCK")="Y"
+65 if DGELG("VAPEN")="@"
SET DGPAT("PILOCK")="@"
+66 ;
+67 ;If any Z11 Pension fields populated, Pension Indicator Lock=Y
+68 NEW SUB
FOR SUB="PENAEFDT","PENTRMDT","PENAREAS","PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4"
IF $GET(DGPAT(SUB))'=""
IF $GET(DGPAT(SUB))'="@"
SET DGPAT("PILOCK")="Y"
+69 ;
+70 ;If Z11 Pension Termination Reason received, Pension Award Lock=Y
+71 NEW SUB
FOR SUB="PENTRMR1","PENTRMR2","PENTRMR3","PENTRMR4"
IF $GET(DGPAT(SUB))'=""
IF $GET(DGPAT(SUB))'="@"
SET DGPAT("PALOCK")="Y"
+72 ;
+73 ;If Z11 Pension Award Reason='Original Award', Pension Award Lock=Y
+74 IF +$GET(DGPAT("PENAREAS"))
IF $PIECE($GET(^DG(27.18,DGPAT("PENAREAS"),0)),U,2)="00"
SET DGPAT("PALOCK")="Y"
+75 ;
+76 ;now merge with the update
+77 DO MERGE
+78 ;
+79 ;add the assumed values
+80 DO ADD
+81 ;
+82 ;now do the consistency checks
+83 SET SUCCESS=$$CHECK()
+84 if 'SUCCESS
QUIT
+85 ;
+86 ;replace input arrays with fully updated versions
+87 KILL DGPAT
MERGE DGPAT=DGPAT3
+88 KILL DGELG
MERGE DGELG=DGELG3
+89 KILL DGCDIS
MERGE DGCDIS=DGCDIS3
End DoDot:1
+90 ;
+91 IF SUCCESS
Begin DoDot:1
+92 ;
+93 ;list of required notifications
+94 ;
+95 ;change in date of death
+96 IF DGPAT("DEATH")
IF $PIECE(OLDPAT("DEATH"),".")'=$PIECE(DGPAT("DEATH"),".")
Begin DoDot:2
+97 DO ADDMSG^DGENUPL3(.MSGS,"HEC SHOWS DATE OF DEATH = "_$$FMTE^XLFDT(DGPAT("DEATH"),"1"),1)
+98 DO ADDMSG^DGENUPL3(.MSGS,$SELECT('OLDPAT("DEATH"):"SITE DOES NOT HAVE DATE OF DEATH",1:"SITE HAS DATE OF DEATH = "_$$FMTE^XLFDT(OLDPAT("DEATH"),"1")),1)
End DoDot:2
+99 ;
+100 IF OLDPAT("DEATH")
IF 'DGPAT("DEATH")
Begin DoDot:2
+101 DO ADDMSG^DGENUPL3(.MSGS,"HEC SHOWS NO DATE OF DEATH",1)
+102 DO ADDMSG^DGENUPL3(.MSGS,"SITE HAS DATE OF DEATH = "_$$FMTE^XLFDT(OLDPAT("DEATH"),"1"),1)
End DoDot:2
+103 ;
+104 ;change in POW
+105 IF OLDELG("POW")="N"
IF DGELG("POW")="Y"
DO ADDMSG^DGENUPL3(.MSGS,"POW STATUS CHANGED TO YES")
+106 IF OLDELG("POW")="Y"
IF DGELG("POW")="N"
DO ADDMSG^DGENUPL3(.MSGS,"POW STATUS CHANGED TO NO")
+107 ;
+108 ;SC to NSC
+109 IF OLDELG("SC")="Y"
IF DGELG("SC")="N"
DO ADDMSG^DGENUPL3(.MSGS,"VETERAN CHANGED TO NON-SERVICE CONNECTED",1)
+110 ;
+111 ; Change from Eligible to Ineligible
+112 IF 'OLDPAT("INELDATE")
IF DGPAT("INELDATE")
DO ADDMSG^DGENUPL3(.MSGS,"VETERAN PREVIOUSLY ELIGIBLE FOR VA HEALTH CARE, NOW INELIGIBLE.",1)
+113 ;
+114 ; Check for erroneous CD deletion
+115 ;no notification is needed
IF OLDCDIS("VCD")=""
IF "@"[DGCDIS("VCD")
QUIT
+116 ;
+117 ; CD Determination Changed
+118 IF OLDCDIS("VCD")'=DGCDIS("VCD")
DO ADDMSG^DGENUPL3(.MSGS,"VETERANS CD EVALUATION HAS CHANGED.")
End DoDot:1
+119 DO EP^DGENUPLB
+120 QUIT SUCCESS
+121 ;
ADD ;
+1 ;Description: adds computed and assumed values to the updated objects
+2 ;
+3 ;Input: DGELG3(),DGPAT3() created in the UOBJECTS procedure.
+4 ;
+5 NEW SUB,TYPE,DATA
+6 SET DGELG3("ELIGENTBY")=.5
+7 SET SUB=0
FOR
SET SUB=$ORDER(DGELG3("RATEDIS",SUB))
if 'SUB
QUIT
SET DGELG3("RATEDIS",SUB,"RDSC")=1
+8 ;
+9 ; Default Patient Types
+10 DO SCVET^DGENUPL3
+11 ;
+12 ; If Ineldate apply business rules
+13 IF DGPAT3("INELDATE")
IF DGELG3("SC")'="Y"
Begin DoDot:1
+14 SET DGPAT3("VETERAN")="N"
SET DGPAT3("PATYPE")=$ORDER(^DG(391,"B","NON-VETERAN (OTHER)",0))
+15 SET DGELG3("POS")=$ORDER(^DIC(21,"B","OTHER NON-VETERANS",0))
End DoDot:1
+16 ;
+17 ;update/set ELIGIBILITY VERIF. SOURCE field (Ineligible Project):
+18 SET DATA(.3613)=$SELECT(DGELG3("ELIGVERIF")["VBA":"H",DGELG3("ELIGVERIF")["CEV":"H",DGELG3("ELIGVERIF")["VIVA":"H",1:"V")
+19 ;
+20 ; File data fields modified by Ineligible Business Rules
+21 IF $$UPD^DGENDBS(2,DFN,.DATA,.ERROR)
+22 QUIT
+23 ;
MERGE ;
+1 ;Description: merges arrays with current patient data with the updates
+2 ; Merges DGPAT() + OLDPAT() -> DGPAT3()
+3 ; DGELG() + OLDELG() -> DGELG3()
+4 ; overlays catastrophic disability array with data from HEC
+5 ; DGCDIS() is info from HEC
+6 ;
+7 NEW SUB,SUB2,LOC,HEC,NATCODE,ISOTH
+8 MERGE DGPAT3=OLDPAT,DGELG3=OLDELG
+9 ;Replace POW in VistA with HEC data
+10 IF '$DATA(DGPAT3("POWI"))
SET DGELG3("POW")=""
+11 KILL DGCDIS3
MERGE DGCDIS3=OLDCDIS
KILL DGCDIS3("EXT"),DGCDIS3("PROC"),DGCDIS3("COND"),DGCDIS3("DIAG")
+12 ;
+13 ;discard MT status from local database - don't ever want to use it during upload
+14 SET DGELG3("MTSTA")=DGELG("MTSTA")
+15 ;
+16 ;patient array
+17 SET SUB=""
+18 FOR
SET SUB=$ORDER(DGPAT(SUB))
if (SUB="")
QUIT
IF (DGPAT(SUB)'="")
SET DGPAT3(SUB)=$SELECT((DGPAT(SUB)="@"):"",1:DGPAT(SUB))
+19 ;
+20 ;Allow Ineligible info deletion (Ineligible Project):
+21 IF $DATA(DGPAT("INELDEC"))
IF DGPAT("INELDEC")=""
SET DGPAT("INELDEC")="@"
+22 IF $DATA(DGPAT("INELREA"))
IF DGPAT("INELREA")=""
SET DGPAT("INELREA")="@"
+23 IF $DATA(DGPAT("INELDATE"))
IF DGPAT("INELDATE")=""
SET DGPAT("INELDATE")="@"
+24 ;
+25 ;catastrophic disability array
+26 SET SUB=""
+27 FOR
SET SUB=$ORDER(DGCDIS(SUB))
if (SUB="")
QUIT
Begin DoDot:1
+28 IF $DATA(DGCDIS(SUB))=1
IF ($GET(DGCDIS(SUB))'="")
SET DGCDIS3(SUB)=DGCDIS(SUB)
+29 IF $DATA(DGCDIS(SUB))=10
Begin DoDot:2
+30 SET SUB2=""
+31 FOR
SET SUB2=$ORDER(DGCDIS(SUB,SUB2))
if SUB2=""
QUIT
Begin DoDot:3
+32 IF ($GET(DGCDIS(SUB,SUB2))'="")
SET DGCDIS3(SUB,SUB2)=DGCDIS(SUB,SUB2)
+33 IF SUB="PROC"
Begin DoDot:4
+34 NEW CDPROC,CDEXT,LIEN
+35 SET CDPROC=$GET(DGCDIS("PROC",SUB2))
+36 if CDPROC=""
QUIT
+37 SET CDEXT=$GET(DGCDIS("EXT",SUB2,1))
+38 if CDEXT=""
QUIT
+39 SET LIEN=$ORDER(^DGEN(27.17,CDPROC,1,"B",CDEXT,0))
+40 if LIEN=""
QUIT
+41 SET DGCDIS3("EXT",SUB2,LIEN)=CDEXT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;
+43 ;eligibility array
+44 FOR
SET SUB=$ORDER(DGELG(SUB))
if (SUB="")
QUIT
IF ($GET(DGELG(SUB))'="")
SET DGELG3(SUB)=$SELECT((DGELG(SUB)="@"):"",1:DGELG(SUB))
+45 ;
+46 ;rated disabilities from HEC should replace local sites
+47 Begin DoDot:1
+48 KILL DGELG3("RATEDIS")
+49 MERGE DGELG3("RATEDIS")=DGELG("RATEDIS")
End DoDot:1
+50 ;
+51 ;primary eligibility
+52 IF (DGELG("ELIG","CODE")'="")
SET DGELG3("ELIG","CODE")=$SELECT((DGELG("ELIG","CODE")="@"):"",($$NATCODE^DGENELA(DGELG("ELIG","CODE"))=$$NATCODE^DGENELA(DGELG3("ELIG","CODE"))):DGELG3("ELIG","CODE"),1:DGELG("ELIG","CODE"))
+53 ;
+54 ;patient eligibilities multiple
+55 ;delete veteran type codes not mapped to national codes sent by HEC, but leave non-veteran types and the codes where there is a match
+56 ;first find all local codes already in the patient file and the ones sent from HEC, keep in arrays LOC and HEC
+57 SET NATCODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
IF NATCODE
SET HEC(NATCODE)=""
+58 SET SUB=0
FOR
SET SUB=$ORDER(DGELG("ELIG","CODE",SUB))
if 'SUB
QUIT
SET NATCODE=$$NATCODE^DGENELA(SUB)
IF NATCODE
SET HEC(NATCODE)=""
+59 SET SUB=0
FOR
SET SUB=$ORDER(DGELG3("ELIG","CODE",SUB))
if 'SUB
QUIT
SET NATCODE=$$NATCODE^DGENELA(SUB)
IF NATCODE
SET LOC(NATCODE)=""
+60 ;Now discard the codes in the local patient database that don't map to a national code sent by HEC, as well as HUMANIARIAN EMERGENCY code if not sent by HEC:
+61 ;Also discard EXPANDED MH CARE NON-ENROLLEE secondary eligibility if primary eligibility is something other than EXPANDED MH CARE NON-ENROLLEE
+62 ; DG*5.3*952
SET ISOTH=($$GET1^DIQ(8,DGELG3("ELIG","CODE")_",",.01)="EXPANDED MH CARE NON-ENROLLEE")
+63 SET SUB=0
FOR
SET SUB=$ORDER(DGELG3("ELIG","CODE",SUB))
if 'SUB
QUIT
Begin DoDot:1
+64 IF $PIECE($GET(^DIC(8,SUB,0)),"^",5)="Y"!($PIECE($GET(^DIC(8,SUB,0)),"^")["HUMANITARIAN EMERGENCY")
IF '$DATA(HEC($$NATCODE^DGENELA(SUB)))
KILL DGELG3("ELIG","CODE",SUB)
+65 ; DG*5.3*952
IF 'ISOTH
IF $$GET1^DIQ(8,SUB_",",.01)="EXPANDED MH CARE NON-ENROLLEE"
KILL DGELG3("ELIG","CODE",SUB)
+66 QUIT
End DoDot:1
+67 ;now add codes included in the update that the local database does not already contain
+68 SET SUB=0
+69 FOR
SET SUB=$ORDER(DGELG("ELIG","CODE",SUB))
if 'SUB
QUIT
Begin DoDot:1
+70 IF '$DATA(LOC($$NATCODE^DGENELA(SUB)))
SET DGELG3("ELIG","CODE",SUB)=SUB
End DoDot:1
+71 ;Agent Orange Exp. Location, use local database when upload is NULL
+72 DO AO^DGENUPL9
+73 QUIT
+74 ;
CHECK() ;
+1 ;
+2 NEW SUCCESS,ALIVE,ERRMSG,DGENR
+3 SET SUCCESS=1
+4 SET ERRMSG=""
+5 ;
+6 ;if upload includes date of death, check for indications that patient is alive
+7 IF DGPAT3("DEATH")
IF 'OLDPAT("DEATH")
Begin DoDot:1
+8 ;
+9 ;determine if patient is at the moment being registered
+10 SET ALIVE=$$IFREG^DGREG(DFN)
+11 ;
+12 ;check if an inpatient
+13 IF 'ALIVE
IF $$INPAT^DGENPTA(DFN,DT,DT)
SET ALIVE=1
+14 ;
+15 ; DG*5.3*1111 - ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comment below modified
+16 ;Phase II locally enrolled with enrollment date after death date and status of unverified and deferred-initial application by vamc (SRS 6.5.1.2 e)
+17 NEW CURIEN,CURENR
+18 SET CURIEN=$$FINDCUR^DGENA(DFN)
+19 IF CURIEN
IF $$GET^DGENA(CURIEN,.CURENR)
IF CURENR("DATE")>DGPAT3("DEATH")
IF CURENR("STATUS")=1!(CURENR("STATUS")=14)
SET ALIVE=1
+20 ;there is an indication that he patient may not be dead
+21 ; DG*5.3*1111 - Change "REJECTED" to 'DEFERRED"
+22 if ALIVE
DO ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"LOCAL SITE VERIFY PATIENT DEATH",.ERRCOUNT)
DO ADDMSG^DGENUPL3(.MSGS,"ELIBILITY UPLOAD CONTAINED DATE OF DEATH AND WAS DEFERRED, PLEASE VERIFY PATIENT DEATH",1)
DO NOTIFY^DGENUPL3(.DGPAT,.MSGS)
End DoDot:1
if ALIVE
SET SUCCESS=0
+23 ;
+24 ;only do consistency checks on this data if it is verified
+25 IF SUCCESS
IF (DGELG3("ELIGSTA")="V")
Begin DoDot:1
+26 IF $$CHECK^DGENPTA1(.DGPAT3,.ERRMSG)
IF $$CHECK^DGENELA1(.DGELG3,.DGPAT3,.DGCDIS3,.ERRMSG)
IF $$CHECK^DGENCDA1(.DGCDIS3,.ERRMSG)
+27 IF '$TEST
Begin DoDot:2
+28 SET SUCCESS=0
+29 DO ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT)
End DoDot:2
End DoDot:1
+30 QUIT SUCCESS
