DGENA3 ;ALB/CJM,ISA/KWP,RTK,TDM,LBD,PHH,PJR,TDM,KUM - Enrollment API - Consistency check ;03/23/20 12:41pm
;;5.3;Registration;**232,306,327,367,417,454,456,491,514,451,808,993,1027**;Aug 13,1993;Build 70
;Per VHA Directive 2004-038, this routine should not be modified.
;
;CHECKand TESTVAL moved from DGENA1
CHECK(DGENR,DGPAT,ERRMSG) ;
;Phase II consistency checks do not include INACTIVE(3),REJECTED(4),SUSPENDED(5),EXPIRED(8),PENDING(9) enrollment statuses. References to these statuses have been removed.
;Description: Does validation checks on the enrollment contained in the
; DGENR array.
;Input:
; DGENR - this local array contains an enrollment and should be passed
; by reference
; DGPAT - this local array contains the patient object, it is optional
; If not passed,the database is referenced. (pass by reference)
;Output:
; Function Value - returns 1 if all validation checks passed, 0
; otherwise
; ERRMSG - if the consistency checks fail, an error msg is returned (pass by reference)
N VALID,DGELGSUB,SUB,PRIGRP
S VALID=0
S ERRMSG=""
D ;drops out of block if invalid condition found
.I '$G(DGENR("DFN")) S ERRMSG="PATIENT NOT FOUND IN DATABASE" Q
.I '$D(^DPT(DGENR("DFN"),0)) S ERRMSG="PATIENT NOT FOUND IN DATABASE" Q
.;if it points to a prior record, the DFN must match
.I DGENR("PRIORREC") D Q:(ERRMSG'="")
..N DFN
..S DFN=$P($G(^DGEN(27.11,DGENR("PRIORREC"),0)),"^",2)
..I DFN,DFN'=DGENR("DFN") S ERRMSG="PATIENT'S PRIOR ENROLLMENT BELONGS TO ANOTHER PATIENT"
.;check for required fields
.F SUB="APP","SOURCE","STATUS","EFFDATE" I $G(DGENR(SUB))="" S ERRMSG="ENROLLMENT FIELD "_$$GET1^DID(27.11,$$FIELD^DGENU(SUB),"","LABEL")_" IS MISSING" Q
.Q:(ERRMSG'="")
.;if the enrollment priority is present, it must be correct
.M DGELGSUB=DGENR("ELIG")
.;Phase II if the enrollment priority is present it must be correct based on the eligibility factors (SRS 6.5.1.2 d)
.; ** temporarily commented out for HVE Phase II and III **
.;I DGENR("PRIORITY") D Q:(ERRMSG'="")
.;.S PRIGRP=$$PRI^DGENELA4(DGENR("ELIG","CODE"),.DGELGSUB,DGENR("DATE"),$G(DGENR("APP")))
.;.;check priority
.;.I DGENR("STATUS")=6 Q ; do not check priority for deceased
.;.I DGENR("PRIORITY")'=$P(PRIGRP,"^") D Q
.;..I $G(DGCDIS("VCD"))'="" Q
.;..S ERRMSG="ENROLLMENT PRIORITY IS INCONSISTENT WITH ELIGIBILITY DATA - PRIORITY SHOULD BE "_$P(PRIGRP,"^")_$$EXTERNAL^DILFD(27.11,.12,"F",$P(PRIGRP,"^",2))
.;.;check subgroup if priority = 7 or 8
.;.Q:DGENR("PRIORITY")<7
.;.; sub-priority "e" can be overridden with "a" at HEC
.;.I "^1^1^5^5^1^"[("^"_DGENR("SUBGRP")_"^"_$P(PRIGRP,"^",2)_"^") Q
.;.; sub-priority "g" can be overridden with "c" at HEC
.;.I "^3^3^7^7^3^"[("^"_DGENR("SUBGRP")_"^"_$P(PRIGRP,"^",2)_"^") Q
.;.S ERRMSG="ENROLLMENT PRIORITY IS INCONSISTENT WITH ELIGIBILITY DATA - PRIORITY SHOULD BE "_$P(PRIGRP,"^")_$$EXTERNAL^DILFD(27.11,.12,"F",$P(PRIGRP,"^",2))
.; end of temporary comments
.;
.;Phase II require priority if status is VERIFIED(2),REJECTED-INITIAL APP(14),REJECTED-FISCAL YEAR(11),REJECTED-MIDCYCLE(12),REJECTED-STOP ENROLL(13),REJECTED BELOW EGT THRESHOLD(SRS 6.5.1.2 b)
.I (DGENR("STATUS")=2)!(DGENR("STATUS")=14)!(DGENR("STATUS")=11)!(DGENR("STATUS")=12)!(DGENR("STATUS")=13)!(DGENR("STATUS")=22),DGENR("PRIORITY")="" D Q
..S ERRMSG="ENROLLMENT PRIORITY IS REQUIRED WITH ENROLLMENT STATUSES: VERIFIED,REJECTED-INITIAL APPLICATION BY VAMC,REJECTED-FISCAL YEAR,REJECTED-MID-CYCLE,REJECTED-STOP NEW ENROLLMENTS,REJECTED-BELOW EGT"
.;Phase II require enrollment date when status is verified(2)(SRS 6.5.1.2 d)
.I DGENR("STATUS")=2,DGENR("DATE")="" S ERRMSG="ENROLLMENT DATE IS REQUIRED WHEN STATUS IS VERIFIED" Q
.;Phase II if enrollment date present with statuses other than verified then veteran must be previously VERIFIED(2) and enrolled (SRS 6.5.1.2 d)
.N CURIEN S CURIEN=$$FINDCUR^DGENA(DGENR("DFN"))
.I DGENR("DATE"),DGENR("DATE")'="@",DGENR("STATUS")'=2,'CURIEN S ERRMSG="ENROLLMENT DATE IS PRESENT WITH STATUS OTHER THAN VERIFIED AND THE VETERAN WAS NOT PREVIOUSLY ENROLLED." Q
.I DGENR("DATE"),DGENR("DATE")'="@",DGENR("STATUS")'=2,CURIEN,$P($G(^DGEN(27.11,CURIEN,0)),"^",4)'=2 S ERRMSG="ENROLLMENT DATE IS PRESENT WITH STATUS OTHER THAN VERIFIED WAS PREVIOUSLY ENROLLED BUT THE PREVIOUS STATUS WAS NOT VERIFIED." Q
.;if status is not CANCELED/DECLINED, the REASON field should be ""
.I (DGENR("STATUS")'=7),DGENR("REASON") S ERRMSG="ENROLLMENT STATUS OF OTHER THAN CANCELED/DECLINED IS INCONSISTENT WITH REASON CANCELED/DECLINED" Q
.;if not an eligible vet, enrollment must not have status of VERIFIED, or UNVERIFIED
.;if status is CANCELED/DECLINED, then reason is required
.I (DGENR("STATUS")=7),'DGENR("REASON") S ERRMSG="STATUS OF CANCELED/DECLINED REQUIRES REASON" Q
.;if status is DECEASED and Date of Death is missing, send bulletin
.; This bulletin has been disabled. DG*5.3*808
.;I DGENR("STATUS")=6 D
.;.I $D(DGPAT),'DGPAT("DEATH") D BULLETIN
.;.I '$D(DGPAT),'$$DEATH^DGENPTA(DGENR("DFN")) D BULLETIN
.Q:(ERRMSG'="")
.;certain statuses not allowed for a dead patient
.I $D(DGPAT),DGPAT("DEATH"),(DGENR("STATUS")=1)!(DGENR("STATUS")=2) S ERRMSG="ENROLLMENT STATUS OF VERIFIED OR UNVERIFIED NOT ALLOWED FOR A DECEASED PATIENT" Q
.I '$D(DGPAT),$$DEATH^DGENPTA(DGENR("DFN")),(DGENR("STATUS")=1)!(DGENR("STATUS")=2) S ERRMSG="ENROLLMENT STATUS OF VERIFIED OR UNVERIFIED NOT ALLOWED FOR A DECEASED PATIENT" Q
.;all the field values must be valid
.S SUB="" F S SUB=$O(DGENR(SUB)) Q:((ERRMSG'="")!(SUB="")) D
..;DG*5.3*1027 - Skip Validity check for Application Date if ES transmits Blank
..I SUB="APP",$G(DGOAPP)="" Q
..;
..I SUB'="ELIG",(SUB'="DATE"),(SUB'="FACREC") I '$$TESTVAL(SUB,DGENR(SUB)) S ERRMSG="ENROLLMENT FIELD "_$$GET1^DID(27.11,$$FIELD^DGENU(SUB),"","LABEL")_" IS NOT VALID"
.Q:(ERRMSG'="")
.S SUB="" F S SUB=$O(DGENR("ELIG",SUB)) Q:((ERRMSG'="")!(SUB="")) D
..I '$$TESTVAL(SUB,DGENR("ELIG",SUB)) S ERRMSG="ENROLLMENT FIELD "_$$GET1^DID(27.11,$$FIELD^DGENU(SUB),"","LABEL")_" IS NOT VALID"
.;if this point is reached it's valid
.S VALID=1
Q VALID
TESTVAL(SUB,VAL) ;
;Description: returns 1 if VAL is a valid value for subscript SUB
N DISPLAY,FIELD,RESULT,VALID
S VALID=1
I (VAL'="") D
.S FIELD=$$FIELD^DGENU(SUB)
.;if there is no external value then it is not valid
.S DISPLAY=$$EXTERNAL^DILFD(27.11,FIELD,"F",VAL)
.I (DISPLAY="") S VALID=0 Q
.I $$GET1^DID(27.11,FIELD,"","TYPE")'="POINTER" D
..D CHK^DIE(27.11,FIELD,,VAL,.RESULT) I RESULT="^" S VALID=0 Q
Q VALID
BULLETIN ; Status vs. Date of Death Data Discrepancy Bulletin
; This bulletin has been disabled. DG*5.3*808
Q
N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ
S DGMGRP=$O(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT",""))
Q:'DGMGRP
D XMY^DGMTUTL(DGMGRP,0,1)
S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^DPT(DFN,0)),"^",9)
S XMTEXT="DGBULL("
S XMSUB="STATUS VS. DATE OF DEATH DATA DISCREPANCY"
S DGLINE=0
D LINE^DGEN("Patient: "_DGNAME,.DGLINE)
D LINE^DGEN("SSN: "_DGSSN,.DGLINE)
D LINE^DGEN("",.DGLINE)
D LINE^DGEN("This Veteran's Enrollment Status is Deceased,",.DGLINE)
D LINE^DGEN("however, there is no Date of Death on file for VistA.",.DGLINE)
D LINE^DGEN("Actions you should take:",.DGLINE)
D LINE^DGEN("",.DGLINE)
D LINE^DGEN("- Add Date of Death Information in VistA, or",.DGLINE)
D LINE^DGEN("",.DGLINE)
D LINE^DGEN("- Contact the HEC to remove an erroneous Date of Death.",.DGLINE)
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENA3 7591 printed Apr 09, 2024@21:43:48 Page 2
DGENA3 ;ALB/CJM,ISA/KWP,RTK,TDM,LBD,PHH,PJR,TDM,KUM - Enrollment API - Consistency check ;03/23/20 12:41pm
+1 ;;5.3;Registration;**232,306,327,367,417,454,456,491,514,451,808,993,1027**;Aug 13,1993;Build 70
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;CHECKand TESTVAL moved from DGENA1
CHECK(DGENR,DGPAT,ERRMSG) ;
+1 ;Phase II consistency checks do not include INACTIVE(3),REJECTED(4),SUSPENDED(5),EXPIRED(8),PENDING(9) enrollment statuses. References to these statuses have been removed.
+2 ;Description: Does validation checks on the enrollment contained in the
+3 ; DGENR array.
+4 ;Input:
+5 ; DGENR - this local array contains an enrollment and should be passed
+6 ; by reference
+7 ; DGPAT - this local array contains the patient object, it is optional
+8 ; If not passed,the database is referenced. (pass by reference)
+9 ;Output:
+10 ; Function Value - returns 1 if all validation checks passed, 0
+11 ; otherwise
+12 ; ERRMSG - if the consistency checks fail, an error msg is returned (pass by reference)
+13 NEW VALID,DGELGSUB,SUB,PRIGRP
+14 SET VALID=0
+15 SET ERRMSG=""
+16 ;drops out of block if invalid condition found
Begin DoDot:1
+17 IF '$GET(DGENR("DFN"))
SET ERRMSG="PATIENT NOT FOUND IN DATABASE"
QUIT
+18 IF '$DATA(^DPT(DGENR("DFN"),0))
SET ERRMSG="PATIENT NOT FOUND IN DATABASE"
QUIT
+19 ;if it points to a prior record, the DFN must match
+20 IF DGENR("PRIORREC")
Begin DoDot:2
+21 NEW DFN
+22 SET DFN=$PIECE($GET(^DGEN(27.11,DGENR("PRIORREC"),0)),"^",2)
+23 IF DFN
IF DFN'=DGENR("DFN")
SET ERRMSG="PATIENT'S PRIOR ENROLLMENT BELONGS TO ANOTHER PATIENT"
End DoDot:2
if (ERRMSG'="")
QUIT
+24 ;check for required fields
+25 FOR SUB="APP","SOURCE","STATUS","EFFDATE"
IF $GET(DGENR(SUB))=""
SET ERRMSG="ENROLLMENT FIELD "_$$GET1^DID(27.11,$$FIELD^DGENU(SUB),"","LABEL")_" IS MISSING"
QUIT
+26 if (ERRMSG'="")
QUIT
+27 ;if the enrollment priority is present, it must be correct
+28 MERGE DGELGSUB=DGENR("ELIG")
+29 ;Phase II if the enrollment priority is present it must be correct based on the eligibility factors (SRS 6.5.1.2 d)
+30 ; ** temporarily commented out for HVE Phase II and III **
+31 ;I DGENR("PRIORITY") D Q:(ERRMSG'="")
+32 ;.S PRIGRP=$$PRI^DGENELA4(DGENR("ELIG","CODE"),.DGELGSUB,DGENR("DATE"),$G(DGENR("APP")))
+33 ;.;check priority
+34 ;.I DGENR("STATUS")=6 Q ; do not check priority for deceased
+35 ;.I DGENR("PRIORITY")'=$P(PRIGRP,"^") D Q
+36 ;..I $G(DGCDIS("VCD"))'="" Q
+37 ;..S ERRMSG="ENROLLMENT PRIORITY IS INCONSISTENT WITH ELIGIBILITY DATA - PRIORITY SHOULD BE "_$P(PRIGRP,"^")_$$EXTERNAL^DILFD(27.11,.12,"F",$P(PRIGRP,"^",2))
+38 ;.;check subgroup if priority = 7 or 8
+39 ;.Q:DGENR("PRIORITY")<7
+40 ;.; sub-priority "e" can be overridden with "a" at HEC
+41 ;.I "^1^1^5^5^1^"[("^"_DGENR("SUBGRP")_"^"_$P(PRIGRP,"^",2)_"^") Q
+42 ;.; sub-priority "g" can be overridden with "c" at HEC
+43 ;.I "^3^3^7^7^3^"[("^"_DGENR("SUBGRP")_"^"_$P(PRIGRP,"^",2)_"^") Q
+44 ;.S ERRMSG="ENROLLMENT PRIORITY IS INCONSISTENT WITH ELIGIBILITY DATA - PRIORITY SHOULD BE "_$P(PRIGRP,"^")_$$EXTERNAL^DILFD(27.11,.12,"F",$P(PRIGRP,"^",2))
+45 ; end of temporary comments
+46 ;
+47 ;Phase II require priority if status is VERIFIED(2),REJECTED-INITIAL APP(14),REJECTED-FISCAL YEAR(11),REJECTED-MIDCYCLE(12),REJECTED-STOP ENROLL(13),REJECTED BELOW EGT THRESHOLD(SRS 6.5.1.2 b)
+48 IF (DGENR("STATUS")=2)!(DGENR("STATUS")=14)!(DGENR("STATUS")=11)!(DGENR("STATUS")=12)!(DGENR("STATUS")=13)!(DGENR("STATUS")=22)
IF DGENR("PRIORITY")=""
Begin DoDot:2
+49 SET ERRMSG="ENROLLMENT PRIORITY IS REQUIRED WITH ENROLLMENT STATUSES: VERIFIED,REJECTED-INITIAL APPLICATION BY VAMC,REJECTED-FISCAL YEAR,REJECTED-MID-CYCLE,REJECTED-STOP NEW ENROLLMENTS,REJECTED-BELOW EGT"
End DoDot:2
QUIT
+50 ;Phase II require enrollment date when status is verified(2)(SRS 6.5.1.2 d)
+51 IF DGENR("STATUS")=2
IF DGENR("DATE")=""
SET ERRMSG="ENROLLMENT DATE IS REQUIRED WHEN STATUS IS VERIFIED"
QUIT
+52 ;Phase II if enrollment date present with statuses other than verified then veteran must be previously VERIFIED(2) and enrolled (SRS 6.5.1.2 d)
+53 NEW CURIEN
SET CURIEN=$$FINDCUR^DGENA(DGENR("DFN"))
+54 IF DGENR("DATE")
IF DGENR("DATE")'="@"
IF DGENR("STATUS")'=2
IF 'CURIEN
SET ERRMSG="ENROLLMENT DATE IS PRESENT WITH STATUS OTHER THAN VERIFIED AND THE VETERAN WAS NOT PREVIOUSLY ENROLLED."
QUIT
+55 IF DGENR("DATE")
IF DGENR("DATE")'="@"
IF DGENR("STATUS")'=2
IF CURIEN
IF $PIECE($GET(^DGEN(27.11,CURIEN,0)),"^",4)'=2
SET ERRMSG="ENROLLMENT DATE IS PRESENT WITH STATUS OTHER THAN VERIFIED WAS PREVIOUSLY ENROLLED BUT THE PREVIOUS STATUS WAS NOT VERIFIED."
QUIT
+56 ;if status is not CANCELED/DECLINED, the REASON field should be ""
+57 IF (DGENR("STATUS")'=7)
IF DGENR("REASON")
SET ERRMSG="ENROLLMENT STATUS OF OTHER THAN CANCELED/DECLINED IS INCONSISTENT WITH REASON CANCELED/DECLINED"
QUIT
+58 ;if not an eligible vet, enrollment must not have status of VERIFIED, or UNVERIFIED
+59 ;if status is CANCELED/DECLINED, then reason is required
+60 IF (DGENR("STATUS")=7)
IF 'DGENR("REASON")
SET ERRMSG="STATUS OF CANCELED/DECLINED REQUIRES REASON"
QUIT
+61 ;if status is DECEASED and Date of Death is missing, send bulletin
+62 ; This bulletin has been disabled. DG*5.3*808
+63 ;I DGENR("STATUS")=6 D
+64 ;.I $D(DGPAT),'DGPAT("DEATH") D BULLETIN
+65 ;.I '$D(DGPAT),'$$DEATH^DGENPTA(DGENR("DFN")) D BULLETIN
+66 if (ERRMSG'="")
QUIT
+67 ;certain statuses not allowed for a dead patient
+68 IF $DATA(DGPAT)
IF DGPAT("DEATH")
IF (DGENR("STATUS")=1)!(DGENR("STATUS")=2)
SET ERRMSG="ENROLLMENT STATUS OF VERIFIED OR UNVERIFIED NOT ALLOWED FOR A DECEASED PATIENT"
QUIT
+69 IF '$DATA(DGPAT)
IF $$DEATH^DGENPTA(DGENR("DFN"))
IF (DGENR("STATUS")=1)!(DGENR("STATUS")=2)
SET ERRMSG="ENROLLMENT STATUS OF VERIFIED OR UNVERIFIED NOT ALLOWED FOR A DECEASED PATIENT"
QUIT
+70 ;all the field values must be valid
+71 SET SUB=""
FOR
SET SUB=$ORDER(DGENR(SUB))
if ((ERRMSG'="")!(SUB=""))
QUIT
Begin DoDot:2
+72 ;DG*5.3*1027 - Skip Validity check for Application Date if ES transmits Blank
+73 IF SUB="APP"
IF $GET(DGOAPP)=""
QUIT
+74 ;
+75 IF SUB'="ELIG"
IF (SUB'="DATE")
IF (SUB'="FACREC")
IF '$$TESTVAL(SUB,DGENR(SUB))
SET ERRMSG="ENROLLMENT FIELD "_$$GET1^DID(27.11,$$FIELD^DGENU(SUB),"","LABEL")_" IS NOT VALID"
End DoDot:2
+76 if (ERRMSG'="")
QUIT
+77 SET SUB=""
FOR
SET SUB=$ORDER(DGENR("ELIG",SUB))
if ((ERRMSG'="")!(SUB=""))
QUIT
Begin DoDot:2
+78 IF '$$TESTVAL(SUB,DGENR("ELIG",SUB))
SET ERRMSG="ENROLLMENT FIELD "_$$GET1^DID(27.11,$$FIELD^DGENU(SUB),"","LABEL")_" IS NOT VALID"
End DoDot:2
+79 ;if this point is reached it's valid
+80 SET VALID=1
End DoDot:1
+81 QUIT VALID
TESTVAL(SUB,VAL) ;
+1 ;Description: returns 1 if VAL is a valid value for subscript SUB
+2 NEW DISPLAY,FIELD,RESULT,VALID
+3 SET VALID=1
+4 IF (VAL'="")
Begin DoDot:1
+5 SET FIELD=$$FIELD^DGENU(SUB)
+6 ;if there is no external value then it is not valid
+7 SET DISPLAY=$$EXTERNAL^DILFD(27.11,FIELD,"F",VAL)
+8 IF (DISPLAY="")
SET VALID=0
QUIT
+9 IF $$GET1^DID(27.11,FIELD,"","TYPE")'="POINTER"
Begin DoDot:2
+10 DO CHK^DIE(27.11,FIELD,,VAL,.RESULT)
IF RESULT="^"
SET VALID=0
QUIT
End DoDot:2
End DoDot:1
+11 QUIT VALID
BULLETIN ; Status vs. Date of Death Data Discrepancy Bulletin
+1 ; This bulletin has been disabled. DG*5.3*808
+2 QUIT
+3 NEW DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ
+4 SET DGMGRP=$ORDER(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT",""))
+5 if 'DGMGRP
QUIT
+6 DO XMY^DGMTUTL(DGMGRP,0,1)
+7 SET DGNAME=$PIECE($GET(^DPT(DFN,0)),"^")
SET DGSSN=$PIECE($GET(^DPT(DFN,0)),"^",9)
+8 SET XMTEXT="DGBULL("
+9 SET XMSUB="STATUS VS. DATE OF DEATH DATA DISCREPANCY"
+10 SET DGLINE=0
+11 DO LINE^DGEN("Patient: "_DGNAME,.DGLINE)
+12 DO LINE^DGEN("SSN: "_DGSSN,.DGLINE)
+13 DO LINE^DGEN("",.DGLINE)
+14 DO LINE^DGEN("This Veteran's Enrollment Status is Deceased,",.DGLINE)
+15 DO LINE^DGEN("however, there is no Date of Death on file for VistA.",.DGLINE)
+16 DO LINE^DGEN("Actions you should take:",.DGLINE)
+17 DO LINE^DGEN("",.DGLINE)
+18 DO LINE^DGEN("- Add Date of Death Information in VistA, or",.DGLINE)
+19 DO LINE^DGEN("",.DGLINE)
+20 DO LINE^DGEN("- Contact the HEC to remove an erroneous Date of Death.",.DGLINE)
+21 DO ^XMD
+22 QUIT
