DGRP6 ;ALB/MRL,LBD,TMK,JAM,HM,ARF - REGISTRATION SCREEN 6/SERVICE INFORMATION ;5/12/11 10:49am
;;5.3;Registration;**161,247,343,397,342,451,672,689,797,841,842,947,972,1014**;Aug 13, 1993;Build 42
N DIPA,LIN,XX,Z1,GLBL
S DGRPS=6 D H^DGRPU F I=.32,.321,.322,.36,.385,.52,.53,.54 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
S (DGRPW,Z)=1 D WW2^DGRPV S Z=" Service Branch/Component",Z1=27 D WW1^DGRPV S Z="Service #",Z1=16 D WW1^DGRPV S Z=" Entered",Z1=12 D WW1^DGRPV S Z="Separated",Z1=12 D WW1^DGRPV W "Discharge"
W !?4,"------------------------",?30,"---------",?47,"-------",?58,"---------",?70,"---------"
;Get MSEs from Military Service Episode sub-file #2.3216 (DG*5.3*797)
K ^TMP("DGRP6",$J)
S GLBL=$NA(^TMP("DGRP6",$J))
D GETMSE^DGRP61(DFN,GLBL,0)
D S
;W ! ;DG*5.3*1014 - ARF - remove blank line between Service Branch/Component and Conflict Locations groups
D CL^DGRP6CL2(DFN,.LIN)
S Z=2 D WW2^DGRPV S Z=" Conflict Locations: ",Z1=20 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1)
S Z=1 F S Z=$O(LIN(Z)) Q:'Z W !,?25,LIN(Z)
D EF^DGRP6EF(DFN,.LIN)
S Z=3 D WW2^DGRPV S Z=" Environment Factors: ",Z1=21 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1)
S Z=1 F S Z=$O(LIN(Z)) Q:'Z W !,?4,"+ ",LIN(Z)
S Z=4,DGRPX=DGRP(.52) D WW^DGRPV W " POW: " S X=5,Z1=6 D YN W "From: " S X=7,Z1=13 D DAT W "To: " S X=8,Z1=12 D DAT W "War: ",$S($D(^DIC(22,+$P(DGRPX,"^",6),0)):$P(^(0),"^",2),1:"")
S Z=5 D WW^DGRPV W " Combat: " S X=11,Z1=6 D YN W "From: " S X=13,Z1=13 D DAT W "To: " S X=14,Z1=12 D DAT W "Loc: ",$S($D(^DIC(22,+$P(DGRPX,"^",12),0)):$P(^(0),"^",2),1:"")
S Z=6 D WW^DGRPV S X=$P(DGRP(.36),"^",12),XX=$P(DGRP(.36),"^",13)
N DGSPACE
S DGSPACE=$S($G(X)="0":" ",$G(X)="1":"",1:" ")
W " Mil Disab Retirement: ",$S(X=0:"NO",X=1:"YES",1:"") W DGSPACE_" Dischrg Due to Disab: ",$S(XX=0:"NO",XX=1:"YES",1:"")
;W !
S Z=7 D WW^DGRPV W " Dent Inj: " S DGRPX=DGRP(.36),X=8,Z1=28 D YN W "Teeth Extracted: " S X=9,Z1=9 D YN S DGRPD=0 I $P(DGRPX,"^",8)="Y",$P(DGRPX,"^",9)="Y" S DGRPD=1
I DGRPD S I1="" F I=0:0 S I=$O(^DPT(DFN,.37,I)) Q:'I S I1=1,DGRPX=^(I,0) D DEN
S Z=8 D WW^DGRPV W " Purple Heart: " S DGRPX=DGRP(.53),X=1 D YN D
. I $P($G(DGRPX),U)="Y",($P($G(DGRPX),U,2)]"") W ?26,"PH Status: "_$S($P($G(DGRPX),U,2)="1":"Pending",$P($G(DGRPX),U,2)="2":"In Process",$P($G(DGRPX),U,2)="3":"Confirmed",1:"")
I $P($G(DGRPX),U)="N" D
. S DGX=$P(DGRPX,U,3)
. S DGX=$S($G(DGX)=1:"UNACCEPTABLE DOCUMENTATION",$G(DGX)=2:"NO DOCUMENTATION REC'D",$G(DGX)=3:"ENTERED IN ERROR",$G(DGX)=4:"UNSUPPORTED PURPLE HEART",$G(DGX)=5:"VAMC",$G(DGX)=6:"UNDELIVERABLE MAIL",1:"")
. I $G(DGX)]"" W ?26,"PH Remarks: "_$S($G(DGX)]"":$G(DGX),1:"")
;DG*5.3*841
I $P(DGRP(.54),"^")="Y" D
.W !,"<9> Medal of Honor: YES"
.;MOH updates start here DG*5.3*972 HM
.N DGMOHADT,DGMOHEDT,DGMOHSDT
.S DGMOHADT=$P(DGRP(.54),"^",2),DGMOHSDT=$P(DGRP(.54),"^",3),DGMOHEDT=$P(DGRP(.54),"^",4) ;get MOH AWARD DATE,MOH STATUS DATE, & MOH COPAYMENT EXEMPTION DATE
.I DGMOHADT="" S DGMOHADT="UNKNOWN",DGMOHEDT="Needs Determination" ;Display text when MOH AWARD DATE empty
.W ?26,"Award Date: "_$$FMTE^XLFDT(DGMOHADT,"5DZ") ;format MOH AWARD DATE
.W ?51,"Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ") ;format MOH STATUS DATE
.W !?4,"MOH Copayment Exemption Date: "_$$FMTE^XLFDT(DGMOHEDT,"5DZ") ;format MOH COPAYMENT EXEMPTION DATE
I $P(DGRP(.54),"^")="N" D ;if MOH indicator is N
.N DGMOHSDT S DGMOHSDT=$P(DGRP(.54),"^",3) ;set status date
.W !,"<9> Medal of Honor: NO"
.W ?26,"Award Date: "
.W ?51,"Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ") ;format MOH STATUS DATE
.W !?4,"MOH Copayment Exemption Date: "
I $P(DGRP(.54),"^")="" D ;if MOH indicator is null
.W !,"<9> Medal of Honor: "
.W ?26,"Award Date: "
.W ?51,"Status Date: "
.W !?4,"MOH Copayment Exemption Date: "
.;MOH end updates DG*5.3*972
;DG*5.3*842
I ($P(DGRP(.385),U,8)["Y")!($P(DGRP(.385),U,8)["N") D EN^DDIOL("<10> Class II Dental Indicator: ","","!?0") S DGRPX=DGRP(.385),X=8,Z1=6 D YN I $P(DGRP(.385),U,8)["Y" D EN^DDIOL("Dental Appl Due Before Date: ","","?0") S X=9 D DAT
Q K DGRPD,DGRPSV
G ^DGRPP
YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNK",1:"") D WW1^DGRPV Q
DAT S Z=$P(DGRPX,"^",X) I Z']"" S Z=""
E S Z=$$FMTE^XLFDT(Z,"5DZ")
D WW1^DGRPV Q
DEN W !?3," Trt Date: " S X=1,Z1=10 D DAT W "Cond.: ",$E($P(DGRPX,"^",2),1,45) Q
S ;Write Military Service Episodes (DG*5.3*797)
N DGL,MSECNT
Q:$G(GLBL)=""
; JAM; DG*5.3*947 - Reason for Early Separation displayed with MSE data.
; This screen displays up to 3 MSE's and must include RES or Final Discharge Date if present
; Array lines (built in ^DGRP61) may contain an MSE or a RES or FDD, so we need to track the number of MSEs
; being displayed (MSECNT) - not the number of lines
S MSECNT=0
S DGL=0 F S DGL=$O(@GLBL@(DGL)) Q:'DGL D
.; JAM; DG*5.3*947 - if this array entry is MSE data (node 1 is present), increment the count and only display 3 episodes
.I $D(@GLBL@(DGL,1)) S MSECNT=MSECNT+1
.Q:MSECNT>3
.I $G(@GLBL@(DGL,0))]"" W !,@GLBL@(DGL,0)
;
; JAM; DG*5.3*947 - indicate more episodes are available using the MSECNT - not the line count
;I DGL>3 W !," <more episodes>" Q
I MSECNT>3 W !," <more episodes>" Q
; end DG*5.3*947 changes
Q
MR W !?19,"Receiving Military retirement in lieu of VA Compensation." Q
;
SETLNEX(Z,SEQ,LIN,LENGTH) ;
I 'LIN S LIN=1,LIN(1)=""
S Z=$E("("_SEQ_") "_Z,1,75)
I LENGTH+$L(Z)>$S(LIN<2:49,1:70) S LIN=LIN+1,LIN(LIN)="",LENGTH=0
S LIN(LIN)=LIN(LIN)_$S(LENGTH:" ",1:"")_Z,LENGTH=$L(LIN(LIN))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRP6 5705 printed Sep 23, 2025@20:31:33 Page 2
DGRP6 ;ALB/MRL,LBD,TMK,JAM,HM,ARF - REGISTRATION SCREEN 6/SERVICE INFORMATION ;5/12/11 10:49am
+1 ;;5.3;Registration;**161,247,343,397,342,451,672,689,797,841,842,947,972,1014**;Aug 13, 1993;Build 42
+2 NEW DIPA,LIN,XX,Z1,GLBL
+3 SET DGRPS=6
DO H^DGRPU
FOR I=.32,.321,.322,.36,.385,.52,.53,.54
SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+4 SET (DGRPW,Z)=1
DO WW2^DGRPV
SET Z=" Service Branch/Component"
SET Z1=27
DO WW1^DGRPV
SET Z="Service #"
SET Z1=16
DO WW1^DGRPV
SET Z=" Entered"
SET Z1=12
DO WW1^DGRPV
SET Z="Separated"
SET Z1=12
DO WW1^DGRPV
WRITE "Discharge"
+5 WRITE !?4,"------------------------",?30,"---------",?47,"-------",?58,"---------",?70,"---------"
+6 ;Get MSEs from Military Service Episode sub-file #2.3216 (DG*5.3*797)
+7 KILL ^TMP("DGRP6",$JOB)
+8 SET GLBL=$NAME(^TMP("DGRP6",$JOB))
+9 DO GETMSE^DGRP61(DFN,GLBL,0)
+10 DO S
+11 ;W ! ;DG*5.3*1014 - ARF - remove blank line between Service Branch/Component and Conflict Locations groups
+12 DO CL^DGRP6CL2(DFN,.LIN)
+13 SET Z=2
DO WW2^DGRPV
SET Z=" Conflict Locations: "
SET Z1=20
DO WW1^DGRPV
if '$DATA(LIN(1))
WRITE "< None Specified >"
if $DATA(LIN(1))
WRITE LIN(1)
+14 SET Z=1
FOR
SET Z=$ORDER(LIN(Z))
if 'Z
QUIT
WRITE !,?25,LIN(Z)
+15 DO EF^DGRP6EF(DFN,.LIN)
+16 SET Z=3
DO WW2^DGRPV
SET Z=" Environment Factors: "
SET Z1=21
DO WW1^DGRPV
if '$DATA(LIN(1))
WRITE "< None Specified >"
if $DATA(LIN(1))
WRITE LIN(1)
+17 SET Z=1
FOR
SET Z=$ORDER(LIN(Z))
if 'Z
QUIT
WRITE !,?4,"+ ",LIN(Z)
+18 SET Z=4
SET DGRPX=DGRP(.52)
DO WW^DGRPV
WRITE " POW: "
SET X=5
SET Z1=6
DO YN
WRITE "From: "
SET X=7
SET Z1=13
DO DAT
WRITE "To: "
SET X=8
SET Z1=12
DO DAT
WRITE "War: ",$SELECT($DATA(^DIC(22,+$PIECE(DGRPX,"^",6),0)):$PIECE(^(0),"^",2),1:"")
+19 SET Z=5
DO WW^DGRPV
WRITE " Combat: "
SET X=11
SET Z1=6
DO YN
WRITE "From: "
SET X=13
SET Z1=13
DO DAT
WRITE "To: "
SET X=14
SET Z1=12
DO DAT
WRITE "Loc: ",$SELECT($DATA(^DIC(22,+$PIECE(DGRPX,"^",12),0)):$PIECE(^(0),"^",2),1:"")
+20 SET Z=6
DO WW^DGRPV
SET X=$PIECE(DGRP(.36),"^",12)
SET XX=$PIECE(DGRP(.36),"^",13)
+21 NEW DGSPACE
+22 SET DGSPACE=$SELECT($GET(X)="0":" ",$GET(X)="1":"",1:" ")
+23 WRITE " Mil Disab Retirement: ",$SELECT(X=0:"NO",X=1:"YES",1:"")
WRITE DGSPACE_" Dischrg Due to Disab: ",$SELECT(XX=0:"NO",XX=1:"YES",1:"")
+24 ;W !
+25 SET Z=7
DO WW^DGRPV
WRITE " Dent Inj: "
SET DGRPX=DGRP(.36)
SET X=8
SET Z1=28
DO YN
WRITE "Teeth Extracted: "
SET X=9
SET Z1=9
DO YN
SET DGRPD=0
IF $PIECE(DGRPX,"^",8)="Y"
IF $PIECE(DGRPX,"^",9)="Y"
SET DGRPD=1
+26 IF DGRPD
SET I1=""
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.37,I))
if 'I
QUIT
SET I1=1
SET DGRPX=^(I,0)
DO DEN
+27 SET Z=8
DO WW^DGRPV
WRITE " Purple Heart: "
SET DGRPX=DGRP(.53)
SET X=1
DO YN
Begin DoDot:1
+28 IF $PIECE($GET(DGRPX),U)="Y"
IF ($PIECE($GET(DGRPX),U,2)]"")
WRITE ?26,"PH Status: "_$SELECT($PIECE($GET(DGRPX),U,2)="1":"Pending",$PIECE($GET(DGRPX),U,2)="2":"In Process",$PIECE($GET(DGRPX),U,2)="3":"Confirmed",1:"")
End DoDot:1
+29 IF $PIECE($GET(DGRPX),U)="N"
Begin DoDot:1
+30 SET DGX=$PIECE(DGRPX,U,3)
+31 SET DGX=$SELECT($GET(DGX)=1:"UNACCEPTABLE DOCUMENTATION",$GET(DGX)=2:"NO DOCUMENTATION REC'D",$GET(DGX)=3:"ENTERED IN ERROR",$GET(DGX)=4:"UNSUPPORTED PURPLE HEART",$GET(DGX)=5:"VAMC",$GET(DGX)=6:"UNDELIVERABLE MAIL",1:"")
+32 IF $GET(DGX)]""
WRITE ?26,"PH Remarks: "_$SELECT($GET(DGX)]"":$GET(DGX),1:"")
End DoDot:1
+33 ;DG*5.3*841
+34 IF $PIECE(DGRP(.54),"^")="Y"
Begin DoDot:1
+35 WRITE !,"<9> Medal of Honor: YES"
+36 ;MOH updates start here DG*5.3*972 HM
+37 NEW DGMOHADT,DGMOHEDT,DGMOHSDT
+38 ;get MOH AWARD DATE,MOH STATUS DATE, & MOH COPAYMENT EXEMPTION DATE
SET DGMOHADT=$PIECE(DGRP(.54),"^",2)
SET DGMOHSDT=$PIECE(DGRP(.54),"^",3)
SET DGMOHEDT=$PIECE(DGRP(.54),"^",4)
+39 ;Display text when MOH AWARD DATE empty
IF DGMOHADT=""
SET DGMOHADT="UNKNOWN"
SET DGMOHEDT="Needs Determination"
+40 ;format MOH AWARD DATE
WRITE ?26,"Award Date: "_$$FMTE^XLFDT(DGMOHADT,"5DZ")
+41 ;format MOH STATUS DATE
WRITE ?51,"Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ")
+42 ;format MOH COPAYMENT EXEMPTION DATE
WRITE !?4,"MOH Copayment Exemption Date: "_$$FMTE^XLFDT(DGMOHEDT,"5DZ")
End DoDot:1
+43 ;if MOH indicator is N
IF $PIECE(DGRP(.54),"^")="N"
Begin DoDot:1
+44 ;set status date
NEW DGMOHSDT
SET DGMOHSDT=$PIECE(DGRP(.54),"^",3)
+45 WRITE !,"<9> Medal of Honor: NO"
+46 WRITE ?26,"Award Date: "
+47 ;format MOH STATUS DATE
WRITE ?51,"Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ")
+48 WRITE !?4,"MOH Copayment Exemption Date: "
End DoDot:1
+49 ;if MOH indicator is null
IF $PIECE(DGRP(.54),"^")=""
Begin DoDot:1
+50 WRITE !,"<9> Medal of Honor: "
+51 WRITE ?26,"Award Date: "
+52 WRITE ?51,"Status Date: "
+53 WRITE !?4,"MOH Copayment Exemption Date: "
+54 ;MOH end updates DG*5.3*972
End DoDot:1
+55 ;DG*5.3*842
+56 IF ($PIECE(DGRP(.385),U,8)["Y")!($PIECE(DGRP(.385),U,8)["N")
DO EN^DDIOL("<10> Class II Dental Indicator: ","","!?0")
SET DGRPX=DGRP(.385)
SET X=8
SET Z1=6
DO YN
IF $PIECE(DGRP(.385),U,8)["Y"
DO EN^DDIOL("Dental Appl Due Before Date: ","","?0")
SET X=9
DO DAT
Q KILL DGRPD,DGRPSV
+1 GOTO ^DGRPP
YN SET Z=$SELECT($PIECE(DGRPX,"^",X)="Y":"YES",$PIECE(DGRPX,"^",X)="N":"NO",$PIECE(DGRPX,"^",X)="U":"UNK",1:"")
DO WW1^DGRPV
QUIT
DAT SET Z=$PIECE(DGRPX,"^",X)
IF Z']""
SET Z=""
+1 IF '$TEST
SET Z=$$FMTE^XLFDT(Z,"5DZ")
+2 DO WW1^DGRPV
QUIT
DEN WRITE !?3," Trt Date: "
SET X=1
SET Z1=10
DO DAT
WRITE "Cond.: ",$EXTRACT($PIECE(DGRPX,"^",2),1,45)
QUIT
S ;Write Military Service Episodes (DG*5.3*797)
+1 NEW DGL,MSECNT
+2 if $GET(GLBL)=""
QUIT
+3 ; JAM; DG*5.3*947 - Reason for Early Separation displayed with MSE data.
+4 ; This screen displays up to 3 MSE's and must include RES or Final Discharge Date if present
+5 ; Array lines (built in ^DGRP61) may contain an MSE or a RES or FDD, so we need to track the number of MSEs
+6 ; being displayed (MSECNT) - not the number of lines
+7 SET MSECNT=0
+8 SET DGL=0
FOR
SET DGL=$ORDER(@GLBL@(DGL))
if 'DGL
QUIT
Begin DoDot:1
+9 ; JAM; DG*5.3*947 - if this array entry is MSE data (node 1 is present), increment the count and only display 3 episodes
+10 IF $DATA(@GLBL@(DGL,1))
SET MSECNT=MSECNT+1
+11 if MSECNT>3
QUIT
+12 IF $GET(@GLBL@(DGL,0))]""
WRITE !,@GLBL@(DGL,0)
End DoDot:1
+13 ;
+14 ; JAM; DG*5.3*947 - indicate more episodes are available using the MSECNT - not the line count
+15 ;I DGL>3 W !," <more episodes>" Q
+16 IF MSECNT>3
WRITE !," <more episodes>"
QUIT
+17 ; end DG*5.3*947 changes
+18 QUIT
MR WRITE !?19,"Receiving Military retirement in lieu of VA Compensation."
QUIT
+1 ;
SETLNEX(Z,SEQ,LIN,LENGTH) ;
+1 IF 'LIN
SET LIN=1
SET LIN(1)=""
+2 SET Z=$EXTRACT("("_SEQ_") "_Z,1,75)
+3 IF LENGTH+$LENGTH(Z)>$SELECT(LIN<2:49,1:70)
SET LIN=LIN+1
SET LIN(LIN)=""
SET LENGTH=0
+4 SET LIN(LIN)=LIN(LIN)_$SELECT(LENGTH:" ",1:"")_Z
SET LENGTH=$LENGTH(LIN(LIN))
+5 QUIT
+6 ;
