DGENA6 ;ALB/CJM,ISA,KWP,RTK,LBD,CKN,RN,JAM - Enrollment API to create enrollment record; 04/24/03 ; 8/31/05 2:44pm
;;5.3;Registration;**232,327,417,491,513,672,940,993,1014,1045,1111**;Aug 13, 1993;Build 18
;
;CREATE line tag moved from DGENA in DG*5.3*232.;MM
;
CREATE(DFN,APP,EFFDATE,REASON,REMARKS,DGENR,ENRDATE,END,DGENRYN) ; DG*5.3*993 Added 9th parameter DGENRYN
;Description: Creates a local enrollment as a local array.
;Input :
; DFN- Patient IEN
; APP - the Enrollment Application Date to use
; EFFDATE - the Effective Date, if NULL assume the same as the
; Enrollment Date
; REASON - used to create an enrollment with CANCELLED/DECLINED status,
; pass in the code for REASON CANCELED/DECLINED
; REMARKS - if creating an enrollment with CANCELLED/DECLINED status,
; and the reason is can optionally pass in textual remarks for
; CANCELED/DECLINED REMARKS
; ENRDATE - the Enrollment Date to use (optional)
; END - the Enrollment End Date to use (optional)
; DGENRYN - (Optional) ENROLL Y/N question for registration 0=NO 1=YES
;Output:
; Function Value - returns 1 if successful, 0 otherwise
; DGENR - a local array where the enrollment object will be stored,
; pass by reference
;
K DGENR
S DGENR="",DGENRYN=$G(DGENRYN)
N DGELGSUB,PRIORITY,DEATH,PRIGRP,DODUPD,DGSTUS,DGNOW,DGEIEN,DGENFLG,DGREG
S DGREG=1 ;DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans.
S DGEIEN=$$FINDCUR^DGENA(DFN)
I DGEIEN S DGENFLG=$$GET1^DIQ(27.11,DGEIEN_",",.14,"I")
;S DGNOW=$$NOW^XLFDT()
;Re-Enrollment - var PRIGRP contains priority and subgroup
S PRIGRP=$$PRIORITY^DGENELA4(DFN,,.DGELGSUB,$G(ENRDATE),$G(APP),$G(DGENRYN)) ;DG*5.3*993 Added 6th parameter DGENRYN
S PRIORITY=$P(PRIGRP,"^") ; Re-Enrollment - Priority is first piece
S DGENR("APP")=$G(APP)
S DGENR("DATE")=$G(ENRDATE)
S DGENR("END")=$G(END)
S DGENR("DFN")=DFN
S DGENR("SOURCE")=1
I $G(DGENRYN)=0,$G(DGENR("STATUS"))'=6 S DGENR("STATUS")=25
I $G(DGENFLG)=0,$G(DGENR("STATUS"))'=6 S DGENR("STATUS")=25
I ($G(DGENFLG)=0)!($G(DGENRYN)=0) S DGREG=0 ;DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans.
D ;drops out of block when status is determined
.I $G(REASON) D Q
..S DGENR("STATUS")=7,DGENR("REMARKS")=$G(REMARKS),DGENR("REASON")=REASON ;CANCELED/DECLINED
.E S DGENR("REMARKS")="",DGENR("REASON")=""
.S DEATH=$$DEATH^DGENPTA(DFN)
.I DEATH D Q
..S DGENR("STATUS")=6 ;DECEASED
..S DGENR("END")=DEATH
..S DODUPD=$P($G(^DPT(DFN,.35)),"^",4) ;Get Date of Death last updated date
..;S EFFDATE=DEATH ;Removed - DG*5.3*672
..S EFFDATE=$S($G(DODUPD)'="":DODUPD,1:DT) ;DG*5.3*672
..;Find patient's current enrollment record
..N DGENRIEN,DGENRC
..S DGENRIEN=$$FINDCUR^DGENA(DFN)
..I DGENRIEN S:$G(DGENRYN)="" DGENRYN=$$GET1^DIQ(27.11,DGENRIEN_",",.14,"I") ;DG*5.3*993 Added REGISTRATION ONLY
..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date
.I DGREG,'$$VET^DGENPTA(DFN) D Q ;NOT ELIGIBLE ; DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans.
..N DGPAT,DGENRIEN,DGENRC
..S DGENR("STATUS")=20 ;new status for Ineligible Project
..;Find patient's current enrollment record
..S DGENRIEN=$$FINDCUR^DGENA(DFN)
..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date
..;Phase II The TESTVAL was moved from DGENA1 to DGENA3 (SRS 6.5.2.1)
..;if vet has an Ineligible Date then the Effective Date should be the later of the Ineligible Date or App Date
..I $$GET^DGENPTA(DFN,.DGENPTA),DGENPTA("INELDATE"),$$TESTVAL^DGENA3("EFFDATE",DGENPTA("INELDATE")),DGENRC=1 S EFFDATE=$G(DGENPTA("INELDATE"))
..I '$G(EFFDATE) S EFFDATE=$G(APP)
..;If currently enrolled, set end date = ineligible date
..I DGENRC=1 S DGENR("END")=$G(DGENPTA("INELDATE"))
..;If not currently enrolled or no ineligible date, set end date = application date
..I '$G(DGENR("END")) S DGENR("END")=$G(APP)
.;Determine preliminary enrollment status based on enrollment group threshold
.;Get enrollment group threshold
.N DGEGTIEN,DGEGT,DGENRC,DGENRIEN
.S DGEGTIEN=$$FINDCUR^DGENEGT
.S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
.; DG*5.3*1111 - All ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comments below modified to reflect this.
.;If patient's enrollment status not above enrollment group threshold
.;set status to DEFERRED: INITIAL APPLICATION BY VAMC
.I $G(PRIORITY)'="",'$$ABOVE2^DGENEGT1(DFN,$G(APP),PRIORITY,$P(PRIGRP,U,2)) D Q
..;Find patient's current enrollment record
..S DGENRIEN=$$FINDCUR^DGENA(DFN)
..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date
..S DGENR("END")=$G(APP) ;enrollment end date = application date
..S EFFDATE=$G(APP) ; effective date = application date
..S DGENR("STATUS")=14 ;DEFERRED; INITIAL APPLICATION BY VAMC
.S DGENR("STATUS")=1 Q ;UNVERIFIED
S DGENR("FACREC")=$$INST^DGENU()
S DGENR("PRIORITY")=PRIORITY
;Phase II add subgroup (SRS 6.4)
S DGENR("SUBGRP")=$P(PRIGRP,"^",2)
S DGENR("EFFDATE")=$S($G(EFFDATE):EFFDATE,$G(ENRDATE):$G(ENRDATE),1:$G(APP))
S DGENR("USER")=$G(DUZ)
S DGENR("DATETIME")=$$NOW^XLFDT ;Moved to top of the routine DG*5.3*672
S DGENR("PRIORREC")=""
S DGENR("RCODE")="" ;DJE field added with DG*5.3*940 - Closed Application - RM#867186
;Next line: DG*5.3*993 New fields for decoupling
; DG*5.3*1045 Set Registration Only Status when Ineligible Date is blank
N DGINELIG,DGENPTA
I $$GET^DGENPTA(DFN,.DGENPTA) S DGINELIG=$G(DGENPTA("INELDATE"))
I $G(DGENRYN)=0,$G(DGINELIG)="",$G(DGENR("STATUS"))'=6,$G(DGENR("STATUS"))'=20 S DGENR("STATUS")=25
I $G(DGENFLG)=0,$G(DGINELIG)="",$G(DGENR("STATUS"))'=6,$G(DGENR("STATUS"))'=20 S DGENR("STATUS")=25
S DGENR("PTAPPLIED")=DGENRYN,DGENR("REGREA")=$G(DGENRRSN),DGENR("REGDATE")=$G(DGENRODT),DGENR("REGSRC")=$G(DGENSRCE)
M DGENR("ELIG")=DGELGSUB
;
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENA6 6178 printed Dec 13, 2024@02:42:22 Page 2
DGENA6 ;ALB/CJM,ISA,KWP,RTK,LBD,CKN,RN,JAM - Enrollment API to create enrollment record; 04/24/03 ; 8/31/05 2:44pm
+1 ;;5.3;Registration;**232,327,417,491,513,672,940,993,1014,1045,1111**;Aug 13, 1993;Build 18
+2 ;
+3 ;CREATE line tag moved from DGENA in DG*5.3*232.;MM
+4 ;
CREATE(DFN,APP,EFFDATE,REASON,REMARKS,DGENR,ENRDATE,END,DGENRYN) ; DG*5.3*993 Added 9th parameter DGENRYN
+1 ;Description: Creates a local enrollment as a local array.
+2 ;Input :
+3 ; DFN- Patient IEN
+4 ; APP - the Enrollment Application Date to use
+5 ; EFFDATE - the Effective Date, if NULL assume the same as the
+6 ; Enrollment Date
+7 ; REASON - used to create an enrollment with CANCELLED/DECLINED status,
+8 ; pass in the code for REASON CANCELED/DECLINED
+9 ; REMARKS - if creating an enrollment with CANCELLED/DECLINED status,
+10 ; and the reason is can optionally pass in textual remarks for
+11 ; CANCELED/DECLINED REMARKS
+12 ; ENRDATE - the Enrollment Date to use (optional)
+13 ; END - the Enrollment End Date to use (optional)
+14 ; DGENRYN - (Optional) ENROLL Y/N question for registration 0=NO 1=YES
+15 ;Output:
+16 ; Function Value - returns 1 if successful, 0 otherwise
+17 ; DGENR - a local array where the enrollment object will be stored,
+18 ; pass by reference
+19 ;
+20 KILL DGENR
+21 SET DGENR=""
SET DGENRYN=$GET(DGENRYN)
+22 NEW DGELGSUB,PRIORITY,DEATH,PRIGRP,DODUPD,DGSTUS,DGNOW,DGEIEN,DGENFLG,DGREG
+23 ;DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans.
SET DGREG=1
+24 SET DGEIEN=$$FINDCUR^DGENA(DFN)
+25 IF DGEIEN
SET DGENFLG=$$GET1^DIQ(27.11,DGEIEN_",",.14,"I")
+26 ;S DGNOW=$$NOW^XLFDT()
+27 ;Re-Enrollment - var PRIGRP contains priority and subgroup
+28 ;DG*5.3*993 Added 6th parameter DGENRYN
SET PRIGRP=$$PRIORITY^DGENELA4(DFN,,.DGELGSUB,$GET(ENRDATE),$GET(APP),$GET(DGENRYN))
+29 ; Re-Enrollment - Priority is first piece
SET PRIORITY=$PIECE(PRIGRP,"^")
+30 SET DGENR("APP")=$GET(APP)
+31 SET DGENR("DATE")=$GET(ENRDATE)
+32 SET DGENR("END")=$GET(END)
+33 SET DGENR("DFN")=DFN
+34 SET DGENR("SOURCE")=1
+35 IF $GET(DGENRYN)=0
IF $GET(DGENR("STATUS"))'=6
SET DGENR("STATUS")=25
+36 IF $GET(DGENFLG)=0
IF $GET(DGENR("STATUS"))'=6
SET DGENR("STATUS")=25
+37 ;DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans.
IF ($GET(DGENFLG)=0)!($GET(DGENRYN)=0)
SET DGREG=0
+38 ;drops out of block when status is determined
Begin DoDot:1
+39 IF $GET(REASON)
Begin DoDot:2
+40 ;CANCELED/DECLINED
SET DGENR("STATUS")=7
SET DGENR("REMARKS")=$GET(REMARKS)
SET DGENR("REASON")=REASON
End DoDot:2
QUIT
+41 IF '$TEST
SET DGENR("REMARKS")=""
SET DGENR("REASON")=""
+42 SET DEATH=$$DEATH^DGENPTA(DFN)
+43 IF DEATH
Begin DoDot:2
+44 ;DECEASED
SET DGENR("STATUS")=6
+45 SET DGENR("END")=DEATH
+46 ;Get Date of Death last updated date
SET DODUPD=$PIECE($GET(^DPT(DFN,.35)),"^",4)
+47 ;S EFFDATE=DEATH ;Removed - DG*5.3*672
+48 ;DG*5.3*672
SET EFFDATE=$SELECT($GET(DODUPD)'="":DODUPD,1:DT)
+49 ;Find patient's current enrollment record
+50 NEW DGENRIEN,DGENRC
+51 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+52 ;DG*5.3*993 Added REGISTRATION ONLY
IF DGENRIEN
if $GET(DGENRYN)=""
SET DGENRYN=$$GET1^DIQ(27.11,DGENRIEN_",",.14,"I")
+53 SET DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
+54 ;enrollment date
SET DGENR("DATE")=$SELECT($GET(DGENRC("DATE"))'="":DGENRC("DATE"),1:"")
End DoDot:2
QUIT
+55 ;NOT ELIGIBLE ; DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans.
IF DGREG
IF '$$VET^DGENPTA(DFN)
Begin DoDot:2
+56 NEW DGPAT,DGENRIEN,DGENRC
+57 ;new status for Ineligible Project
SET DGENR("STATUS")=20
+58 ;Find patient's current enrollment record
+59 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+60 SET DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
+61 ;enrollment date
SET DGENR("DATE")=$SELECT($GET(DGENRC("DATE"))'="":DGENRC("DATE"),1:"")
+62 ;Phase II The TESTVAL was moved from DGENA1 to DGENA3 (SRS 6.5.2.1)
+63 ;if vet has an Ineligible Date then the Effective Date should be the later of the Ineligible Date or App Date
+64 IF $$GET^DGENPTA(DFN,.DGENPTA)
IF DGENPTA("INELDATE")
IF $$TESTVAL^DGENA3("EFFDATE",DGENPTA("INELDATE"))
IF DGENRC=1
SET EFFDATE=$GET(DGENPTA("INELDATE"))
+65 IF '$GET(EFFDATE)
SET EFFDATE=$GET(APP)
+66 ;If currently enrolled, set end date = ineligible date
+67 IF DGENRC=1
SET DGENR("END")=$GET(DGENPTA("INELDATE"))
+68 ;If not currently enrolled or no ineligible date, set end date = application date
+69 IF '$GET(DGENR("END"))
SET DGENR("END")=$GET(APP)
End DoDot:2
QUIT
+70 ;Determine preliminary enrollment status based on enrollment group threshold
+71 ;Get enrollment group threshold
+72 NEW DGEGTIEN,DGEGT,DGENRC,DGENRIEN
+73 SET DGEGTIEN=$$FINDCUR^DGENEGT
+74 SET DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
+75 ; DG*5.3*1111 - All ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comments below modified to reflect this.
+76 ;If patient's enrollment status not above enrollment group threshold
+77 ;set status to DEFERRED: INITIAL APPLICATION BY VAMC
+78 IF $GET(PRIORITY)'=""
IF '$$ABOVE2^DGENEGT1(DFN,$GET(APP),PRIORITY,$PIECE(PRIGRP,U,2))
Begin DoDot:2
+79 ;Find patient's current enrollment record
+80 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+81 SET DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
+82 ;enrollment date
SET DGENR("DATE")=$SELECT($GET(DGENRC("DATE"))'="":DGENRC("DATE"),1:"")
+83 ;enrollment end date = application date
SET DGENR("END")=$GET(APP)
+84 ; effective date = application date
SET EFFDATE=$GET(APP)
+85 ;DEFERRED; INITIAL APPLICATION BY VAMC
SET DGENR("STATUS")=14
End DoDot:2
QUIT
+86 ;UNVERIFIED
SET DGENR("STATUS")=1
QUIT
End DoDot:1
+87 SET DGENR("FACREC")=$$INST^DGENU()
+88 SET DGENR("PRIORITY")=PRIORITY
+89 ;Phase II add subgroup (SRS 6.4)
+90 SET DGENR("SUBGRP")=$PIECE(PRIGRP,"^",2)
+91 SET DGENR("EFFDATE")=$SELECT($GET(EFFDATE):EFFDATE,$GET(ENRDATE):$GET(ENRDATE),1:$GET(APP))
+92 SET DGENR("USER")=$GET(DUZ)
+93 ;Moved to top of the routine DG*5.3*672
SET DGENR("DATETIME")=$$NOW^XLFDT
+94 SET DGENR("PRIORREC")=""
+95 ;DJE field added with DG*5.3*940 - Closed Application - RM#867186
SET DGENR("RCODE")=""
+96 ;Next line: DG*5.3*993 New fields for decoupling
+97 ; DG*5.3*1045 Set Registration Only Status when Ineligible Date is blank
+98 NEW DGINELIG,DGENPTA
+99 IF $$GET^DGENPTA(DFN,.DGENPTA)
SET DGINELIG=$GET(DGENPTA("INELDATE"))
+100 IF $GET(DGENRYN)=0
IF $GET(DGINELIG)=""
IF $GET(DGENR("STATUS"))'=6
IF $GET(DGENR("STATUS"))'=20
SET DGENR("STATUS")=25
+101 IF $GET(DGENFLG)=0
IF $GET(DGINELIG)=""
IF $GET(DGENR("STATUS"))'=6
IF $GET(DGENR("STATUS"))'=20
SET DGENR("STATUS")=25
+102 SET DGENR("PTAPPLIED")=DGENRYN
SET DGENR("REGREA")=$GET(DGENRRSN)
SET DGENR("REGDATE")=$GET(DGENRODT)
SET DGENR("REGSRC")=$GET(DGENSRCE)
+103 MERGE DGENR("ELIG")=DGELGSUB
+104 ;
+105 QUIT 1
