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