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

DGEN.m

Go to the documentation of this file.
  1. DGEN ;ALB/RMO/CJM,JAM,RN - Patient Enrollment Option; 11/17/00 12:12pm ; 12/6/00 5:32pm
  1. ;;5.3;Registration;**121,122,165,147,232,314,624,993,1027,1045**;Aug 13,1993;Build 15
  1. ;
  1. EN ;Entry point for stand-alone enrollment option
  1. ; Input -- None
  1. ; Output -- None
  1. N DFN
  1. ;
  1. ;Get Patient file (#2) IEN - DFN
  1. D GETPAT^DGRPTU(,,.DFN,) G ENQ:DFN<0
  1. ;
  1. ;Load patient enrollment screen
  1. D EN^DGENL(DFN)
  1. ENQ Q
  1. ;
  1. EN1(DFN) ;Entry point for enrollment from registration and disposition
  1. ; Input -- DFN Patient IEN
  1. ; Output -- None
  1. N DGDISP,DGENOUT,DGX,DGSTS,DGNOPMT
  1. ;
  1. ;Check if patient should be asked to enroll
  1. ;Begin DG*5.3*993
  1. S DGDISP=$P(XQY0,U,1)="DG DISPOSITION APPLICATION"
  1. S DGSTS=$$STATUS^DGENA(DFN)
  1. I DGDISP,$G(DGENRYN)=0 S DGDISP=0 ; coming from DG DISPOSITION DGENRYN is 0 DB
  1. I $G(DGENRYN)=1 S DGNOPMT=0 ; Added condition for Yes
  1. I $G(DGENRYN)="" D
  1. . I DGSTS=25 S DGDISP=0
  1. ;END DG*5.3*993
  1. N DGCHK S DGCHK=$$CHK(DFN)
  1. I (DGCHK)!(DGDISP) D
  1. . I $$ENRPAT(DFN,.DGENOUT,$G(DGENRYN))
  1. I '$$VET^DGENPTA(DFN) D REGONLY(DFN) ; DG*5.3*993 NON-VETERANS
  1. ;
  1. ;If user did not timeout or '^' and
  1. ;patient is an eligible veteran or has an enrollment status
  1. I '$G(DGENOUT),($$VET^DGENPTA(DFN)!($$STATUS^DGENA(DFN))) D
  1. . D DISPLAY^DGENU(DFN) ;Display enrollment
  1. EN1Q Q
  1. ;
  1. CHK(DFN) ;Check if patient should be asked to enroll
  1. ; Input -- DFN Patient IEN
  1. ; Output -- 1=Yes and 0=No
  1. N Y,STATUS
  1. S Y=1
  1. ;Is patient an eligible veteran
  1. S Y=$$VET^DGENPTA(DFN)
  1. ;
  1. ;Is patient already enrolled or pending enrollment
  1. S STATUS=$$STATUS^DGENA(DFN)
  1. ; Purple Heart added status 21
  1. I Y,(STATUS=9)!(STATUS=1)!(STATUS=2)!(STATUS=14)!(STATUS=15)!(STATUS=16)!(STATUS=17)!(STATUS=18)!(STATUS=21) S Y=0 ;DG*5.3*993
  1. Q +$G(Y)
  1. ;
  1. CHK3(DFN) ;Check to restrict Register Only Patients to enroll from Patient Enrollment EP protocol
  1. ; Input -- DFN Patient IEN
  1. ; Output -- 1=Yes and 0=No
  1. N Y,STATUS
  1. S Y=1
  1. S Y=$$VET^DGENPTA(DFN)
  1. S STATUS=$$STATUS^DGENA(DFN)
  1. I Y,(STATUS=9)!(STATUS=1)!(STATUS=2)!(STATUS=14)!(STATUS=15)!(STATUS=16)!(STATUS=17)!(STATUS=18)!(STATUS=21)!(STATUS=25) S Y=0 ;DG*5.3*993 To Disable EP protocol
  1. Q +$G(Y)
  1. ;End DG*5.3*993
  1. ENRPAT(DFN,DGENOUT,DGENRYN) ;Enroll patient DG*5.3*993 Added third parameter
  1. ; Input -- DFN Patient IEN
  1. ; -- DGENRYN (Optional) ENROLL Y/N question for registration 0=NO 1=YES
  1. ; Output -- 1=Successful and 0=Failure
  1. ; DGENOUT 1=Timeout or up-arrow
  1. ;DG*5.3*993 - DO YOU WISH TO ENROLL now in initial registration questions DGENRYN=0 if NO to enroll
  1. N Y
  1. I $G(DGDISP),$G(DGNOPMT) S Y=$$ASK("enroll",.DGENOUT) S:Y DGENRYN=1 ;DG*5.3*993 If option used is Disposition an Application
  1. S DGENRYN=$G(DGENRYN)
  1. D G ENRPATQ
  1. . S DGOKF=$$ENROLL(DFN,DGENRYN) ;DG*5.3*993 Added second parameter DGENRYN
  1. ;End of DG*5.3*993 mods
  1. ENRPATQ Q +$G(DGOKF)
  1. ;
  1. ASK(ACTION,DGENOUT) ;Ask patient if s/he would like to enroll or cease enrollment
  1. ; Input -- ACTION Action description
  1. ; Output -- 1=Yes and 0=No
  1. ; DGENOUT 1=Timeout or up-arrow
  1. N DIR,DTOUT,DUOUT,Y
  1. S DIR("A")="Do you wish to "_ACTION_" in the VA Patient Enrollment System"
  1. S DIR("B")="YES",DIR(0)="Y"
  1. W ! D ^DIR
  1. I $D(DTOUT)!($D(DUOUT)) S DGENOUT=1
  1. Q +$G(Y)
  1. ;
  1. ENROLL(DFN,DGENRYN) ;Create new local unverified enrollment DG*5.3*993 Added 2nd parameter DGENRYN
  1. ; Input -- DFN Patient IEN
  1. ; -- DGENRYN (Optional) ENROLL Y/N question for registration 0=NO 1=YES
  1. ; Output -- 1=Successful and 0=Failure
  1. N DGENR,DGOKF,DGREQF,APPDATE,DGNOW,STATUS,DGDSPM,DGENRP,DGMNU,DGEIEN,DGAPDT,DGEXST,DGAD,DGPT,DGREGO
  1. S DGEXST=0
  1. S DGMNU=0
  1. S DGAD=0
  1. S DGREGO=0
  1. S DGNOW=$$NOW^XLFDT()
  1. S STATUS=$$STATUS^DGENA(DFN)
  1. ;Lock enrollment record
  1. I '$$LOCK^DGENA1(DFN) D G ENROLLQ
  1. . W !,">>> Another user is editing, try later ..."
  1. . D PAUSE^VALM1
  1. ;
  1. S DGDSPM=$P(XQY0,U,1)="DG DISPOSITION APPLICATION"
  1. S DGENRP=$P(XQY0,U,1)="DGEN PATIENT ENROLLMENT"
  1. I (DGDSPM)!(DGENRP) S DGMNU=1
  1. I DGENRP G ENROLLQ
  1. ;now that the enrollment history is locked, need to check again whether or not patient may be enrolled (query reply may have been received)
  1. G:'$$CHK^DGEN(DFN)&($G(DGDSPM)) ENROLLQ
  1. ;
  1. I $G(DGENRYN)=0,$G(DGENRODT)="" S DGENRODT=DGNOW ;
  1. S DGEIEN=$$FINDCUR^DGENA(DFN)
  1. I DGEIEN S DGAPDT=$$GET1^DIQ(27.11,DGEIEN_",",.01,"I"),DGPT=$$GET1^DIQ(27.11,DGEIEN_",",.14,"I")
  1. I $G(DGAPDT) S DGEXST=1
  1. I ($G(DGENRYN)=0)!($G(DGPT)=0)!($G(STATUS)=25) S DGREGO=1
  1. I ($G(DGENRYN)=0)!($G(STATUS)=25),'DGEXST S APPDATE=DT S DGAD=1
  1. ;Ask Application Date if not already entered at beginning of registration DG*5.3*993
  1. I ($G(DGENRYN)=1)!($G(DGPT)=1) D
  1. . I $G(DGENRDT)?1.N.E S APPDATE=DGENRDT
  1. ;. E I 'DGREGO,'DGMNU W ! I $$PROMPT^DGENU(27.11,.01,DT,.APPDATE,,1)
  1. ;
  1. ;
  1. D
  1. . ;Does patient require a Means Test?
  1. . D EN^DGMTR
  1. . ;Create local enrollment array
  1. . I $$CREATE^DGENA6(DFN,$G(APPDATE),,,,.DGENR,,,$G(DGENRYN)) D ;DG*5.3*993 Added 9th parameter DGENRYN
  1. . . ;Store local enrollment as current
  1. . . I $$STORECUR^DGENA1(.DGENR) D
  1. . . . S DGOKF=1
  1. . . . ;Ask preferred facility
  1. . . . I $G(DGENRYN)'=0 D PREFER^DGENPT(DFN)
  1. . . . ;If patient's means test status is required, send bulletin
  1. . . . I $$MTREQ(DFN) D MTBULL(DFN,.DGENR)
  1. ENROLLQ D UNLOCK^DGENA1(DFN)
  1. Q +$G(DGOKF)
  1. ;
  1. CANCEL(DFN,DGENR,EFFDATE) ;Cancel current enrollment
  1. ; Input
  1. ; DFN Patient IEN
  1. ; DGENR Array containing current enrollment (pass by reference)
  1. ; EFFDATE Enrollment Effective Date Of Change (optional)
  1. ; Output
  1. ; Function Return Value is 1 if Successful and 0 on Failure
  1. ;
  1. N DGENR2,DGOKF,REASON,REMARKS,BEGIN,END,ERRMSG
  1. ;Lock enrollment record
  1. I '$$LOCK^DGENA1(DFN) D G CANCELQ
  1. .W !,">>> Another user is editing, try later ..."
  1. .D PAUSE^VALM1
  1. W !
  1. ;Ask effective date of change for cessation
  1. I '$G(EFFDATE) D G:'EFFDATE CANCELQ
  1. .N DIR
  1. .S BEGIN=$S(DGENR("DATE"):DGENR("DATE"),1:DGENR("APP"))
  1. .S END=DGENR("END")
  1. .S DIR(0)="D^::AEX"
  1. .S DIR("A")="Effective Date of Cancellation"
  1. .S DIR("B")=$$VIEWDATE(DT)
  1. ASKDATE .W !,"Please enter the date to cease enrollment, no earlier than "_$$VIEWDATE(BEGIN)
  1. .I END W !,"and no later than "_$$VIEWDATE(END)_"."
  1. .D ^DIR
  1. .I $D(DIRUT)!('Y) S EFFDATE="" Q
  1. .E S EFFDATE=Y I (EFFDATE<BEGIN)!(END&(END<EFFDATE)) G ASKDATE
  1. .;
  1. ;Ask reason canceled/declined enrollment
  1. I '$$PROMPT^DGENU(27.11,.05,,.REASON,1) G CANCELQ
  1. ;If reason is 'Other', ask for remarks
  1. I REASON=4,'$$PROMPT^DGENU(27.11,25,,.REMARKS,1) G CANCELQ
  1. ;Create local enrollment array
  1. I $$CREATE^DGENA6(DFN,DGENR("APP"),EFFDATE,REASON,$G(REMARKS),.DGENR2,DGENR("DATE"),EFFDATE) D
  1. .;Store local enrollment as current
  1. .I $$STORECUR^DGENA1(.DGENR2,,.ERRMSG) D
  1. ..S DGOKF=1
  1. .E D
  1. ..W !,$G(ERRMSG)
  1. ;
  1. D UNLOCK^DGENA1(DFN)
  1. CANCELQ Q +$G(DGOKF)
  1. ;
  1. DECLINE(DFN,APPDATE) ;Create Declined enrollment
  1. ; Input -- DFN Patient IEN
  1. ; APPDATE Application date (optional)
  1. ; Output -- 1=Successful and 0=Failure
  1. N DGENR,DGOKF,REASON,REMARKS
  1. ;Lock enrollment record
  1. I '$$LOCK^DGENA1(DFN) D G DECLINEQ
  1. . W !,">>> Another user is editing, try later ..."
  1. . D PAUSE^VALM1
  1. ;Ask enrollment date
  1. W !
  1. I '$G(APPDATE),'$$PROMPT^DGENU(27.11,.01,DT,.APPDATE) G DECLINEQ
  1. ;Ask reason declined enrollment
  1. I '$$PROMPT^DGENU(27.11,.05,,.REASON,1) G DECLINEQ
  1. ;If reason is 'Other', ask for remarks
  1. I REASON=4,'$$PROMPT^DGENU(27.11,25,,.REMARKS,1) G DECLINEQ
  1. ;Create local enrollment array
  1. I $$CREATE^DGENA6(DFN,APPDATE,DT,REASON,$G(REMARKS),.DGENR) D
  1. . ;Store local enrollment as current
  1. . I $$STORECUR^DGENA1(.DGENR) D
  1. . . S DGOKF=1
  1. . . ;Ask preferred facility
  1. . . D PREFER^DGENPT(DFN)
  1. D UNLOCK^DGENA1(DFN)
  1. DECLINEQ ;
  1. Q +$G(DGOKF)
  1. ;
  1. MTBULL(DFN,DGENR) ;Create/Send means test 'REQUIRED' bulletin for PATIENT ENROLLMENT
  1. ;
  1. ; Input:
  1. ; DFN - patient IEN
  1. ; DGENR - this local array represents the PATIENT ENROLLMENT and
  1. ; should be passed by reference
  1. ;
  1. ; Output: None
  1. ;
  1. N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ
  1. ;
  1. ; get Means Test 'Required' mail group
  1. S DGMGRP=$P($G(^DG(43,1,"NOT")),"^",13)
  1. ;
  1. ; if mail group not defined, exit
  1. I 'DGMGRP G MTBULLQ
  1. ;
  1. ; set up XMY array
  1. D XMY^DGMTUTL(DGMGRP,0,1)
  1. ;
  1. ; obtain patient identifier
  1. D PID^VADPT6
  1. ;
  1. ; patient name
  1. S DGNAME=$P($G(^DPT(DFN,0)),"^")
  1. ;
  1. ; local array containing msg text
  1. S XMTEXT="DGBULL("
  1. ;
  1. ; - msg subject
  1. S XMSUB=$E("Patient: "_DGNAME,1,30)_" ("_VA("BID")_") "_"Means Test Required"
  1. ;
  1. ; - insert lines of text into message
  1. S DGLINE=0
  1. D LINE("The following patient is enrolled in the VA Patient Enrollment",.DGLINE)
  1. D LINE("System and 'REQUIRES' a means test.",.DGLINE)
  1. D LINE("",.DGLINE)
  1. D LINE(" Patient Name: "_DGNAME,.DGLINE)
  1. D LINE(" Patient ID: "_VA("PID"),.DGLINE)
  1. D LINE("",.DGLINE)
  1. D LINE(" Enrollment Date: "_$$EXT^DGENU("DATE",DGENR("DATE")),.DGLINE)
  1. D LINE(" Enrollment Status: "_$$EXT^DGENU("STATUS",DGENR("STATUS")),.DGLINE)
  1. D LINE(" Entered By: "_$$EXT^DGENU("USER",DGENR("USER")),.DGLINE)
  1. D LINE(" Date/Time Entered: "_$$EXT^DGENU("DATETIME",DGENR("DATETIME")),.DGLINE)
  1. D ^XMD
  1. ;
  1. MTBULLQ Q
  1. ;
  1. LINE(DGTEXT,DGLINE) ;Add lines of text to mail message
  1. ;
  1. ; Input:
  1. ; DGTEXT - as line of text to be inserted into mail message
  1. ; DGLINE - as number of lines in message, passed by reference
  1. ;
  1. ; Output:
  1. ; DGBULL - as local array containing message text
  1. ;
  1. S DGLINE=DGLINE+1
  1. S DGBULL(DGLINE)=DGTEXT
  1. Q
  1. ;
  1. MTREQ(DFN) ; --
  1. ;Determine if Means Test (required) bulletin should be sent for patient.
  1. ;
  1. ; Input:
  1. ; DFN - patient IEN
  1. ;
  1. ; Output:
  1. ; 1=Successful and 0=Failure
  1. ;
  1. N DGMTNODE,DGMTREQ
  1. ;
  1. ;Last means test for patient
  1. S DGMTNODE=$$LST^DGMTU(DFN)
  1. ;
  1. ;If scheduling bulletin already sent, exit
  1. I $P($G(^DGMT(408.31,+DGMTNODE,"BUL")),"^")=DT G MTREQQ
  1. ;
  1. ;If patient means test status is 'REQUIRED'
  1. I $P(DGMTNODE,"^",4)="R" D
  1. . ;set flag (send bulletin)
  1. . S DGMTREQ=1
  1. ;
  1. MTREQQ Q +$G(DGMTREQ)
  1. ;
  1. VIEWDATE(FMDATE) ;
  1. ;This function changes a FM date to its external representation
  1. N Y
  1. S Y=$G(FMDATE)
  1. D DD^%DT
  1. Q Y
  1. ;
  1. REGONLY(DFN) ;
  1. ; DG*5.3*1045 - capture ineligible reason DGINELREA
  1. N DGIENS,DGFDA,DGINELIG,DGENPTA,DGINELREA
  1. I $$GET^DGENPTA(DFN,.DGENPTA) S DGINELIG=$G(DGENPTA("INELDATE")),DGINELREA=$G(DGENPTA("INELREA"))
  1. ;Lock enrollment record
  1. I '$$LOCK^DGENA1(DFN) D Q
  1. . W !,">>> Another user is editing, try later ..."
  1. . D PAUSE^VALM1
  1. Q:$$FINDCUR^DGENA(DFN)
  1. ; DG*5.3*1027 - Create empty enrollment record
  1. S DGFDA(27.11,"+1,",.01)=DT
  1. S DGFDA(27.11,"+1,",.02)=DFN
  1. D UPDATE^DIE("","DGFDA","DGIENS")
  1. I '$D(DGIENS(1)) D UNLOCK^DGENA1(DFN) Q
  1. K DGFDA
  1. ; DG*5.3*1027 - Set CURRENT ENROLLMENT field in the PATIENT file
  1. S DGFDA(2,DFN_",",27.01)=DGIENS(1) D FILE^DIE("","DGFDA")
  1. K DGFDA
  1. ; DG*5.3*1027 - Set field values into the enrollment record
  1. S DGFDA(27.11,DGIENS(1)_",",.03)=1
  1. ; DG*5.3*1045- Set Enrollment Status to 20 if Ineligible date and Ineligible reason are populated
  1. I $G(DGINELIG)'="",$G(DGINELREA)'="" D
  1. . S DGFDA(27.11,DGIENS(1)_",",.04)=20
  1. ELSE D
  1. . S DGFDA(27.11,DGIENS(1)_",",.04)=25
  1. S DGFDA(27.11,DGIENS(1)_",",.06)=$$INST^DGENU()
  1. S DGFDA(27.11,DGIENS(1)_",",.07)=""
  1. S DGFDA(27.11,DGIENS(1)_",",.08)=DT
  1. S DGFDA(27.11,DGIENS(1)_",",.14)=0
  1. ; DG*5.3*1027;RN - Added condition for application date if ineligible date is populated
  1. I $G(DGENRYN)=1,$G(DGINELIG)'="" S DGFDA(27.11,DGIENS(1)_",",.14)=1,DGFDA(27.11,DGIENS(1)_",",.01)=$G(DGENRDT)
  1. ;DG*5.3*1027;RN - Added logic for Registration reason, source and registration date for a non-veteran
  1. I $G(DGINELIG)="",$G(DGENRRSN)?."" S DGENRRSN=$$FIND1^DIC(408.43,"","X","UNANSWERED")
  1. I $G(DGENRODT)?."" S DGENRODT=DGNOW
  1. I $G(DGENSRCE)?."" S DGENSRCE=1
  1. S DGFDA(27.11,DGIENS(1)_",",.15)=$G(DGENRRSN)
  1. S DGFDA(27.11,DGIENS(1)_",",.16)=$G(DGENRODT)
  1. S DGFDA(27.11,DGIENS(1)_",",.17)=$G(DGENSRCE)
  1. S DGFDA(27.11,DGIENS(1)_",",50.01)=$$NATCODE^DGENELA($$GET1^DIQ(2,DFN_",",".361","I"))
  1. S DGFDA(27.11,DGIENS(1)_",",75.01)=$$NOW^XLFDT()
  1. S DGFDA(27.11,DGIENS(1)_",",75.02)=$G(DUZ)
  1. D FILE^DIE("","DGFDA")
  1. D UNLOCK^DGENA1(DFN)
  1. Q