DGRPE1 ;ALB/MRL,RTK,BRM,RGL,ERC,TDM,ARF,JAM,ARF,JAM - REGISTRATIONS EDITS (CONTINUED) ;4/2/09 11:26am
;;5.3;Registration;**114,327,451,631,688,808,804,909,952,1085,1093,1111,1143**;Aug 13, 1993;Build 36
; Reference to DO^DIC1 in ICR #10007
;
;***CONTAINS ISM SPECIFIC CODE TO AVOID STORE ERRORS WITH ELIG.***
;
I DGRPS'=7 F I=1:1 S J=$P(DGDR,",",I) Q:J="" F J1=J,J*1000 Q:'$T(@J1) S DGDRD=$P($T(@J1),";;",2) D S
I DGRPS=7 S DR="[DG LOAD EDIT SCREEN 7]"
;S DR(2,2.0361)=".01"
D ^DIE K DIE,DR,DGCT,DGDR,DGDRD,DGDRS,I,J,J1
N DGELIG S DGELIG=$$GET1^DIQ(2,DFN_",",.361) I DGELIG'="EXPANDED MH CARE NON-ENROLLEE" D DEACTIVE^DGOTHEL
; rbd DG*5.3*909 Update Camp Lejeune potentially to No based on
; Veteran changing to No or Primary Elig Code becoming a Non-Veteran
; Type.
D SETCLNO^DGENCLEA
;update/set ELIGIBILITY VERIF. SOURCE field (327/Ineligible Project)
I $D(^DPT(DFN,.361)) S DGELG=^DPT(DFN,.361) D
.N DGXEL
.S DGXEL=$P(DGELG,U,5),DATA(.3613)="V"
.I $S($G(DGXEL)["CEV":1,$G(DGXEL)["VBA":1,$G(DGXEL)["VIVA":1,1:0),$P(DGELG,U,6)=.5 S DATA(.3613)="H"
.I '$$UPD^DGENDBS(2,DFN,.DATA)
Q
S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
701 ;;391;D SC7^DGRPV;1901;.301;S:X'="Y" Y=.313;.302;.313;.312;
702 ;;.361;D AAC1^DGLOCK2 S:DGAAC(1)']"" Y=361;.309;361;.323;D ^DGYZODS;S:'DGODS Y=.36265;11500.02;11500.03;.36265;S:X='"Y" Y="@72";.3626;@72;
703 ;;.3731;
1001 ;;.152;S:X="" Y="@101";.1651;.1653;.1654;.307;.1656;@101;
1002 ;;.153;S:X="" Y="@102";.1657:.1659;.16;@102;
1101 ;;.3611;.3612;.3614;.3615;
1102 ;;.306;
1103 ;;.322;
1104 ;;D VETTYPE^DGRPE1;D MSG^DGRPE1 S Y=0;@114;K DGRDCHG;D DR^DGRPE1;.302;.3721;D EFF^DGRPE1;D:$G(DGRDCHG) BULL^DGRPE1;K DGRDCHG;
MSG W !,"Patient is not a veteran. Can't enter rated disabilities",! Q
;
BULL ; Rated Disabilities update bulletin
;
Q ; This bulletin has been disabled. DG*5.3*808
;
N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ
S DGMGRP=$O(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT",""))
Q:'DGMGRP
D XMY^DGMTUTL(DGMGRP,0,1)
S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^DPT(DFN,0)),"^",9)
S XMTEXT="DGBULL("
S XMSUB="RATED DISABILITY UPDATED"
S DGLINE=0
D LINE^DGEN("Patient: "_DGNAME,.DGLINE)
D LINE^DGEN("SSN: "_DGSSN,.DGLINE)
D LINE^DGEN("",.DGLINE)
D LINE^DGEN("Send updates to SC Disabilities to HEC via fax or HECAlert",.DGLINE)
D LINE^DGEN("Outlook mail group so that they can be entered into VHA's",.DGLINE)
D LINE^DGEN("Authoritative Database. SC Disability information entered directly",.DGLINE)
D LINE^DGEN("into VistA may be overlaid.",.DGLINE)
D ^XMD
Q
DR ;
K DGSCPC
S DGSCPC=$P($G(^DPT(DFN,.3)),U,2)
S DR(2,2.04)=".01;2;3"
Q
EFF ;
I $G(DGSCPC)=$P($G(^DPT(DFN,.3)),U,2) Q
S DGFDA(2,DFN_",",.3014)="@"
D FILE^DIE("","DGFDA","DGERR")
K DGFDA,DGSCPC
Q
VETTYPE ;
S:$S('$D(^DPT(DFN,"VET")):0,^("VET")="Y":1,1:0) Y="@114" Q
S:'$S('$D(^("TYPE")):1,'$D(^DG(391,+^("TYPE"),0)):1,$P(^(0),"^",2):0,1:1) Y="@114"
Q
DR207 ; DG*5.3*1085 - Prompt for PREFERRED LANGUAGE (#2.07,.02)
; DG*5.3*1093; Add X,Y to NEW variables below - the call to ^DIR uses these vars
N DIR,DGFDA,DGLANGNM,DGERR,DGSUB,DGDATE,X,Y
S DGDATE="",DGDATE=$O(^DPT(DFN,.207,"B",DGDATE),-1)
I DGDATE'="" S DGSUB=$O(^DPT(DFN,.207,"B",DGDATE,0)) ;get the latest subscript
I $G(DGSUB)'="" S DGLANGNM=$$GET1^DIQ(2.07,DGSUB_","_DFN_",",.02) ;get PREFERRED LANGUAGE name
;
S DIR("B")=$S($G(DGLANGNM)'="":DGLANGNM,1:"ENGLISH")
S DIR(0)="2.07,.02" D ^DIR
;
I Y["^" W $C(7),!!,"No language was entered.",! H 3 Q
I Y="" Q
Q:Y=$G(DGLANGNM) ;if PREFERRED LANGUAGE is the same
;
S DGFDA(2.07,"+1,"_DFN_",",.01)=$$NOW^XLFDT()
S DGFDA(2.07,"+1,"_DFN_",",.02)=Y
D UPDATE^DIE("","DGFDA",,"DGERR")
Q
;
DR104() ;DG*5.3*1111-Prompt for the PAGER NUMBER (#.135) field of the PATIENT file #2 only if currently populated
;Returns: 1 - processing of fields beyond the PAGER NUMBER should continue
; 0 - processing should not continue (e.g. the user is exiting or a timeout occurred)
;
;DG*5.3*1143 - The PAGE NUMBER field (#.135) of the PATIENT file (#2) is no longer displayed
; or edited in VistA. This is obsolete code.
Q 1
; Quit if PAGER NUMBER field is not currently populated
Q:$$GET1^DIQ(2,DFN,.135)="" 1
;
; New input parameters for UPDATE^DIE call
N DGFDA
N DGERR
N DIR
;
; New DIR output vars that are always returned
N X ; Unprocessed user response
N Y ; Processed user response
;
; New DIR output vars that are conditionally returned
N DTOUT ;User time out
N DUOUT ;User entered caret (^)
N DIRUT ;User entered caret (^), pressed ENTER, or @ entered, or timed out
N DIROUT ;User entered two carets (^^)
;
; Prompt for the PAGER NUMBER
S DIR(0)="2,.135" D ^DIR K DIR
S DGFDA(2,DFN_",",.135)=Y
;
; Quit if TIMED READ (# OF SECONDS) maximum reached
I $D(DTOUT) S DGTMOT=1 Q 0
;
; Quit when ^ or ^^ is entered
I ($D(DUOUT))!($D(DIROUT)) Q 0
;
; If user wants to delete PAGER NUMBER, then ask user to verify deletion
I X["@" S DIR(0)="YA",DIR("B")="NO",DIR("A")="SURE YOU WANT TO DELETE? " N X,Y D ^DIR K DIR
;
; Quit if timeout or exit
I $D(DTOUT) S DGTMOT=1 Q 0
I ($D(DUOUT))!$D(DIROUT) Q 0
;
; Quit if answered NO to SURE YOU WANT TO DELETE?
I (X["N") W " <NOTHING DELETED>" Q 1
;
; Update PAGER NUMBER (#.135) field
D UPDATE^DIE("","DGFDA",,"DGERR")
Q 1
;
; DG*5.3*1111 - code moved here from DGRPE due to size limitations of DGRPE
YN1316(DFN) ;Email address indicator - DG*5.3*865
N %,RSLT
S DIE("NO^")=""
P1316 ;
S %=0
W !,"DOES THE PATIENT HAVE AN EMAIL ADDRESS? Y/N"
D YN^DICN
; DG*5.3*1111 - process a timeout
I $D(DTOUT) S DGTMOT=1 Q 0
I %=0 W !," If the patient has a valid Email Address, please answer with 'Yes'.",!," If no Email Address please answer with 'No'." G P1316
I %=-1 W !," EXIT NOT ALLOWED ??" G P1316
S RSLT=$S(%=1:"Y",%=2:"N")
N FDA,IENS
Q:'$G(DFN)
S IENS=DFN_",",FDA(2,IENS,.1316)=RSLT
D FILE^DIE("","FDA")
Q RSLT
;
DR115(DGEDIT) ; DG*5.3*1143 - Editing for cell phone and email
; This tag is called when Real-time updates are enabled from 115^DGRPE and from PSOPAT^DGADDUTL for PSO PAT option
; Input: DGEDIT (optional) - if NULL both cell and email are prompted
; - "C" - edit cell phone
; - "E" - edit email (not coded at this time since no need for it.)
; Output: - Array DGADDGRP5 (must be NEW'd in the calling program - e.g. screen 1.1 logic) will contain updated email or phone
; - DGADDEDIT(5) (must be NEW'd in the calling program) is a flag to indicate thar an edit has occurred
;
; DGEDIT, if defined, must be a C or E (E is not currently coded. For future use.)
I $D(DGEDIT) I DGEDIT'="C"&(DGEDIT'="E") Q
N X,Y,DIR,DA,DTOUT,DUOUT,DIROUT,DGVAL
ASKPH S DIR(0)="2,.134"
; Use the value in the local array for the field default if defined
I $D(DGADDGRP5(.134)) S DIR("B")=DGADDGRP5(.134)
I DFN S DA=DFN
D ^DIR
I $D(DTOUT) S DGTMOT=1 Q
I $D(DUOUT)!$D(DIROUT) Q
K DIR
; Check the format of the phone number since the user may have accepted the default value which would not be checked by Fileman
S DGVAL=Y
I DGVAL'="" D I '$D(DGVAL) W !,*7,"Answer must be 10 numbers in length with an optional 'X' and 1-6 digit",!,"extension number allowed.",!! G ASKPH
. S DGVAL=$TR(DGVAL,"x","X") K:$L(DGVAL)>17 DGVAL I $D(DGVAL) K:'(DGVAL?10N!(DGVAL?10.N1"X"1.6N)) DGVAL
; Initialize the group 5 edit flag
K DGADDEDIT(5)
; Set the phone value in the local array
S DGADDGRP5(.134)=Y
; If the phone is different from what is in the DB, set flag that an edit has occurred in group 5
I Y'=$P($G(^DPT(DFN,.13)),"^",4) S DGADDEDIT(5)=1
; Quit if editing cell phone only
I $G(DGEDIT)="C" Q
;
EMI ; Email Y/N indicator
S X=$$YN1316^DGRPE1(DFN) I +$G(DGTMOT) QUIT
; If No, set NULL email in the local array
I X["N" S DGADDGRP5(.133)=""
; If Yes, prompt for the email address, and return to Y/N prompt if they didn't enter anything
I X["Y" D EMAIL Q:+$G(DGTMOT) I $G(DGADDGRP5(.133))="" G EMI
; If the Email value has changed, set the EMAIL ADDRESS INDICATOR DT/TM and flag that an edit has occurred in group 5
I $G(DGADDGRP5(.133))'=$P($G(^DPT(DFN,.13)),"^",3) S DGADDGRP5(.1317)=$$NOW^XLFDT(),DGADDEDIT(5)=1
; If group 5 edit flag not set, no change has been made, delete the group 5 data and the edit flag
I +$G(DGADDEDIT(5))=0 K DGADDGRP5,DGADDEDIT(5)
Q
;
EMAIL ; DG*5.3*1143 Enter email address
N X,Y,DIR,DA,DTOUT,DUOUT,DIROUT
S DIR(0)="2,.133"
; Use the value in the local array for the field default if defined
I $G(DGADDGRP5(.133))'="" S DIR("B")=DGADDGRP5(.133)
I DFN S DA=DFN
D ^DIR
I $D(DTOUT) S DGTMOT=1 Q
I $D(DUOUT)!$D(DIROUT) W !," Exit not allowed" G EMAIL
; Check the format of the email since the user may have accepted the default value which would not be checked by Fileman
S DGVAL=Y
I DGVAL'="" D I '$D(DGVAL) W !!,*7,"Enter the applicant's email address [6-72 characters].",! D 133^DGMTDD5 G EMAIL
. ; Email format: 6-72 chars, ".." not allowed, more than 1 "@" not allowed,
. ; Must start with 1 AN followed by up to 63 chars, followed by "@" and 1 or more chars, followed by "." and at least 2 AN chars
. K:$L(DGVAL)>72!($L(DGVAL)<6)!(DGVAL["..")!($P(DGVAL,"@",2,99)["@")!'(DGVAL?1AN.63E1"@"1.E1"."2.AN.E) DGVAL
. ; Some combinations of chars are not allowed
. I $D(DGVAL) K:(DGVAL[".@")!(DGVAL["@.") DGVAL
. ; last char must be alpha-numeric
. I $D(DGVAL) I $E(DGVAL,$L(DGVAL))'?1AN K DGVAL
. ; Only alpha-numerc and certain accepted chars are allowed
. I $D(DGVAL) N DGX S DGX=$TR(DGVAL,"!#$%&'*+-/=?_{}`@.","") K:DGX'?.AN DGVAL
; hold value in local array
S DGADDGRP5(.133)=$G(Y)
Q
;
; DG*5.3*1143 - Tags DR11 and DR111 moved here from DGRPE
DR11 ;clt; DG*5.3*941 - Called from line tag 112 if Perm address in the patient file is empty
; Check if the user wants to copy Residential Address to Perm
; DG*5.3*1143 - Quit if we already have data in the Mailing Address local array (when RTA updates are ON)
I $G(DGADDGRP2(.111))'="" Q
; DG*5.3*1143 - Add check for a Residential Address in the local array.
; If no residential address exists, quit. Nothing to copy from
I $G(DGADDGRP1(.1151))="" Q:$G(^DPT(DFN,.115))=""
; DG*5.3*1040 - Quit if timeout from previous field
Q:$D(DTOUT)
Q:+$G(DGTMOT)
;DG*5.3*1056 removed Permanent from the following comment and message
; Residential Address exists, give user the option of copying residential to mailing address
W !,"The Patient has no Mailing Address."
D RESMVQ^DGREGCP1(DFN)
Q
DR111 ; Set DR string for Confidential Address categories
; DG*5.3*1143 - this tag no longer used. This code is now done in DGREGTE2 when editing Confidential Address
S DR(2,2.141)=".01;1//YES;"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPE1 11016 printed May 25, 2026@13:00:13 Page 2
DGRPE1 ;ALB/MRL,RTK,BRM,RGL,ERC,TDM,ARF,JAM,ARF,JAM - REGISTRATIONS EDITS (CONTINUED) ;4/2/09 11:26am
+1 ;;5.3;Registration;**114,327,451,631,688,808,804,909,952,1085,1093,1111,1143**;Aug 13, 1993;Build 36
+2 ; Reference to DO^DIC1 in ICR #10007
+3 ;
+4 ;***CONTAINS ISM SPECIFIC CODE TO AVOID STORE ERRORS WITH ELIG.***
+5 ;
+6 IF DGRPS'=7
FOR I=1:1
SET J=$PIECE(DGDR,",",I)
if J=""
QUIT
FOR J1=J,J*1000
if '$TEXT(@J1)
QUIT
SET DGDRD=$PIECE($TEXT(@J1),";;",2)
DO S
+7 IF DGRPS=7
SET DR="[DG LOAD EDIT SCREEN 7]"
+8 ;S DR(2,2.0361)=".01"
+9 DO ^DIE
KILL DIE,DR,DGCT,DGDR,DGDRD,DGDRS,I,J,J1
+10 NEW DGELIG
SET DGELIG=$$GET1^DIQ(2,DFN_",",.361)
IF DGELIG'="EXPANDED MH CARE NON-ENROLLEE"
DO DEACTIVE^DGOTHEL
+11 ; rbd DG*5.3*909 Update Camp Lejeune potentially to No based on
+12 ; Veteran changing to No or Primary Elig Code becoming a Non-Veteran
+13 ; Type.
+14 DO SETCLNO^DGENCLEA
+15 ;update/set ELIGIBILITY VERIF. SOURCE field (327/Ineligible Project)
+16 IF $DATA(^DPT(DFN,.361))
SET DGELG=^DPT(DFN,.361)
Begin DoDot:1
+17 NEW DGXEL
+18 SET DGXEL=$PIECE(DGELG,U,5)
SET DATA(.3613)="V"
+19 IF $SELECT($GET(DGXEL)["CEV":1,$GET(DGXEL)["VBA":1,$GET(DGXEL)["VIVA":1,1:0)
IF $PIECE(DGELG,U,6)=.5
SET DATA(.3613)="H"
+20 IF '$$UPD^DGENDBS(2,DFN,.DATA)
End DoDot:1
+21 QUIT
S IF $LENGTH(@DGDRS)+$LENGTH(DGDRD)<241
SET @DGDRS=@DGDRS_DGDRD
QUIT
+1 SET DGCT=DGCT+1
SET DGDRS="DR(1,2,"_DGCT_")"
SET @DGDRS=DGDRD
QUIT
701 ;;391;D SC7^DGRPV;1901;.301;S:X'="Y" Y=.313;.302;.313;.312;
702 ;;.361;D AAC1^DGLOCK2 S:DGAAC(1)']"" Y=361;.309;361;.323;D ^DGYZODS;S:'DGODS Y=.36265;11500.02;11500.03;.36265;S:X='"Y" Y="@72";.3626;@72;
703 ;;.3731;
1001 ;;.152;S:X="" Y="@101";.1651;.1653;.1654;.307;.1656;@101;
1002 ;;.153;S:X="" Y="@102";.1657:.1659;.16;@102;
1101 ;;.3611;.3612;.3614;.3615;
1102 ;;.306;
1103 ;;.322;
1104 ;;D VETTYPE^DGRPE1;D MSG^DGRPE1 S Y=0;@114;K DGRDCHG;D DR^DGRPE1;.302;.3721;D EFF^DGRPE1;D:$G(DGRDCHG) BULL^DGRPE1;K DGRDCHG;
MSG WRITE !,"Patient is not a veteran. Can't enter rated disabilities",!
QUIT
+1 ;
BULL ; Rated Disabilities update bulletin
+1 ;
+2 ; This bulletin has been disabled. DG*5.3*808
QUIT
+3 ;
+4 NEW DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ
+5 SET DGMGRP=$ORDER(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT",""))
+6 if 'DGMGRP
QUIT
+7 DO XMY^DGMTUTL(DGMGRP,0,1)
+8 SET DGNAME=$PIECE($GET(^DPT(DFN,0)),"^")
SET DGSSN=$PIECE($GET(^DPT(DFN,0)),"^",9)
+9 SET XMTEXT="DGBULL("
+10 SET XMSUB="RATED DISABILITY UPDATED"
+11 SET DGLINE=0
+12 DO LINE^DGEN("Patient: "_DGNAME,.DGLINE)
+13 DO LINE^DGEN("SSN: "_DGSSN,.DGLINE)
+14 DO LINE^DGEN("",.DGLINE)
+15 DO LINE^DGEN("Send updates to SC Disabilities to HEC via fax or HECAlert",.DGLINE)
+16 DO LINE^DGEN("Outlook mail group so that they can be entered into VHA's",.DGLINE)
+17 DO LINE^DGEN("Authoritative Database. SC Disability information entered directly",.DGLINE)
+18 DO LINE^DGEN("into VistA may be overlaid.",.DGLINE)
+19 DO ^XMD
+20 QUIT
DR ;
+1 KILL DGSCPC
+2 SET DGSCPC=$PIECE($GET(^DPT(DFN,.3)),U,2)
+3 SET DR(2,2.04)=".01;2;3"
+4 QUIT
EFF ;
+1 IF $GET(DGSCPC)=$PIECE($GET(^DPT(DFN,.3)),U,2)
QUIT
+2 SET DGFDA(2,DFN_",",.3014)="@"
+3 DO FILE^DIE("","DGFDA","DGERR")
+4 KILL DGFDA,DGSCPC
+5 QUIT
VETTYPE ;
+1 if $SELECT('$DATA(^DPT(DFN,"VET"))
SET Y="@114"
QUIT
+2 if '$SELECT('$DATA(^("TYPE"))
SET Y="@114"
+3 QUIT
DR207 ; DG*5.3*1085 - Prompt for PREFERRED LANGUAGE (#2.07,.02)
+1 ; DG*5.3*1093; Add X,Y to NEW variables below - the call to ^DIR uses these vars
+2 NEW DIR,DGFDA,DGLANGNM,DGERR,DGSUB,DGDATE,X,Y
+3 SET DGDATE=""
SET DGDATE=$ORDER(^DPT(DFN,.207,"B",DGDATE),-1)
+4 ;get the latest subscript
IF DGDATE'=""
SET DGSUB=$ORDER(^DPT(DFN,.207,"B",DGDATE,0))
+5 ;get PREFERRED LANGUAGE name
IF $GET(DGSUB)'=""
SET DGLANGNM=$$GET1^DIQ(2.07,DGSUB_","_DFN_",",.02)
+6 ;
+7 SET DIR("B")=$SELECT($GET(DGLANGNM)'="":DGLANGNM,1:"ENGLISH")
+8 SET DIR(0)="2.07,.02"
DO ^DIR
+9 ;
+10 IF Y["^"
WRITE $CHAR(7),!!,"No language was entered.",!
HANG 3
QUIT
+11 IF Y=""
QUIT
+12 ;if PREFERRED LANGUAGE is the same
if Y=$GET(DGLANGNM)
QUIT
+13 ;
+14 SET DGFDA(2.07,"+1,"_DFN_",",.01)=$$NOW^XLFDT()
+15 SET DGFDA(2.07,"+1,"_DFN_",",.02)=Y
+16 DO UPDATE^DIE("","DGFDA",,"DGERR")
+17 QUIT
+18 ;
DR104() ;DG*5.3*1111-Prompt for the PAGER NUMBER (#.135) field of the PATIENT file #2 only if currently populated
+1 ;Returns: 1 - processing of fields beyond the PAGER NUMBER should continue
+2 ; 0 - processing should not continue (e.g. the user is exiting or a timeout occurred)
+3 ;
+4 ;DG*5.3*1143 - The PAGE NUMBER field (#.135) of the PATIENT file (#2) is no longer displayed
+5 ; or edited in VistA. This is obsolete code.
+6 QUIT 1
+7 ; Quit if PAGER NUMBER field is not currently populated
+8 if $$GET1^DIQ(2,DFN,.135)=""
QUIT 1
+9 ;
+10 ; New input parameters for UPDATE^DIE call
+11 NEW DGFDA
+12 NEW DGERR
+13 NEW DIR
+14 ;
+15 ; New DIR output vars that are always returned
+16 ; Unprocessed user response
NEW X
+17 ; Processed user response
NEW Y
+18 ;
+19 ; New DIR output vars that are conditionally returned
+20 ;User time out
NEW DTOUT
+21 ;User entered caret (^)
NEW DUOUT
+22 ;User entered caret (^), pressed ENTER, or @ entered, or timed out
NEW DIRUT
+23 ;User entered two carets (^^)
NEW DIROUT
+24 ;
+25 ; Prompt for the PAGER NUMBER
+26 SET DIR(0)="2,.135"
DO ^DIR
KILL DIR
+27 SET DGFDA(2,DFN_",",.135)=Y
+28 ;
+29 ; Quit if TIMED READ (# OF SECONDS) maximum reached
+30 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT 0
+31 ;
+32 ; Quit when ^ or ^^ is entered
+33 IF ($DATA(DUOUT))!($DATA(DIROUT))
QUIT 0
+34 ;
+35 ; If user wants to delete PAGER NUMBER, then ask user to verify deletion
+36 IF X["@"
SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="SURE YOU WANT TO DELETE? "
NEW X,Y
DO ^DIR
KILL DIR
+37 ;
+38 ; Quit if timeout or exit
+39 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT 0
+40 IF ($DATA(DUOUT))!$DATA(DIROUT)
QUIT 0
+41 ;
+42 ; Quit if answered NO to SURE YOU WANT TO DELETE?
+43 IF (X["N")
WRITE " <NOTHING DELETED>"
QUIT 1
+44 ;
+45 ; Update PAGER NUMBER (#.135) field
+46 DO UPDATE^DIE("","DGFDA",,"DGERR")
+47 QUIT 1
+48 ;
+49 ; DG*5.3*1111 - code moved here from DGRPE due to size limitations of DGRPE
YN1316(DFN) ;Email address indicator - DG*5.3*865
+1 NEW %,RSLT
+2 SET DIE("NO^")=""
P1316 ;
+1 SET %=0
+2 WRITE !,"DOES THE PATIENT HAVE AN EMAIL ADDRESS? Y/N"
+3 DO YN^DICN
+4 ; DG*5.3*1111 - process a timeout
+5 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT 0
+6 IF %=0
WRITE !," If the patient has a valid Email Address, please answer with 'Yes'.",!," If no Email Address please answer with 'No'."
GOTO P1316
+7 IF %=-1
WRITE !," EXIT NOT ALLOWED ??"
GOTO P1316
+8 SET RSLT=$SELECT(%=1:"Y",%=2:"N")
+9 NEW FDA,IENS
+10 if '$GET(DFN)
QUIT
+11 SET IENS=DFN_","
SET FDA(2,IENS,.1316)=RSLT
+12 DO FILE^DIE("","FDA")
+13 QUIT RSLT
+14 ;
DR115(DGEDIT) ; DG*5.3*1143 - Editing for cell phone and email
+1 ; This tag is called when Real-time updates are enabled from 115^DGRPE and from PSOPAT^DGADDUTL for PSO PAT option
+2 ; Input: DGEDIT (optional) - if NULL both cell and email are prompted
+3 ; - "C" - edit cell phone
+4 ; - "E" - edit email (not coded at this time since no need for it.)
+5 ; Output: - Array DGADDGRP5 (must be NEW'd in the calling program - e.g. screen 1.1 logic) will contain updated email or phone
+6 ; - DGADDEDIT(5) (must be NEW'd in the calling program) is a flag to indicate thar an edit has occurred
+7 ;
+8 ; DGEDIT, if defined, must be a C or E (E is not currently coded. For future use.)
+9 IF $DATA(DGEDIT)
IF DGEDIT'="C"&(DGEDIT'="E")
QUIT
+10 NEW X,Y,DIR,DA,DTOUT,DUOUT,DIROUT,DGVAL
ASKPH SET DIR(0)="2,.134"
+1 ; Use the value in the local array for the field default if defined
+2 IF $DATA(DGADDGRP5(.134))
SET DIR("B")=DGADDGRP5(.134)
+3 IF DFN
SET DA=DFN
+4 DO ^DIR
+5 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+6 IF $DATA(DUOUT)!$DATA(DIROUT)
QUIT
+7 KILL DIR
+8 ; Check the format of the phone number since the user may have accepted the default value which would not be checked by Fileman
+9 SET DGVAL=Y
+10 IF DGVAL'=""
Begin DoDot:1
+11 SET DGVAL=$TRANSLATE(DGVAL,"x","X")
if $LENGTH(DGVAL)>17
KILL DGVAL
IF $DATA(DGVAL)
if '(DGVAL?10N!(DGVAL?10.N1"X"1.6N))
KILL DGVAL
End DoDot:1
IF '$DATA(DGVAL)
WRITE !,*7,"Answer must be 10 numbers in length with an optional 'X' and 1-6 digit",!,"extension number allowed.",!!
GOTO ASKPH
+12 ; Initialize the group 5 edit flag
+13 KILL DGADDEDIT(5)
+14 ; Set the phone value in the local array
+15 SET DGADDGRP5(.134)=Y
+16 ; If the phone is different from what is in the DB, set flag that an edit has occurred in group 5
+17 IF Y'=$PIECE($GET(^DPT(DFN,.13)),"^",4)
SET DGADDEDIT(5)=1
+18 ; Quit if editing cell phone only
+19 IF $GET(DGEDIT)="C"
QUIT
+20 ;
EMI ; Email Y/N indicator
+1 SET X=$$YN1316^DGRPE1(DFN)
IF +$GET(DGTMOT)
QUIT
+2 ; If No, set NULL email in the local array
+3 IF X["N"
SET DGADDGRP5(.133)=""
+4 ; If Yes, prompt for the email address, and return to Y/N prompt if they didn't enter anything
+5 IF X["Y"
DO EMAIL
if +$GET(DGTMOT)
QUIT
IF $GET(DGADDGRP5(.133))=""
GOTO EMI
+6 ; If the Email value has changed, set the EMAIL ADDRESS INDICATOR DT/TM and flag that an edit has occurred in group 5
+7 IF $GET(DGADDGRP5(.133))'=$PIECE($GET(^DPT(DFN,.13)),"^",3)
SET DGADDGRP5(.1317)=$$NOW^XLFDT()
SET DGADDEDIT(5)=1
+8 ; If group 5 edit flag not set, no change has been made, delete the group 5 data and the edit flag
+9 IF +$GET(DGADDEDIT(5))=0
KILL DGADDGRP5,DGADDEDIT(5)
+10 QUIT
+11 ;
EMAIL ; DG*5.3*1143 Enter email address
+1 NEW X,Y,DIR,DA,DTOUT,DUOUT,DIROUT
+2 SET DIR(0)="2,.133"
+3 ; Use the value in the local array for the field default if defined
+4 IF $GET(DGADDGRP5(.133))'=""
SET DIR("B")=DGADDGRP5(.133)
+5 IF DFN
SET DA=DFN
+6 DO ^DIR
+7 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT
+8 IF $DATA(DUOUT)!$DATA(DIROUT)
WRITE !," Exit not allowed"
GOTO EMAIL
+9 ; Check the format of the email since the user may have accepted the default value which would not be checked by Fileman
+10 SET DGVAL=Y
+11 IF DGVAL'=""
Begin DoDot:1
+12 ; Email format: 6-72 chars, ".." not allowed, more than 1 "@" not allowed,
+13 ; Must start with 1 AN followed by up to 63 chars, followed by "@" and 1 or more chars, followed by "." and at least 2 AN chars
+14 if $LENGTH(DGVAL)>72!($LENGTH(DGVAL)<6)!(DGVAL["..")!($PIECE(DGVAL,"@",2,99)["@")!'(DGVAL?1AN.63E1"@"1.E1"."2.AN.E)
KILL DGVAL
+15 ; Some combinations of chars are not allowed
+16 IF $DATA(DGVAL)
if (DGVAL[".@")!(DGVAL["@.")
KILL DGVAL
+17 ; last char must be alpha-numeric
+18 IF $DATA(DGVAL)
IF $EXTRACT(DGVAL,$LENGTH(DGVAL))'?1AN
KILL DGVAL
+19 ; Only alpha-numerc and certain accepted chars are allowed
+20 IF $DATA(DGVAL)
NEW DGX
SET DGX=$TRANSLATE(DGVAL,"!#$%&'*+-/=?_{}`@.","")
if DGX'?.AN
KILL DGVAL
End DoDot:1
IF '$DATA(DGVAL)
WRITE !!,*7,"Enter the applicant's email address [6-72 characters].",!
DO 133^DGMTDD5
GOTO EMAIL
+21 ; hold value in local array
+22 SET DGADDGRP5(.133)=$GET(Y)
+23 QUIT
+24 ;
+25 ; DG*5.3*1143 - Tags DR11 and DR111 moved here from DGRPE
DR11 ;clt; DG*5.3*941 - Called from line tag 112 if Perm address in the patient file is empty
+1 ; Check if the user wants to copy Residential Address to Perm
+2 ; DG*5.3*1143 - Quit if we already have data in the Mailing Address local array (when RTA updates are ON)
+3 IF $GET(DGADDGRP2(.111))'=""
QUIT
+4 ; DG*5.3*1143 - Add check for a Residential Address in the local array.
+5 ; If no residential address exists, quit. Nothing to copy from
+6 IF $GET(DGADDGRP1(.1151))=""
if $GET(^DPT(DFN,.115))=""
QUIT
+7 ; DG*5.3*1040 - Quit if timeout from previous field
+8 if $DATA(DTOUT)
QUIT
+9 if +$GET(DGTMOT)
QUIT
+10 ;DG*5.3*1056 removed Permanent from the following comment and message
+11 ; Residential Address exists, give user the option of copying residential to mailing address
+12 WRITE !,"The Patient has no Mailing Address."
+13 DO RESMVQ^DGREGCP1(DFN)
+14 QUIT
DR111 ; Set DR string for Confidential Address categories
+1 ; DG*5.3*1143 - this tag no longer used. This code is now done in DGREGTE2 when editing Confidential Address
+2 SET DR(2,2.141)=".01;1//YES;"
+3 QUIT
