DGENA6 ;ALB/CJM,ISA,KWP,RTK,LBD,CKN - Enrollment API to create enrollment record; 04/24/03 ; 8/31/05 2:44pm
;;5.3;Registration;**232,327,417,491,513,672,1015**;Aug 13, 1993;Build 21
;
;CREATE line tag moved from DGENA in DG*5.3*232.;MM
;
CREATE(DFN,APP,EFFDATE,REASON,REMARKS,DGENR,ENRDATE,END) ;
;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)
;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=""
N DGELGSUB,PRIORITY,DEATH,PRIGRP,DODUPD
;Re-Enrollment - var PRIGRP contains priority and subgroup
S PRIGRP=$$PRIORITY^DGENELA4(DFN,,.DGELGSUB,$G(ENRDATE),$G(APP))
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
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)
..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date
.I '$$VET^DGENPTA(DFN) D Q ;NOT ELIGIBLE
..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)
.;If patient's enrollment status not above enrollment group threshold
.;set status to Rejected: 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 ;Rejected: 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")=""
M DGENR("ELIG")=DGELGSUB
;
Q 1
DGENA6 ;ALB/CJM,ISA,KWP,RTK,LBD,CKN - Enrollment API to create enrollment record; 04/24/03 ; 8/31/05 2:44pm
+1 ;;5.3;Registration;**232,327,417,491,513,672,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;CREATE line tag moved from DGENA in DG*5.3*232.;MM
+4 ;
CREATE(DFN,APP,EFFDATE,REASON,REMARKS,DGENR,ENRDATE,END) ;
+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 ;Output:
+15 ; Function Value - returns 1 if successful, 0 otherwise
+16 ; DGENR - a local array where the enrollment object will be stored,
+17 ; pass by reference
+18 ;
+19 KILL DGENR
+20 SET DGENR=""
+21 NEW DGELGSUB,PRIORITY,DEATH,PRIGRP,DODUPD
+22 ;Re-Enrollment - var PRIGRP contains priority and subgroup
+23 SET PRIGRP=$$PRIORITY^DGENELA4(DFN,,.DGELGSUB,$GET(ENRDATE),$GET(APP))
+24 ; Re-Enrollment - Priority is first piece
SET PRIORITY=$PIECE(PRIGRP,"^")
+25 SET DGENR("APP")=$GET(APP)
+26 SET DGENR("DATE")=$GET(ENRDATE)
+27 SET DGENR("END")=$GET(END)
+28 SET DGENR("DFN")=DFN
+29 SET DGENR("SOURCE")=1
+30 ;drops out of block when status is determined
Begin DoDot:1
+31 IF $GET(REASON)
Begin DoDot:2
+32 ;CANCELED/DECLINED
SET DGENR("STATUS")=7
SET DGENR("REMARKS")=$GET(REMARKS)
SET DGENR("REASON")=REASON
End DoDot:2
QUIT
+33 IF '$TEST
SET DGENR("REMARKS")=""
SET DGENR("REASON")=""
+34 SET DEATH=$$DEATH^DGENPTA(DFN)
+35 IF DEATH
Begin DoDot:2
+36 ;DECEASED
SET DGENR("STATUS")=6
+37 SET DGENR("END")=DEATH
+38 ;Get Date of Death last updated date
SET DODUPD=$PIECE($GET(^DPT(DFN,.35)),"^",4)
+39 ;S EFFDATE=DEATH ;Removed - DG*5.3*672
+40 ;DG*5.3*672
SET EFFDATE=$SELECT($GET(DODUPD)'="":DODUPD,1:DT)
+41 ;Find patient's current enrollment record
+42 NEW DGENRIEN,DGENRC
+43 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+44 SET DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
+45 ;enrollment date
SET DGENR("DATE")=$SELECT($GET(DGENRC("DATE"))'="":DGENRC("DATE"),1:"")
End DoDot:2
QUIT
+46 ;NOT ELIGIBLE
IF '$$VET^DGENPTA(DFN)
Begin DoDot:2
+47 NEW DGPAT,DGENRIEN,DGENRC
+48 ;new status for Ineligible Project
SET DGENR("STATUS")=20
+49 ;Find patient's current enrollment record
+50 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+51 SET DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
+52 ;enrollment date
SET DGENR("DATE")=$SELECT($GET(DGENRC("DATE"))'="":DGENRC("DATE"),1:"")
+53 ;Phase II The TESTVAL was moved from DGENA1 to DGENA3 (SRS 6.5.2.1)
+54 ;if vet has an Ineligible Date then the Effective Date should be the later of the Ineligible Date or App Date
+55 IF $$GET^DGENPTA(DFN,.DGENPTA)
IF DGENPTA("INELDATE")
IF $$TESTVAL^DGENA3("EFFDATE",DGENPTA("INELDATE"))
IF DGENRC=1
SET EFFDATE=$GET(DGENPTA("INELDATE"))
+56 IF '$GET(EFFDATE)
SET EFFDATE=$GET(APP)
+57 ;If currently enrolled, set end date = ineligible date
+58 IF DGENRC=1
SET DGENR("END")=$GET(DGENPTA("INELDATE"))
+59 ;If not currently enrolled or no ineligible date, set end date = application date
+60 IF '$GET(DGENR("END"))
SET DGENR("END")=$GET(APP)
End DoDot:2
QUIT
+61 ;Determine preliminary enrollment status based on enrollment group threshold
+62 ;Get enrollment group threshold
+63 NEW DGEGTIEN,DGEGT,DGENRC,DGENRIEN
+64 SET DGEGTIEN=$$FINDCUR^DGENEGT
+65 SET DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
+66 ;If patient's enrollment status not above enrollment group threshold
+67 ;set status to Rejected: Initial Application by VAMC)
+68 IF $GET(PRIORITY)'=""
IF '$$ABOVE2^DGENEGT1(DFN,$GET(APP),PRIORITY,$PIECE(PRIGRP,U,2))
Begin DoDot:2
+69 ;Find patient's current enrollment record
+70 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+71 SET DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
+72 ;enrollment date
SET DGENR("DATE")=$SELECT($GET(DGENRC("DATE"))'="":DGENRC("DATE"),1:"")
+73 ;enrollment end date = application date
SET DGENR("END")=$GET(APP)
+74 ; effective date = application date
SET EFFDATE=$GET(APP)
+75 ;Rejected: Initial Application by VAMC
SET DGENR("STATUS")=14
End DoDot:2
QUIT
+76 ;UNVERIFIED
SET DGENR("STATUS")=1
QUIT
End DoDot:1
+77 SET DGENR("FACREC")=$$INST^DGENU()
+78 SET DGENR("PRIORITY")=PRIORITY
+79 ;Phase II add subgroup (SRS 6.4)
+80 SET DGENR("SUBGRP")=$PIECE(PRIGRP,"^",2)
+81 SET DGENR("EFFDATE")=$SELECT($GET(EFFDATE):EFFDATE,$GET(ENRDATE):$GET(ENRDATE),1:$GET(APP))
+82 SET DGENR("USER")=$GET(DUZ)
+83 ;Moved to top of the routine DG*5.3*672
SET DGENR("DATETIME")=$$NOW^XLFDT
+84 SET DGENR("PRIORREC")=""
+85 MERGE DGENR("ELIG")=DGELGSUB
+86 ;
+87 QUIT 1
