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 - Patient Enrollment Option; 11/17/00 12:12pm ; 12/6/00 5:32pm
  1.  ;;5.3;Registration;**121,122,165,147,232,314,624,1015**;Aug 13,1993;Build 21
  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 DGENOUT
  1.  ;
  1.  ;Check if patient should be asked to enroll
  1.  I $$CHK(DFN) D
  1.  . ;Enroll patient
  1.  . I $$ENRPAT(DFN,.DGENOUT)
  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.  . ;Display enrollment
  1.  . D DISPLAY^DGENU(DFN)
  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
  1.  Q +$G(Y)
  1.  ;
  1. ENRPAT(DFN,DGENOUT) ;Enroll patient
  1.  ; Input  -- DFN      Patient IEN
  1.  ; Output -- 1=Successful and 0=Failure
  1.  ;           DGENOUT  1=Timeout or up-arrow
  1.  N DGOKF
  1.  ;Ask patient if s/he would like to enroll
  1.  I $$ASK("enroll",.DGENOUT) D
  1.  . ;If 'Yes' enroll patient
  1.  . S DGOKF=$$ENROLL(DFN)
  1.  ELSE  D
  1.  . ;Quit if timeout or '^'
  1.  . Q:$G(DGENOUT)
  1.  . ;Otherwise patient declined enrollment
  1.  . ;Cancel/decline functionality disabled by DG*5.3*232
  1.  . ;S DGOKF=$$DECLINE(DFN,DT)
  1.  . S DGOKF=0
  1.  . ;* Prompt for requested appt. (DG*5.3*624)
  1.  . I $P($G(^DPT(DFN,1010.15)),"^",9)="" DO
  1.  . . N DGSXS,DGAPPTAN
  1.  . . S DGSXS=$$PROMPT^DGENU(2,1010.159,1,.DGAPPTAN,"",1)
  1.  . . I DGSXS DO
  1.  . . . N DA,DR,DIE
  1.  . . . S DA=DFN
  1.  . . . S DIE="^DPT("
  1.  . . . S DR="1010.159////^S X=DGAPPTAN"
  1.  . . . D ^DIE
  1.  . . . K DA,DR,DIE
  1.  . . . ;*Set Appointment Request Date to current date
  1.  . . . N DA,DR,DIE
  1.  . . . S DIE="^DPT("
  1.  . . . S DA=DFN
  1.  . . . S DR="1010.1511////^S X=DT"
  1.  . . . D ^DIE
  1.  . . . K DA,DR,DIE
  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) ;Create new local unverified enrollment
  1.  ; Input  -- DFN      Patient IEN
  1.  ; Output -- 1=Successful and 0=Failure
  1.  N DGENR,DGOKF,DGREQF,APPDATE
  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.  ;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) ENROLLQ
  1.  ;
  1.  ;Ask Application Date
  1.  W !
  1.  I $$PROMPT^DGENU(27.11,.01,DT,.APPDATE) D
  1.  . ;Does patient require a Means Test?
  1.  . D EN^DGMTR
  1.  . ;Create local enrollment array
  1.  . I $$CREATE^DGENA6(DFN,APPDATE,,,,.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.  . . . ;If patient's means test status is required, send bulletin
  1.  . . . I $$MTREQ(DFN) D MTBULL(DFN,.DGENR)
  1.  I $P($G(^DPT(DFN,1010.15)),"^",11)="" DO
  1.  . N DGSXS,DGAPPTAN,DGDFLT
  1.  . S DGDFLT=$P($G(^DPT(DFN,1010.15)),"^",9)
  1.  . S:DGDFLT="" DGDFLT=1
  1.  . S DGSXS=$$PROMPT^DGENU(2,1010.159,DGDFLT,.DGAPPTAN,"",1)
  1.  . I DGSXS DO
  1.  . . N DA,DR,DIE
  1.  . . S DA=DFN
  1.  . . S DIE="^DPT("
  1.  . . S DR="1010.159////^S X=DGAPPTAN"
  1.  . . D ^DIE
  1.  . . K DA,DR,DIE
  1.  . . ;*If patient answered NO to "Do you want an appt" question
  1.  . . I $P($G(^DPT(DFN,1010.15)),"^",9)=0 DO
  1.  . . . N DA,DR,DIE
  1.  . . . S DIE="^DPT("
  1.  . . . S DA=DFN
  1.  . . . S DR="1010.1511////^S X=DT"
  1.  . . . D ^DIE
  1.  . . . K DA,DR,DIE
  1.  . . ;*If patient answered YES to "Do you want an appt" question
  1.  . . I $P($G(^DPT(DFN,1010.15)),"^",9)=1 DO
  1.  . . . N DA,DR,DIE
  1.  . . . S DIE="^DPT("
  1.  . . . S DA=DFN
  1.  . . . S DR="1010.1511////^S X=APPDATE"
  1.  . . . D ^DIE
  1.  . . . K DA,DR,DIE
  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