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