- 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 Feb 19, 2025@00:08:25 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