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.
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**;Aug 13,1993;Build 70
 ;
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) ;
 N DGIENS,DGFDA,DGINELIG,DGENPTA
 I $$GET^DGENPTA(DFN,.DGENPTA) S DGINELIG=$G(DGENPTA("INELDATE"))
 ;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
 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