DGRPE1 ;ALB/MRL,RTK,BRM,RGL,ERC,TDM,ARF,JAM,ARF - REGISTRATIONS EDITS (CONTINUED) ;4/2/09 11:26am
;;5.3;Registration;**114,327,451,631,688,808,804,909,952,1085,1093,1111**;Aug 13, 1993;Build 18
; 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)
; 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPE1 5973 printed Sep 23, 2025@20:32:09 Page 2
DGRPE1 ;ALB/MRL,RTK,BRM,RGL,ERC,TDM,ARF,JAM,ARF - REGISTRATIONS EDITS (CONTINUED) ;4/2/09 11:26am
+1 ;;5.3;Registration;**114,327,451,631,688,808,804,909,952,1085,1093,1111**;Aug 13, 1993;Build 18
+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 ; Quit if PAGER NUMBER field is not currently populated
+4 if $$GET1^DIQ(2,DFN,.135)=""
QUIT 1
+5 ;
+6 ; New input parameters for UPDATE^DIE call
+7 NEW DGFDA
+8 NEW DGERR
+9 NEW DIR
+10 ;
+11 ; New DIR output vars that are always returned
+12 ; Unprocessed user response
NEW X
+13 ; Processed user response
NEW Y
+14 ;
+15 ; New DIR output vars that are conditionally returned
+16 ;User time out
NEW DTOUT
+17 ;User entered caret (^)
NEW DUOUT
+18 ;User entered caret (^), pressed ENTER, or @ entered, or timed out
NEW DIRUT
+19 ;User entered two carets (^^)
NEW DIROUT
+20 ;
+21 ; Prompt for the PAGER NUMBER
+22 SET DIR(0)="2,.135"
DO ^DIR
KILL DIR
+23 SET DGFDA(2,DFN_",",.135)=Y
+24 ;
+25 ; Quit if TIMED READ (# OF SECONDS) maximum reached
+26 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT 0
+27 ;
+28 ; Quit when ^ or ^^ is entered
+29 IF ($DATA(DUOUT))!($DATA(DIROUT))
QUIT 0
+30 ;
+31 ; If user wants to delete PAGER NUMBER, then ask user to verify deletion
+32 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
+33 ;
+34 ; Quit if timeout or exit
+35 IF $DATA(DTOUT)
SET DGTMOT=1
QUIT 0
+36 IF ($DATA(DUOUT))!$DATA(DIROUT)
QUIT 0
+37 ;
+38 ; Quit if answered NO to SURE YOU WANT TO DELETE?
+39 IF (X["N")
WRITE " <NOTHING DELETED>"
QUIT 1
+40 ;
+41 ; Update PAGER NUMBER (#.135) field
+42 DO UPDATE^DIE("","DGFDA",,"DGERR")
+43 QUIT 1
+44 ;
+45 ; 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
