source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENA6.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1DGENA6 ;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 ;
6CREATE(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
Note: See TracBrowser for help on using the repository browser.