VADPT4 ;ALB/MRL,MJK,ERC,DIC,PWC,ARF,JMM - PATIENT VARIABLES ;12 DEC 1988 ;10/13/10 4:43pm
;;5.3;Registration;**343,342,528,689,688,790,797,935,952,1007,1018,1090,1103,1118,1121**;Aug 13, 1993;Build 14
7 ;Eligibility [ELIG]
F I=.15,.3,.31,.32,.36,.361,"INE","TYPE","VET" S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
S VAZ=$P(VAX(.36),"^",1) S:$D(^DIC(8,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",1))=VAZ
S VAX=0 F I=0:0 S VAX=$O(^DPT(DFN,"E",VAX)) Q:VAX'>0 S VAZ=VAX I $D(^DIC(8,+VAZ,0)),+@VAV@($P(VAS,"^"))'=VAZ S VAZ=VAZ_"^"_$P(^DIC(8,+VAZ,0),"^") S @VAV@($P(VAS,"^",1),VAX)=VAZ
S VAZ=$P(VAX(.32),"^",3) S:$D(^DIC(21,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",2))=VAZ
S VAZ=$S($P(VAX(.3),"^",1)="Y":1,1:0) S:VAZ VAZ=VAZ_"^"_$P(VAX(.3),"^",2) S @VAV@($P(VAS,"^",3))=VAZ
S @VAV@($P(VAS,"^",4))=$S(VAX("VET")="Y":1,1:0),VAZ=$S(+$P(VAX(.15),"^",2):0,1:1),@VAV@($P(VAS,"^",5))=VAZ
I VAZ F I=1:1:6 S @VAV@($P(VAS,"^",5),I)="" G 71
S VAZ=$P(VAX(.15),"^",2),Y=VAZ X ^DD("DD") S @VAV@($P(VAS,"^",5),1)=VAZ_"^"_Y,VAZ=$P(VAX("INE"),"^",1) S:VAZ]"" VAZ=VAZ_"^"_$P("VAMC^REGIONAL OFFICE^RPC","^",VAZ) S @VAV@($P(VAS,"^",5),2)=VAZ
S @VAV@($P(VAS,"^",5),3)=$P(VAX("INE"),"^",3),VAZ=$P(VAX("INE"),"^",4) S:$D(^DIC(5,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",5),4)=VAZ
S @VAV@($P(VAS,"^",5),5)=$P(VAX("INE"),"^",6),@VAV@($P(VAS,"^",5),6)=$P(VAX(.3),"^",7)
71 S VAZ=VAX("TYPE") S:$D(^DG(391,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",6))=VAZ
S @VAV@($P(VAS,"^",7))=$P(VAX(.31),"^",3),VAZ=$P(VAX(.361),"^",1) S:VAZ]"" VAZ=VAZ_"^"_$S(VAZ="V":"VERIFIED",VAZ="P":"PENDING VERIFICATION",VAZ="R":"PENDING RE-VERIFICATION",1:"") S @VAV@($P(VAS,"^",8))=VAZ
I $D(^DPT(DFN,0)) S VAX=$P(^(0),"^",14),VAX=$G(^DG(408.32,+VAX,0)) I VAX]"" S @VAV@($P(VAS,"^",9))=$P(VAX,"^",2)_"^"_$P(VAX,"^",1)
S VAX=$G(^DPT(DFN,.55)) S @VAV@($P(VAS,"^",10))=VAX_$S(VAX]"":"^",1:"")_$$GET1^DIQ(2,DFN_",",.5501,"E")
Q
;
8 ;Monetary Benefits [MB]
N DGTOTVA
S @VAV@($P(VAS,"^",6))=0 ; SSI no longer supported
D ALL^DGMTU21(DFN,"V",DT,"I")
S VAX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) F I=8,11,13 S @VAV@($S(I=8:$P(VAS,"^",3),I=11:$P(VAS,"^",5),1:$P(VAS,"^",8)))=$S($P(VAX,"^",I)'="":"1^"_$P(VAX,"^",I),1:0)
S VAX=$G(^DPT(DFN,.362))
S DGTOTVA=$P(VAX,U,20)
F I=12,13,14 S @VAV@($S(I=12:$P(VAS,"^",1),(I=13):$P(VAS,"^",2),1:$P(VAS,"^",4)))=$S($P(VAX,"^",I)="Y":1_U_DGTOTVA,1:0)
S I=17 S @VAV@($P(VAS,"^",9))=$S($P(VAX,"^",17)="Y":1_U_$P(VAX,U,6),1:0)
S VAX=$G(^DPT(DFN,.3)) S @VAV@($P(VAS,"^",7))=$S($P(VAX,"^",11)="Y":1_U_DGTOTVA,1:0)
K DGDEP,DGREL,DGINC,DGINR Q
;
9 ;Service information
F I=.32,.321,.3291,.52,.53 S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
D:$D(^DPT(DFN,.3216)) MSDS
S VAX("N")=.321 F I=1,2,3 S VAX(3)=I,VAZ=$S($P(VAX(.321),"^",I)="Y":1,1:0),@VAV@($P(VAS,"^",VAX(3)))=VAZ I VAZ S VAX(1)=$S(I=1:"4^5",I=2:"7^9^8",1:11),VAX(4)=0 D 91
S VAX("N")=.52 F I=5,11 S VAX(3)=$S(I=5:4,1:5),VAX(1)=$S(I=5:"7^8",1:"13^14"),VAZ=$S($P(VAX(.52),"^",I)="Y":1,1:0),@VAV@($P(VAS,"^",VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91
;Combat Vet
S VAX(3)=10,VAX(1)="15",VAZ=$S($P(VAX(.52),U,15)]"":1,1:0),@VAV@($P(VAS,U,VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91
F I=6,7,8 S @VAV@($P(VAS,"^",I))="" F VAX(1)=1:1:6 S @VAV@($P(VAS,"^",I),VAX(1))=""
S VAX("N")=.32,VAZ=$S($P(VAX(.32),"^",5)]"":1,1:0),@VAV@($P(VAS,"^",6))=VAZ I VAZ,$P(VAX(.32),"^",19)="Y" S VAZ=1,@VAV@($P(VAS,"^",7))=VAZ I VAZ,$P(VAX(.32),"^",20)="Y" S @VAV@($P(VAS,"^",8))=1
F I=6,7,8 I @VAV@($P(VAS,"^",I)) S VAX(3)=I,VAX(1)=$S(I=6:"6^7",I=7:"11^12",1:"16^17"),VAX(4)=3 D 91
S VAX("N")=.3291
F I=6,7,8 I @VAV@($P(VAS,"^",I)) S VAX(3)=I,VAX(1)=I-5,VAX(4)=6 D 94
S VAX("N")=.53,VAX(3)=9,VAX(1)="2^3",VAZ=$S($P(VAX(.53),U)="Y":1,$P(VAX(.53),U)="N":1,1:0),@VAV@($P(VAS,U,VAX(3)))=$S($P(VAX(.53),U)="Y":1,$P(VAX(.53),U)="N":0,1:"") I VAZ S VAX(4)=0 D 93
S VAX("N")=.3215,VAZ=$$GET^DGENOEIF(DFN,.VAZ,1)
;OEF/OIF
F I=11,12,13 S @VAV@(I)=+$G(VAZ($P("OIF^OEF^UNK",U,I-10),"COUNT"))
S VAX(2)=11
F I="OIF","OEF","UNK" S VAX=0 F S VAX=$O(VAZ(I,VAX)) S:'VAX VAX(2)=VAX(2)+1 Q:'VAX S VAX(3)=0 D
. N Z
. F VAX(1)="LOC","FR","TO" S VAX(3)=VAX(3)+1,Z=$G(VAZ(I,VAX,VAX(1))),@VAV@(VAX(2),VAX,VAX(3))=Z D 95
;SHAD - added with DG*5.3*688
S VAX(3)=14,VAZ=$S($P(VAX(.321),U,15)]"":1,1:0),@VAV@($P(VAS,U,VAX(3)))=VAZ I VAZ S @VAV@($P(VAS,U,VAX(3)),1)=$S($P(VAX(.321),U,15)=1:"1^YES",1:"0^NO")
; DG*5.3*1103 - add TERA indicator
; DG*5.3*1118 - add UNKNOWN to the TERA indicator
S VAX(3)=15,VAZ=$S($P(VAX(.321),U,16)=1:"1^YES",$P(VAX(.321),U,16)=0:"0^NO",1:"^UNKNOWN"),@VAV@($P(VAS,U,VAX(3)))=VAZ
;
; DG*5.3*1121 - add Persian Gulf Indicator and Last Change date
S VAX(3)=16,VAZ=$S($P(VAX(.321),U,17)=1:"1^YES",$P(VAX(.321),U,17)=0:"0^NO",1:"^UNKNOWN"),@VAV@($P(VAS,U,VAX(3)))=VAZ
S VAX(3)=17,VAZ=$S($P(VAX(.321),U,18)]"":1,1:0) I VAZ S Y=$P(VAX(.321),U,18) X:Y]"" ^DD("DD") S VAZ=$P(VAX(.321),U,18)_"^"_Y,@VAV@($P(VAS,U,VAX(3)))=VAZ
;
Q
;
91 ;date fields
F VAX(2)=1:1 S VAX(4)=VAX(4)+1,X=+$P(VAX(1),"^",VAX(2)) Q:'X S X=$P(VAX(VAX("N")),"^",X),VAZ=X,Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=$S(VAZ]"":VAZ_"^"_Y,1:"")
Q:VAX(3)=1!(VAX(3)=9)!(VAX(3)=10)
;some sets of codes ;DG*5.3*1018 corrected the external code stored in the array for the AGENT ORANGE EXPOSURE LOCATION field (#.3213)
I VAX(3)=2 S @VAV@($P(VAS,"^",2),4)=$P(VAX(.321),"^",10) S (X,VAZ)=$P(VAX(.321),"^",13) S:X]"" VAZ=VAZ_"^"_$$GET1^DIQ(2,DFN,.3213,"E") S @VAV@($P(VAS,"^",2),5)=VAZ Q
I VAX(3)<4 S X=$P(VAX(.321),"^",12),VAZ=X D
.;DG*5.3*1090 Modified the RADIATION EXPOSURE METHOD (#2,.3212) to get updated field definitions
.I X]"" S VAZ=VAZ_"^"_$$GET1^DIQ(2,DFN,.3212,"E")
.S @VAV@($P(VAS,"^",3),2)=VAZ Q
;POW, combat locations
I VAX(3)<6 S X=$P(VAX(VAX("N")),"^",$S(VAX(3)=4:6,1:12)),VAZ=X S:$D(^DIC(22,+X,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",VAX(3)),3)=VAZ Q
;service episodes
S X=$S(VAX(3)=6:5,VAX(3)=7:10,1:15),VAX(2)=0 F VAX(5)=X,X+3,X-1 S VAX(2)=VAX(2)+1,VAZ=$P(VAX(VAX("N")),"^",VAX(5)),@VAV@($P(VAS,"^",VAX(3)),VAX(2))=VAZ I "^4^5^9^10^14^15^"[("^"_VAX(5)_"^"),+VAZ D 92
Q
92 ;pointers to Branch of Service (23) and Type Discharge (25)
S VAX(6)="^DIC("_$S('(VAX(5)#5):23,1:25)_","_+VAZ_",0)" I $D(@(VAX(6))) S VAZ=$P(^(0),"^",1),@VAV@($P(VAS,"^",VAX(3)),VAX(2))=@VAV@($P(VAS,"^",VAX(3)),VAX(2))_"^"_VAZ
Q
93 ;Purple Heart
NEW VAFILE,VAIENS,VAFLDS,VAARR,VAI
S VAFILE=2,VAIENS=DFN_",",VAFLDS=".532;.533"
D GETS^DIQ(VAFILE,VAIENS,VAFLDS,"IEN","VAARR")
F VAI=1:1 S VAFLDS(VAI)=$P(VAFLDS,";",VAI) Q:VAFLDS(VAI)="" D
. I '$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I")),'$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E")) S @VAV@($P(VAS,"^",VAX(3)),VAI)=""
. E S @VAV@($P(VAS,U,VAX(3)),VAI)=$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I"))_"^"_$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E"))
Q
94 ;more military service
N VASVCI,VASVCE
;DG*5.3*1007 No longer using Fileman lookup to get Military Service Component
;S VAIENS=DFN_",",VAFLDS=".3291"_VAX(1)
;D GETS^DIQ(2,VAIENS,VAFLDS,"IEN","VAARR")
;I $G(VAARR(2,VAIENS,VAFLDS,"I"))'="" D
;. S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=$G(VAARR(2,VAIENS,VAFLDS,"I"))_"^"_$G(VAARR(2,VAIENS,VAFLDS,"E"))
;DG*5.3*1007 Using Military Service Component data extracted from the .3291 field or .3216 sub-file
I $G(VAX(.3291))'="" D
. S VASVCI=$S(VAX(3)=6:$P(VAX(.3291),"^",1),VAX(3)=7:$P(VAX(.3291),"^",2),VAX(3)=8:$P(VAX(.3291),"^",3),1:0)
. S VASVCE=$S(VASVCI="R":"REGULAR",VASVCI="V":"ACTIVATED RESERVE",VASVCI="G":"ACTIVATED NG",1:0)
. S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=VASVCI_"^"_VASVCE
Q
;
95 ;OEF/OIF
N X,Y
I VAX(3)=1 S $P(@VAV@(VAX(2),VAX,VAX(3)),U,2)=$$EXTERNAL^DILFD(2.3215,.01,"",Z)
I VAX(3)=2!(VAX(3)=3) S Y=Z X ^DD("DD") S:Y'="" $P(@VAV@(VAX(2),VAX,VAX(3)),U,2)=Y
Q
;
MSDS ;Returns latest service episodes from ESR sourced data
N BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,I,SDATE,SERVNO,SUB
S COUNT=0,EDATE=""
;Clear military service discharge, branch, start, end and number info
F I=4:1:20 S $P(VAX(.32),U,I)=""
;Clear military service component info
F I=1:1:3 S $P(VAX(.3291),U,I)=""
;Scan back for three most recent service episodes
F S EDATE=$O(^DPT(DFN,.3216,"B",EDATE),-1) Q:'EDATE D Q:COUNT'<3
.S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA
.;DJS, skip an MSE that has Future Discharge Date; DG*5.3*935
.S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""!($P(EDATA,U,8)'="")
.S COUNT=COUNT+1,SDATE=$P(EDATA,U,2)
.S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4)
.S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6)
.;SL = 4, SNL = 9 or SNNL = 14
.S SUB=(COUNT*5)-1
.S $P(VAX(.32),U,SUB)=DTYP
.S $P(VAX(.32),U,SUB+1)=BRANCH
.S $P(VAX(.32),U,SUB+2)=EDATE
.S $P(VAX(.32),U,SUB+3)=SDATE
.S $P(VAX(.32),U,SUB+4)=SERVNO
.S $P(VAX(.3291),U,COUNT)=COMP
.S:SUB=9 $P(VAX(.32),U,19)="Y"
.S:SUB=14 $P(VAX(.32),U,20)="Y"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVADPT4 8876 printed Sep 23, 2025@20:37:12 Page 2
VADPT4 ;ALB/MRL,MJK,ERC,DIC,PWC,ARF,JMM - PATIENT VARIABLES ;12 DEC 1988 ;10/13/10 4:43pm
+1 ;;5.3;Registration;**343,342,528,689,688,790,797,935,952,1007,1018,1090,1103,1118,1121**;Aug 13, 1993;Build 14
7 ;Eligibility [ELIG]
+1 FOR I=.15,.3,.31,.32,.36,.361,"INE","TYPE","VET"
SET VAX(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+2 SET VAZ=$PIECE(VAX(.36),"^",1)
if $DATA(^DIC(8,+VAZ,0))
SET VAZ=VAZ_"^"_$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",1))=VAZ
+3 SET VAX=0
FOR I=0:0
SET VAX=$ORDER(^DPT(DFN,"E",VAX))
if VAX'>0
QUIT
SET VAZ=VAX
IF $DATA(^DIC(8,+VAZ,0))
IF +@VAV@($PIECE(VAS,"^"))'=VAZ
SET VAZ=VAZ_"^"_$PIECE(^DIC(8,+VAZ,0),"^")
SET @VAV@($PIECE(VAS,"^",1),VAX)=VAZ
+4 SET VAZ=$PIECE(VAX(.32),"^",3)
if $DATA(^DIC(21,+VAZ,0))
SET VAZ=VAZ_"^"_$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",2))=VAZ
+5 SET VAZ=$SELECT($PIECE(VAX(.3),"^",1)="Y":1,1:0)
if VAZ
SET VAZ=VAZ_"^"_$PIECE(VAX(.3),"^",2)
SET @VAV@($PIECE(VAS,"^",3))=VAZ
+6 SET @VAV@($PIECE(VAS,"^",4))=$SELECT(VAX("VET")="Y":1,1:0)
SET VAZ=$SELECT(+$PIECE(VAX(.15),"^",2):0,1:1)
SET @VAV@($PIECE(VAS,"^",5))=VAZ
+7 IF VAZ
FOR I=1:1:6
SET @VAV@($PIECE(VAS,"^",5),I)=""
GOTO 71
+8 SET VAZ=$PIECE(VAX(.15),"^",2)
SET Y=VAZ
XECUTE ^DD("DD")
SET @VAV@($PIECE(VAS,"^",5),1)=VAZ_"^"_Y
SET VAZ=$PIECE(VAX("INE"),"^",1)
if VAZ]""
SET VAZ=VAZ_"^"_$PIECE("VAMC^REGIONAL OFFICE^RPC","^",VAZ)
SET @VAV@($PIECE(VAS,"^",5),2)=VAZ
+9 SET @VAV@($PIECE(VAS,"^",5),3)=$PIECE(VAX("INE"),"^",3)
SET VAZ=$PIECE(VAX("INE"),"^",4)
if $DATA(^DIC(5,+VAZ,0))
SET VAZ=VAZ_"^"_$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",5),4)=VAZ
+10 SET @VAV@($PIECE(VAS,"^",5),5)=$PIECE(VAX("INE"),"^",6)
SET @VAV@($PIECE(VAS,"^",5),6)=$PIECE(VAX(.3),"^",7)
71 SET VAZ=VAX("TYPE")
if $DATA(^DG(391,+VAZ,0))
SET VAZ=VAZ_"^"_$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",6))=VAZ
+1 SET @VAV@($PIECE(VAS,"^",7))=$PIECE(VAX(.31),"^",3)
SET VAZ=$PIECE(VAX(.361),"^",1)
if VAZ]""
SET VAZ=VAZ_"^"_$SELECT(VAZ="V":"VERIFIED",VAZ="P":"PENDING VERIFICATION",VAZ="R":"PENDING RE-VERIFICATION",1:"")
SET @VAV@($PIECE(VAS,"^",8))=VAZ
+2 IF $DATA(^DPT(DFN,0))
SET VAX=$PIECE(^(0),"^",14)
SET VAX=$GET(^DG(408.32,+VAX,0))
IF VAX]""
SET @VAV@($PIECE(VAS,"^",9))=$PIECE(VAX,"^",2)_"^"_$PIECE(VAX,"^",1)
+3 SET VAX=$GET(^DPT(DFN,.55))
SET @VAV@($PIECE(VAS,"^",10))=VAX_$SELECT(VAX]"":"^",1:"")_$$GET1^DIQ(2,DFN_",",.5501,"E")
+4 QUIT
+5 ;
8 ;Monetary Benefits [MB]
+1 NEW DGTOTVA
+2 ; SSI no longer supported
SET @VAV@($PIECE(VAS,"^",6))=0
+3 DO ALL^DGMTU21(DFN,"V",DT,"I")
+4 SET VAX=$GET(^DGMT(408.21,+$GET(DGINC("V")),0))
FOR I=8,11,13
SET @VAV@($SELECT(I=8:$PIECE(VAS,"^",3),I=11:$PIECE(VAS,"^",5),1:$PIECE(VAS,"^",8)))=$SELECT($PIECE(VAX,"^",I)'="":"1^"_$PIECE(VAX,"^",I),1:0)
+5 SET VAX=$GET(^DPT(DFN,.362))
+6 SET DGTOTVA=$PIECE(VAX,U,20)
+7 FOR I=12,13,14
SET @VAV@($SELECT(I=12:$PIECE(VAS,"^",1),(I=13):$PIECE(VAS,"^",2),1:$PIECE(VAS,"^",4)))=$SELECT($PIECE(VAX,"^",I)="Y":1_U_DGTOTVA,1:0)
+8 SET I=17
SET @VAV@($PIECE(VAS,"^",9))=$SELECT($PIECE(VAX,"^",17)="Y":1_U_$PIECE(VAX,U,6),1:0)
+9 SET VAX=$GET(^DPT(DFN,.3))
SET @VAV@($PIECE(VAS,"^",7))=$SELECT($PIECE(VAX,"^",11)="Y":1_U_DGTOTVA,1:0)
+10 KILL DGDEP,DGREL,DGINC,DGINR
QUIT
+11 ;
9 ;Service information
+1 FOR I=.32,.321,.3291,.52,.53
SET VAX(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+2 if $DATA(^DPT(DFN,.3216))
DO MSDS
+3 SET VAX("N")=.321
FOR I=1,2,3
SET VAX(3)=I
SET VAZ=$SELECT($PIECE(VAX(.321),"^",I)="Y":1,1:0)
SET @VAV@($PIECE(VAS,"^",VAX(3)))=VAZ
IF VAZ
SET VAX(1)=$SELECT(I=1:"4^5",I=2:"7^9^8",1:11)
SET VAX(4)=0
DO 91
+4 SET VAX("N")=.52
FOR I=5,11
SET VAX(3)=$SELECT(I=5:4,1:5)
SET VAX(1)=$SELECT(I=5:"7^8",1:"13^14")
SET VAZ=$SELECT($PIECE(VAX(.52),"^",I)="Y":1,1:0)
SET @VAV@($PIECE(VAS,"^",VAX(3)))=VAZ
IF VAZ
SET VAX(4)=0
DO 91
+5 ;Combat Vet
+6 SET VAX(3)=10
SET VAX(1)="15"
SET VAZ=$SELECT($PIECE(VAX(.52),U,15)]"":1,1:0)
SET @VAV@($PIECE(VAS,U,VAX(3)))=VAZ
IF VAZ
SET VAX(4)=0
DO 91
+7 FOR I=6,7,8
SET @VAV@($PIECE(VAS,"^",I))=""
FOR VAX(1)=1:1:6
SET @VAV@($PIECE(VAS,"^",I),VAX(1))=""
+8 SET VAX("N")=.32
SET VAZ=$SELECT($PIECE(VAX(.32),"^",5)]"":1,1:0)
SET @VAV@($PIECE(VAS,"^",6))=VAZ
IF VAZ
IF $PIECE(VAX(.32),"^",19)="Y"
SET VAZ=1
SET @VAV@($PIECE(VAS,"^",7))=VAZ
IF VAZ
IF $PIECE(VAX(.32),"^",20)="Y"
SET @VAV@($PIECE(VAS,"^",8))=1
+9 FOR I=6,7,8
IF @VAV@($PIECE(VAS,"^",I))
SET VAX(3)=I
SET VAX(1)=$SELECT(I=6:"6^7",I=7:"11^12",1:"16^17")
SET VAX(4)=3
DO 91
+10 SET VAX("N")=.3291
+11 FOR I=6,7,8
IF @VAV@($PIECE(VAS,"^",I))
SET VAX(3)=I
SET VAX(1)=I-5
SET VAX(4)=6
DO 94
+12 SET VAX("N")=.53
SET VAX(3)=9
SET VAX(1)="2^3"
SET VAZ=$SELECT($PIECE(VAX(.53),U)="Y":1,$PIECE(VAX(.53),U)="N":1,1:0)
SET @VAV@($PIECE(VAS,U,VAX(3)))=$SELECT($PIECE(VAX(.53),U)="Y":1,$PIECE(VAX(.53),U)="N":0,1:"")
IF VAZ
SET VAX(4)=0
DO 93
+13 SET VAX("N")=.3215
SET VAZ=$$GET^DGENOEIF(DFN,.VAZ,1)
+14 ;OEF/OIF
+15 FOR I=11,12,13
SET @VAV@(I)=+$GET(VAZ($PIECE("OIF^OEF^UNK",U,I-10),"COUNT"))
+16 SET VAX(2)=11
+17 FOR I="OIF","OEF","UNK"
SET VAX=0
FOR
SET VAX=$ORDER(VAZ(I,VAX))
if 'VAX
SET VAX(2)=VAX(2)+1
if 'VAX
QUIT
SET VAX(3)=0
Begin DoDot:1
+18 NEW Z
+19 FOR VAX(1)="LOC","FR","TO"
SET VAX(3)=VAX(3)+1
SET Z=$GET(VAZ(I,VAX,VAX(1)))
SET @VAV@(VAX(2),VAX,VAX(3))=Z
DO 95
End DoDot:1
+20 ;SHAD - added with DG*5.3*688
+21 SET VAX(3)=14
SET VAZ=$SELECT($PIECE(VAX(.321),U,15)]"":1,1:0)
SET @VAV@($PIECE(VAS,U,VAX(3)))=VAZ
IF VAZ
SET @VAV@($PIECE(VAS,U,VAX(3)),1)=$SELECT($PIECE(VAX(.321),U,15)=1:"1^YES",1:"0^NO")
+22 ; DG*5.3*1103 - add TERA indicator
+23 ; DG*5.3*1118 - add UNKNOWN to the TERA indicator
+24 SET VAX(3)=15
SET VAZ=$SELECT($PIECE(VAX(.321),U,16)=1:"1^YES",$PIECE(VAX(.321),U,16)=0:"0^NO",1:"^UNKNOWN")
SET @VAV@($PIECE(VAS,U,VAX(3)))=VAZ
+25 ;
+26 ; DG*5.3*1121 - add Persian Gulf Indicator and Last Change date
+27 SET VAX(3)=16
SET VAZ=$SELECT($PIECE(VAX(.321),U,17)=1:"1^YES",$PIECE(VAX(.321),U,17)=0:"0^NO",1:"^UNKNOWN")
SET @VAV@($PIECE(VAS,U,VAX(3)))=VAZ
+28 SET VAX(3)=17
SET VAZ=$SELECT($PIECE(VAX(.321),U,18)]"":1,1:0)
IF VAZ
SET Y=$PIECE(VAX(.321),U,18)
if Y]""
XECUTE ^DD("DD")
SET VAZ=$PIECE(VAX(.321),U,18)_"^"_Y
SET @VAV@($PIECE(VAS,U,VAX(3)))=VAZ
+29 ;
+30 QUIT
+31 ;
91 ;date fields
+1 FOR VAX(2)=1:1
SET VAX(4)=VAX(4)+1
SET X=+$PIECE(VAX(1),"^",VAX(2))
if 'X
QUIT
SET X=$PIECE(VAX(VAX("N")),"^",X)
SET VAZ=X
SET Y=VAZ
if Y]""
XECUTE ^DD("DD")
SET @VAV@($PIECE(VAS,"^",VAX(3)),VAX(4))=$SELECT(VAZ]"":VAZ_"^"_Y,1:"")
+2 if VAX(3)=1!(VAX(3)=9)!(VAX(3)=10)
QUIT
+3 ;some sets of codes ;DG*5.3*1018 corrected the external code stored in the array for the AGENT ORANGE EXPOSURE LOCATION field (#.3213)
+4 IF VAX(3)=2
SET @VAV@($PIECE(VAS,"^",2),4)=$PIECE(VAX(.321),"^",10)
SET (X,VAZ)=$PIECE(VAX(.321),"^",13)
if X]""
SET VAZ=VAZ_"^"_$$GET1^DIQ(2,DFN,.3213,"E")
SET @VAV@($PIECE(VAS,"^",2),5)=VAZ
QUIT
+5 IF VAX(3)<4
SET X=$PIECE(VAX(.321),"^",12)
SET VAZ=X
Begin DoDot:1
+6 ;DG*5.3*1090 Modified the RADIATION EXPOSURE METHOD (#2,.3212) to get updated field definitions
+7 IF X]""
SET VAZ=VAZ_"^"_$$GET1^DIQ(2,DFN,.3212,"E")
+8 SET @VAV@($PIECE(VAS,"^",3),2)=VAZ
QUIT
End DoDot:1
+9 ;POW, combat locations
+10 IF VAX(3)<6
SET X=$PIECE(VAX(VAX("N")),"^",$SELECT(VAX(3)=4:6,1:12))
SET VAZ=X
if $DATA(^DIC(22,+X,0))
SET VAZ=VAZ_"^"_$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",VAX(3)),3)=VAZ
QUIT
+11 ;service episodes
+12 SET X=$SELECT(VAX(3)=6:5,VAX(3)=7:10,1:15)
SET VAX(2)=0
FOR VAX(5)=X,X+3,X-1
SET VAX(2)=VAX(2)+1
SET VAZ=$PIECE(VAX(VAX("N")),"^",VAX(5))
SET @VAV@($PIECE(VAS,"^",VAX(3)),VAX(2))=VAZ
IF "^4^5^9^10^14^15^"[("^"_VAX(5)_"^")
IF +VAZ
DO 92
+13 QUIT
92 ;pointers to Branch of Service (23) and Type Discharge (25)
+1 SET VAX(6)="^DIC("_$SELECT('(VAX(5)#5):23,1:25)_","_+VAZ_",0)"
IF $DATA(@(VAX(6)))
SET VAZ=$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",VAX(3)),VAX(2))=@VAV@($PIECE(VAS,"^",VAX(3)),VAX(2))_"^"_VAZ
+2 QUIT
93 ;Purple Heart
+1 NEW VAFILE,VAIENS,VAFLDS,VAARR,VAI
+2 SET VAFILE=2
SET VAIENS=DFN_","
SET VAFLDS=".532;.533"
+3 DO GETS^DIQ(VAFILE,VAIENS,VAFLDS,"IEN","VAARR")
+4 FOR VAI=1:1
SET VAFLDS(VAI)=$PIECE(VAFLDS,";",VAI)
if VAFLDS(VAI)=""
QUIT
Begin DoDot:1
+5 IF '$DATA(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I"))
IF '$DATA(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E"))
SET @VAV@($PIECE(VAS,"^",VAX(3)),VAI)=""
+6 IF '$TEST
SET @VAV@($PIECE(VAS,U,VAX(3)),VAI)=$GET(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I"))_"^"_$GET(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E"))
End DoDot:1
+7 QUIT
94 ;more military service
+1 NEW VASVCI,VASVCE
+2 ;DG*5.3*1007 No longer using Fileman lookup to get Military Service Component
+3 ;S VAIENS=DFN_",",VAFLDS=".3291"_VAX(1)
+4 ;D GETS^DIQ(2,VAIENS,VAFLDS,"IEN","VAARR")
+5 ;I $G(VAARR(2,VAIENS,VAFLDS,"I"))'="" D
+6 ;. S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=$G(VAARR(2,VAIENS,VAFLDS,"I"))_"^"_$G(VAARR(2,VAIENS,VAFLDS,"E"))
+7 ;DG*5.3*1007 Using Military Service Component data extracted from the .3291 field or .3216 sub-file
+8 IF $GET(VAX(.3291))'=""
Begin DoDot:1
+9 SET VASVCI=$SELECT(VAX(3)=6:$PIECE(VAX(.3291),"^",1),VAX(3)=7:$PIECE(VAX(.3291),"^",2),VAX(3)=8:$PIECE(VAX(.3291),"^",3),1:0)
+10 SET VASVCE=$SELECT(VASVCI="R":"REGULAR",VASVCI="V":"ACTIVATED RESERVE",VASVCI="G":"ACTIVATED NG",1:0)
+11 SET @VAV@($PIECE(VAS,"^",VAX(3)),VAX(4))=VASVCI_"^"_VASVCE
End DoDot:1
+12 QUIT
+13 ;
95 ;OEF/OIF
+1 NEW X,Y
+2 IF VAX(3)=1
SET $PIECE(@VAV@(VAX(2),VAX,VAX(3)),U,2)=$$EXTERNAL^DILFD(2.3215,.01,"",Z)
+3 IF VAX(3)=2!(VAX(3)=3)
SET Y=Z
XECUTE ^DD("DD")
if Y'=""
SET $PIECE(@VAV@(VAX(2),VAX,VAX(3)),U,2)=Y
+4 QUIT
+5 ;
MSDS ;Returns latest service episodes from ESR sourced data
+1 NEW BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,I,SDATE,SERVNO,SUB
+2 SET COUNT=0
SET EDATE=""
+3 ;Clear military service discharge, branch, start, end and number info
+4 FOR I=4:1:20
SET $PIECE(VAX(.32),U,I)=""
+5 ;Clear military service component info
+6 FOR I=1:1:3
SET $PIECE(VAX(.3291),U,I)=""
+7 ;Scan back for three most recent service episodes
+8 FOR
SET EDATE=$ORDER(^DPT(DFN,.3216,"B",EDATE),-1)
if 'EDATE
QUIT
Begin DoDot:1
+9 SET DA=$ORDER(^DPT(DFN,.3216,"B",EDATE,0))
if 'DA
QUIT
+10 ;DJS, skip an MSE that has Future Discharge Date; DG*5.3*935
+11 SET EDATA=$GET(^DPT(DFN,.3216,DA,0))
if EDATA=""!($PIECE(EDATA,U,8)'="")
QUIT
+12 SET COUNT=COUNT+1
SET SDATE=$PIECE(EDATA,U,2)
+13 SET BRANCH=$PIECE(EDATA,U,3)
SET COMP=$PIECE(EDATA,U,4)
+14 SET SERVNO=$PIECE(EDATA,U,5)
SET DTYP=$PIECE(EDATA,U,6)
+15 ;SL = 4, SNL = 9 or SNNL = 14
+16 SET SUB=(COUNT*5)-1
+17 SET $PIECE(VAX(.32),U,SUB)=DTYP
+18 SET $PIECE(VAX(.32),U,SUB+1)=BRANCH
+19 SET $PIECE(VAX(.32),U,SUB+2)=EDATE
+20 SET $PIECE(VAX(.32),U,SUB+3)=SDATE
+21 SET $PIECE(VAX(.32),U,SUB+4)=SERVNO
+22 SET $PIECE(VAX(.3291),U,COUNT)=COMP
+23 if SUB=9
SET $PIECE(VAX(.32),U,19)="Y"
+24 if SUB=14
SET $PIECE(VAX(.32),U,20)="Y"
End DoDot:1
if COUNT'<3
QUIT
+25 QUIT
