Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGENA6

DGENA6.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;CREATE line tag moved from DGENA in DG*5.3*232.;MM
  1. ;
  1. 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.
  1. ;Input :
  1. ; DFN- Patient IEN
  1. ; APP - the Enrollment Application Date to use
  1. ; EFFDATE - the Effective Date, if NULL assume the same as the
  1. ; Enrollment Date
  1. ; REASON - used to create an enrollment with CANCELLED/DECLINED status,
  1. ; pass in the code for REASON CANCELED/DECLINED
  1. ; REMARKS - if creating an enrollment with CANCELLED/DECLINED status,
  1. ; and the reason is can optionally pass in textual remarks for
  1. ; CANCELED/DECLINED REMARKS
  1. ; ENRDATE - the Enrollment Date to use (optional)
  1. ; END - the Enrollment End Date to use (optional)
  1. ; DGENRYN - (Optional) ENROLL Y/N question for registration 0=NO 1=YES
  1. ;Output:
  1. ; Function Value - returns 1 if successful, 0 otherwise
  1. ; DGENR - a local array where the enrollment object will be stored,
  1. ; pass by reference
  1. ;
  1. K DGENR
  1. S DGENR="",DGENRYN=$G(DGENRYN)
  1. N DGELGSUB,PRIORITY,DEATH,PRIGRP,DODUPD,DGSTUS,DGNOW,DGEIEN,DGENFLG,DGREG
  1. S DGREG=1 ;DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans.
  1. S DGEIEN=$$FINDCUR^DGENA(DFN)
  1. I DGEIEN S DGENFLG=$$GET1^DIQ(27.11,DGEIEN_",",.14,"I")
  1. ;S DGNOW=$$NOW^XLFDT()
  1. ;Re-Enrollment - var PRIGRP contains priority and subgroup
  1. S PRIGRP=$$PRIORITY^DGENELA4(DFN,,.DGELGSUB,$G(ENRDATE),$G(APP),$G(DGENRYN)) ;DG*5.3*993 Added 6th parameter DGENRYN
  1. S PRIORITY=$P(PRIGRP,"^") ; Re-Enrollment - Priority is first piece
  1. S DGENR("APP")=$G(APP)
  1. S DGENR("DATE")=$G(ENRDATE)
  1. S DGENR("END")=$G(END)
  1. S DGENR("DFN")=DFN
  1. S DGENR("SOURCE")=1
  1. I $G(DGENRYN)=0,$G(DGENR("STATUS"))'=6 S DGENR("STATUS")=25
  1. I $G(DGENFLG)=0,$G(DGENR("STATUS"))'=6 S DGENR("STATUS")=25
  1. 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.
  1. D ;drops out of block when status is determined
  1. .I $G(REASON) D Q
  1. ..S DGENR("STATUS")=7,DGENR("REMARKS")=$G(REMARKS),DGENR("REASON")=REASON ;CANCELED/DECLINED
  1. .E S DGENR("REMARKS")="",DGENR("REASON")=""
  1. .S DEATH=$$DEATH^DGENPTA(DFN)
  1. .I DEATH D Q
  1. ..S DGENR("STATUS")=6 ;DECEASED
  1. ..S DGENR("END")=DEATH
  1. ..S DODUPD=$P($G(^DPT(DFN,.35)),"^",4) ;Get Date of Death last updated date
  1. ..;S EFFDATE=DEATH ;Removed - DG*5.3*672
  1. ..S EFFDATE=$S($G(DODUPD)'="":DODUPD,1:DT) ;DG*5.3*672
  1. ..;Find patient's current enrollment record
  1. ..N DGENRIEN,DGENRC
  1. ..S DGENRIEN=$$FINDCUR^DGENA(DFN)
  1. ..I DGENRIEN S:$G(DGENRYN)="" DGENRYN=$$GET1^DIQ(27.11,DGENRIEN_",",.14,"I") ;DG*5.3*993 Added REGISTRATION ONLY
  1. ..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
  1. ..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date
  1. .I DGREG,'$$VET^DGENPTA(DFN) D Q ;NOT ELIGIBLE ; DG*5.3*1014 Restrict change of status when changing primary eligibility for non-veterans.
  1. ..N DGPAT,DGENRIEN,DGENRC
  1. ..S DGENR("STATUS")=20 ;new status for Ineligible Project
  1. ..;Find patient's current enrollment record
  1. ..S DGENRIEN=$$FINDCUR^DGENA(DFN)
  1. ..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
  1. ..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date
  1. ..;Phase II The TESTVAL was moved from DGENA1 to DGENA3 (SRS 6.5.2.1)
  1. ..;if vet has an Ineligible Date then the Effective Date should be the later of the Ineligible Date or App Date
  1. ..I $$GET^DGENPTA(DFN,.DGENPTA),DGENPTA("INELDATE"),$$TESTVAL^DGENA3("EFFDATE",DGENPTA("INELDATE")),DGENRC=1 S EFFDATE=$G(DGENPTA("INELDATE"))
  1. ..I '$G(EFFDATE) S EFFDATE=$G(APP)
  1. ..;If currently enrolled, set end date = ineligible date
  1. ..I DGENRC=1 S DGENR("END")=$G(DGENPTA("INELDATE"))
  1. ..;If not currently enrolled or no ineligible date, set end date = application date
  1. ..I '$G(DGENR("END")) S DGENR("END")=$G(APP)
  1. .;Determine preliminary enrollment status based on enrollment group threshold
  1. .;Get enrollment group threshold
  1. .N DGEGTIEN,DGEGT,DGENRC,DGENRIEN
  1. .S DGEGTIEN=$$FINDCUR^DGENEGT
  1. .S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
  1. .; DG*5.3*1111 - All ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Comments below modified to reflect this.
  1. .;If patient's enrollment status not above enrollment group threshold
  1. .;set status to DEFERRED: INITIAL APPLICATION BY VAMC
  1. .I $G(PRIORITY)'="",'$$ABOVE2^DGENEGT1(DFN,$G(APP),PRIORITY,$P(PRIGRP,U,2)) D Q
  1. ..;Find patient's current enrollment record
  1. ..S DGENRIEN=$$FINDCUR^DGENA(DFN)
  1. ..S DGENRC=$$GET^DGENA(DGENRIEN,.DGENRC)
  1. ..S DGENR("DATE")=$S($G(DGENRC("DATE"))'="":DGENRC("DATE"),1:"") ;enrollment date
  1. ..S DGENR("END")=$G(APP) ;enrollment end date = application date
  1. ..S EFFDATE=$G(APP) ; effective date = application date
  1. ..S DGENR("STATUS")=14 ;DEFERRED; INITIAL APPLICATION BY VAMC
  1. .S DGENR("STATUS")=1 Q ;UNVERIFIED
  1. S DGENR("FACREC")=$$INST^DGENU()
  1. S DGENR("PRIORITY")=PRIORITY
  1. ;Phase II add subgroup (SRS 6.4)
  1. S DGENR("SUBGRP")=$P(PRIGRP,"^",2)
  1. S DGENR("EFFDATE")=$S($G(EFFDATE):EFFDATE,$G(ENRDATE):$G(ENRDATE),1:$G(APP))
  1. S DGENR("USER")=$G(DUZ)
  1. S DGENR("DATETIME")=$$NOW^XLFDT ;Moved to top of the routine DG*5.3*672
  1. S DGENR("PRIORREC")=""
  1. S DGENR("RCODE")="" ;DJE field added with DG*5.3*940 - Closed Application - RM#867186
  1. ;Next line: DG*5.3*993 New fields for decoupling
  1. ; DG*5.3*1045 Set Registration Only Status when Ineligible Date is blank
  1. N DGINELIG,DGENPTA
  1. I $$GET^DGENPTA(DFN,.DGENPTA) S DGINELIG=$G(DGENPTA("INELDATE"))
  1. I $G(DGENRYN)=0,$G(DGINELIG)="",$G(DGENR("STATUS"))'=6,$G(DGENR("STATUS"))'=20 S DGENR("STATUS")=25
  1. I $G(DGENFLG)=0,$G(DGINELIG)="",$G(DGENR("STATUS"))'=6,$G(DGENR("STATUS"))'=20 S DGENR("STATUS")=25
  1. S DGENR("PTAPPLIED")=DGENRYN,DGENR("REGREA")=$G(DGENRRSN),DGENR("REGDATE")=$G(DGENRODT),DGENR("REGSRC")=$G(DGENSRCE)
  1. M DGENR("ELIG")=DGELGSUB
  1. ;
  1. Q 1