DGRP6 ;ALB/MRL,LBD,TMK - REGISTRATION SCREEN 6/SERVICE INFORMATION ;12 SEP 05
;;5.3;Registration;**161,247,343,397,342,451,672,689,1015**;Aug 13, 1993;Build 21
N DIPA,LIN,XX,Z1
S DGRPS=6 D H^DGRPU F I=.32,.321,.322,.36,.52,.53 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
S (DGRPW,Z)=1 D WW^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,"---------",?46,"-------",?58,"---------",?70,"---------"
S DGRPX=DGRP(.32),DGRPSV=4 D S I $P(DGRPX,"^",19)="Y" S DGRPSV=9 D S I $P(DGRPX,"^",20)="Y" S DGRPSV=14 D S
W !
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:"")
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 N Z,DGRPSB S DGRPSB=+$P(DGRPX,U,DGRPSV+1) ;Service Branch
S Z=$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15),1:DGRPU)
I $P($G(^DPT(DFN,.3291)),U,(DGRPSV+1)/5)'="" D
. N Z0
. ; Component
. S Z0=$$SVCCOMP^DGRP6CL($P($G(^DPT(DFN,.3291)),U,(DGRPSV+1)/5))
. Q:Z0=""
. S Z=Z_"/"_Z0
I $$FV^DGRPMS(DGRPSB)=1 S Z=$E(Z_$J("",21),1,21)_"("_$P(DGRP(.321),U,14)_")"
W !?4,Z
W ?30,$S($P(DGRPX,"^",DGRPSV+4)]"":$P(DGRPX,"^",DGRPSV+4),1:DGRPU)
F I=2,3 S X=$P(DGRPX,"^",DGRPSV+I),X=$S(X]"":$$FMTE^XLFDT(X,"5DZ"),1:"UNKNOWN") W ?$S(I=2:46,1:58),X
W ?70,$S($D(^DIC(25,+$P(DGRPX,"^",DGRPSV),0)):$E($P(^(0),"^",1),1,9),1:"UNKNOWN") 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
;
DGRP6 ;ALB/MRL,LBD,TMK - REGISTRATION SCREEN 6/SERVICE INFORMATION ;12 SEP 05
+1 ;;5.3;Registration;**161,247,343,397,342,451,672,689,1015**;Aug 13, 1993;Build 21
+2 NEW DIPA,LIN,XX,Z1
+3 SET DGRPS=6
DO H^DGRPU
FOR I=.32,.321,.322,.36,.52,.53
SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+4 SET (DGRPW,Z)=1
DO WW^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,"---------",?46,"-------",?58,"---------",?70,"---------"
+6 SET DGRPX=DGRP(.32)
SET DGRPSV=4
DO S
IF $PIECE(DGRPX,"^",19)="Y"
SET DGRPSV=9
DO S
IF $PIECE(DGRPX,"^",20)="Y"
SET DGRPSV=14
DO S
+7 WRITE !
+8 DO CL^DGRP6CL2(DFN,.LIN)
+9 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)
+10 SET Z=1
FOR
SET Z=$ORDER(LIN(Z))
IF 'Z
QUIT
WRITE !,?25,LIN(Z)
+11 DO EF^DGRP6EF(DFN,.LIN)
+12 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)
+13 SET Z=1
FOR
SET Z=$ORDER(LIN(Z))
IF 'Z
QUIT
WRITE !,?4,"+ ",LIN(Z)
+14 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:"")
+15 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:"")
+16 SET Z=6
DO WW^DGRPV
SET X=$PIECE(DGRP(.36),"^",12)
SET XX=$PIECE(DGRP(.36),"^",13)
+17 NEW DGSPACE
+18 SET DGSPACE=$SELECT($GET(X)="0":" ",$GET(X)="1":"",1:" ")
+19 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:"")
+20 ;W !
+21 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
+22 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
+23 SET Z=8
DO WW^DGRPV
WRITE " Purple Heart: "
SET DGRPX=DGRP(.53)
SET X=1
DO YN
Begin DoDot:1
+24 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
+25 IF $PIECE($GET(DGRPX),U)="N"
Begin DoDot:1
+26 SET DGX=$PIECE(DGRPX,U,3)
+27 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:"")
+28 IF $GET(DGX)]""
WRITE ?26,"PH Remarks: "_$SELECT($GET(DGX)]"":$GET(DGX),1:"")
End DoDot:1
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 ;Service Branch
NEW Z,DGRPSB
SET DGRPSB=+$PIECE(DGRPX,U,DGRPSV+1)
+1 SET Z=$SELECT($DATA(^DIC(23,DGRPSB,0)):$EXTRACT($PIECE(^(0),"^",1),1,15),1:DGRPU)
+2 IF $PIECE($GET(^DPT(DFN,.3291)),U,(DGRPSV+1)/5)'=""
Begin DoDot:1
+3 NEW Z0
+4 ; Component
+5 SET Z0=$$SVCCOMP^DGRP6CL($PIECE($GET(^DPT(DFN,.3291)),U,(DGRPSV+1)/5))
+6 IF Z0=""
QUIT
+7 SET Z=Z_"/"_Z0
End DoDot:1
+8 IF $$FV^DGRPMS(DGRPSB)=1
SET Z=$EXTRACT(Z_$JUSTIFY("",21),1,21)_"("_$PIECE(DGRP(.321),U,14)_")"
+9 WRITE !?4,Z
+10 WRITE ?30,$SELECT($PIECE(DGRPX,"^",DGRPSV+4)]"":$PIECE(DGRPX,"^",DGRPSV+4),1:DGRPU)
+11 FOR I=2,3
SET X=$PIECE(DGRPX,"^",DGRPSV+I)
SET X=$SELECT(X]"":$$FMTE^XLFDT(X,"5DZ"),1:"UNKNOWN")
WRITE ?$SELECT(I=2:46,1:58),X
+12 WRITE ?70,$SELECT($DATA(^DIC(25,+$PIECE(DGRPX,"^",DGRPSV),0)):$EXTRACT($PIECE(^(0),"^",1),1,9),1:"UNKNOWN")
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 ;
