DGPTRNU ;ISF/GJW,HIOFO/FT - PTF TRANSMISSION ;2/18/15 2:28pm
;;5.3;Registration;**884**;Aug 13, 1993;Build 31
;
;XLFDT - #10103
;
FDATE(DGDT,DGDF) ;format date as MMDDYY
;Format options
;1 - MMDDYY
;2 - MMDDYYYY
N X,MON,DAY,YR,VAL
S DGDF=$G(DGDF,1) ;default to 2-digit date
S X=$$FMTE^XLFDT(DGDT,"5ZP")
S MON=$P(X,"/")
S DAY=$P(X,"/",2)
S YR=$P(X,"/",3)
S:DGDF=1 VAL=MON_DAY_$E(YR,3,4)
S:DGDF=2 VAL=MON_DAY_YR
Q $S(+DGDT'>0:"",1:VAL)
;
TIME(DTM) ;extract time in HHMM format from date/time
N X,Y,H,M
S X=$$FMTE^XLFDT(DTM,"6F")
S Y=$P(X,"@",2)
S H=$P(Y,":"),M=$P(Y,":",2)
Q H_M
;
FMTICD(DGC) ;format ICD code for transmission
Q $TR(DGC,".","")
;
;Retrieve nodes from PTF CLOSE OUT (#45.84) where appropriate
GETNODE(DGPTF,DGHOW,DGNODE) ;
;DGHOW = 1 - use PTF CLOSE OUT node if defined, PTF otherwise
;DGHOW = 2 - use PTF file
;DGHOW = 3 - use PTF CLOSE OUT record (forced)
N VAL,DFN,COUT,IENS45,IENS2,FLD,NODE
;the field numbers for the various STORE(*) fields
S NODE=$S(DGNODE=0:0,DGNODE=32:.32,DGNODE=321:.321,DGNODE=52:.52,1:"")
S FLD=$S(DGNODE=0:10,DGNODE=11:11,DGNODE=52:12,DGNODE=321:13,DGNODE=32:14,DGNODE=57:15,.3:16,1:0)
S VAL=""
S IENS45=DGPTF_","
S COUT=$$GET1^DIQ(45,IENS45,7.1,"I") ;corresponding entry in PTF CLOSE OUT file
S DFN=$$GET1^DIQ(45,IENS45,.01,"I") ;ft 2/12/15
I DGHOW'=3 D
.S DFN=$$GET1^DIQ(45,IENS45,.01,"I")
.S IENS2=$G(DFN)_","
I DGHOW=1 S VAL=$S(COUT:$$GET1^DIQ(45.84,COUT_",",FLD),1:$G(^DPT(DFN,DGNODE)))
I DGHOW=2 S VAL=$G(^DPT(DFN,.321))
I DGHOW=3 S VAL=$$GET1^DIQ(45.84,COUT_",",FLD)
Q VAL
;
;convenience routines for commonly used nodes
GET0(DGPTF,DGHOW) ;
S DGHOW=$G(DGHOW,1)
Q $$GETNODE(DGPTF,DGHOW,0)
;
GET32(DGPTF,DGHOW) ;
S DGHOW=$G(DGHOW,1)
Q $$GETNODE(DGPTF,DGHOW,.32)
;
GET321(DGPTF,DGHOW) ;
S DGHOW=$G(DGHOW,1)
Q $$GETNODE(DGPTF,DGHOW,.321)
;
GET52(DGPTF,DGHOW) ;
S DGHOW=$G(DGHOW,1)
Q $$GETNODE(DGPTF,DGHOW,.52)
;
POW(DGPTF) ;POW status
;returns
;1 - not a POW
;3 - POW, unknown
;4 - POW, World War I
;5 - POW, World War II (Europe)
;6 - POW, World War II (Pacific)
;7 - POW, Korea
;8 - POW, Vietnam
;9 - POW, combination
N DG52,SI,PP,Y,VAL
S DG52=$$GET52^DGPTRNU(DGPTF)
S SI=$P(DG52,U,5) ;POW status indicated?,
S Y=$P(DG52,U,6) ;POW period
S VAL=1
I SI="Y" D
.S VAL=$S(Y=0:3,Y=2:5,Y=3:6,Y=4:7,Y=5:8,Y=6:9,Y=7:"A",Y=8:"B",1:" ")
Q VAL
;
PDIS(DGPTF) ;place of disposition
N IENS,IENS1,X
S IENS=DGPTF_","
S X=$$GET1^DIQ(45,IENS,75,"I"),IENS1=X_","
Q $$GET1^DIQ(45.6,IENS1,2) ;PTF code
;
POS(DGPTF) ;period of service
N IENS45,DG32,POS1,POS,MV,ELIG
S IENS45=DGPTF_","
S DG32=$$GET32^DGPTRNU(DGPTF)
S POS1=$P(DG32,U,3) ;period of service from PATIENT file (pointer to file #21)
S POS=$$GET1^DIQ(21,POS1_",",.03) ;code
;Now, use the "APTF" cross-reference on the PATIENT MOVEMENT (#405) file to look up
;the patient movement associated with this PTF entry
S MV="" S:$D(^DGPM("APTF",PTF)) MV=$O(^DGPM("APTF",PTF,0))
;If the patient movement has ODS AT ADMISSION set (for Operation Desert Shield), ensure
;that POS=6 (ODS). This is necessary because the POS may have been set to another value
;according the business rules.
I +$$GET1^DIQ(405,MV_",",11500.01)>0 S POS=6
S ELIG=$$GET1^DIQ(45,IENS45,20.1,"I") ;admitting eligibility
S POS=$$CKPOS^DGPTUTL(ELIG,POS) ;update POS (to account for non-vet eligibilities)
Q POS
;
MSTATUS(DGPTF) ;marital status
N IENS45,DFN,IENS,X,MS
S IENS45=DGPTF_","
S DFN=$$GET1^DIQ(45,IENS45,.01,"I"),IENS=DFN_","
S X=$$GET1^DIQ(2,IENS,.05,"I")
S MS=$$GET1^DIQ(11,X_",",2,"I")
S:MS="" MS="U"
Q MS
;
ION(DGPTF) ;ionizing radiation (used by 101)
;return value
;1 - no claim of exposure
;2 - claims exposure, Japan
;3 - claims exposure, testing
;4 - claims exposure, both testing and Japan
;5 - claims exposure, underground nuclear testing
;6 - claims exposure, nuclear facility
;7 - claims exposure, other
N DG321,DGNT,DGPOS,RE,E,VPOS
S DG321=$$GET321^DGPTRNU(DGPTF)
S DGNT=$P(DG321,U,12) ;radiation exposure method
S RE=$P(DG321,U,3) ;radiation exposure indicated
S E=" "
S DGPOS=$$POS(DGPTF)
;valid POS for ionizing radiation?
S VPOS=$S(DGPOS=0:1,DGPOS=2:1,DGPOS=4:1,DGPOS=5:1,DGPOS=7:1,DGPOS=8:1,DGPOS="Z":1,1:0)
D:VPOS
.S E=$S(RE'="Y":1,1:DGNT)
Q E
;
ION2(DGPTF) ;ionizing radiation (used by 701)
;returns Y(es), N(o) or space
N G
S G=$$GET1^DIQ(45,DGPTF_",",79.27,"I")
Q $S(G="Y":"Y",G="N":"N",1:" ")
;
MST(DGPTF) ;military sexual trauma
N IENS,X,Y
S IENS=DGPTF_","
S Y=$$GET1^DIQ(45,IENS,79.29,"I")
Q $S(Y="Y":"Y",Y="N":"N",1:" ")
;
HNC(DGPTF) ;treatment related to head/neck cancer (HNC)
N Y,IENS
S IENS=DGPTF_","
S Y=$$GET1^DIQ(45,IENS,79.3,"I")
Q $S(Y="Y":"Y",Y="N":"N",1:" ")
;
SWASIA(DGPTF) ;treatment related to service in SW Asia
N Y,IENS
S IENS=DGPTF_","
S Y=$$GET1^DIQ(45,IENS,79.28)
Q $S(Y="":" ",1:Y)
;
CVS(DGPTF) ;combat vet status
;returns 1=yes, 2=no
N DG0,IENS,DFN,Y,ADATE
S DG0=$$GET0^DGPTRNU(DGPTF)
S IENS=DGPTF_","
S DFN=$$GET1^DIQ(45,IENS,.01,"I")
S ADATE=$P(DG0,U,2) ;admission date
I ADATE S Y=$$CVEDT^DGCV(DFN,ADATE)
E S Y=$$CVEDT^DGCV(DFN,ADATE)
Q $S(+Y>0:1,1:2)
;
CVDT(DGPTF) ;combat vet date
N DG0,IENS,DFN,ADATE,Y
S DG0=$$GET0^DGPTRNU(DGPTF)
S IENS=DGPTF_","
S DFN=$$GET1^DIQ(45,IENS,.01,"I")
S ADATE=+$P(DG0,U,2) ;admission date
I ADATE S Y=$$CVEDT^DGCV(DFN,ADATE)
E S Y=$$CVEDT^DGCV(DFN)
Q $S(+Y>0:$P(Y,U,2),1:0)
;
SHAD(DGPTF) ;SHAD/Project 112
N IENS,Y
S IENS=DGPTF_","
S Y=$$GET1^DIQ(45,IENS,79.32,"I")
Q $S(Y="":" ",1:Y)
;
KATRINA(DGPTF) ;Katrina indicator
N DFN,DG0,ERI
S IENS=DGPTF_","
S DG0=$$GET0(DGPTF),DFN=+DG0
S ERI=$$EMGRES^DGUTL(DFN) ;emergency response indicator
;returns "K" or " "
Q $S("^K^"[(U_ERI_U):"K",1:" ")
;
MTI(DGPTF) ;means test indicator
;return value
;AS - SC and special category veterans
;AN - NSC veterans
;B - category "B" NSC veterans
;C - MT copay required (category "C" NSC veterans)
;N - non-veterans
;X - not applicable
;U - not done/completed
;G - GMT copay required
N VAL,IENS,MT,AO
S VAL=" "
S IENS=DGPTF_","
S AO=$$GET1^DIQ(45.84,IENS,79.26,"I") ;treated for AO condition
S MT=$$GET1^DIQ(45.84,IENS,10,"I") ;means test indicator
S MT=$S(MT="":"U",1:MT)
S VAL=$S(AO="Y":"AS",1:MT)
Q VAL
;
AO(DGPTF) ;treated for agent orange exposure (used by 701)
;Y - yes
;N - no
;" " - unknown or no value
N G
S G=$$GET1^DIQ(45,DGPTF_",",79.26,"I")
Q $S(G="Y":"Y",G="N":"N",1:" ")
;
AO2(DGPTF) ;agent orange exposure (used by 101)
;return value:
;1 - no claim of service in Vietnam
;2 - claims service in Vietnam, no exposure
;3 - claims service in Vietnam with exposure
;4 - claims service in Vietnam with exposure unknown
;5 - claims service in DMZ with exposure
;may return blank
N G,DGAO,DGPOS,DG321
S DG321=$$GET321(DGPTF)
S G=" "
S DGAO=$P(DG321,U,2)
S DGPOS=$$POS^DGPTRNU(DGPTF)
S:DGPOS=7 G=$S($P(DG321,U)'="Y":1,DGAO="N":2,DGAO="Y":3,1:4)
;Check to see if the exposure location was the Korean DMZ
S:(DGAO="Y")&($P(DG321,U,13)="K") G=5
Q G
;
INCOME(DGPTF) ;income
N INC,IENS,LI,PAD
S IENS=DGPTF_","
S INC=$$GET1^DIQ(45,IENS,101.07)
S:INC>999999 INC=999999
S LI=$L(INC)
S PAD=$S(LI=0:"000000",LI=1:"00000",LI=2:"0000",LI=3:"000",LI=4:"00",LI=5:"0",1:"")
Q PAD_INC
;
DISP(PTF) ;date of disposition
N IENS
S IENS=PTF_","
Q $$GET1^DIQ(45,IENS,70,"I") ;discharge date
;
GETMPCR(DGTS) ;MPCR from specialty
N ARRY,Y,Z,MPCR
S Y=$$TSDATA^DGACT(42.4,DGTS,.ARRY)
S Z=$G(ARRY(6))
I Y>0 S MPCR=$E($P(Z,".")_"0000",1,4)_$E($P(Z,".",2)_"00",1,2)
E S MPCR=""
Q MPCR
;
SPCODE(DGTS) ;
N ARRY,Y,Z
S Y=$$TSDATA^DGACT(42.4,DGTS,.ARRY)
S Z=$G(ARRY(6))
Q $S(Y>0:Z,1:"")
;
RACE(DGPTF,DGARR) ;
N IENS45,IENS,DFN
N OUT,MOUT
N I,NUM,MORE,EVAL,IVAL
S IENS45=DGPTF_","
S DFN=$$GET1^DIQ(45,IENS45,.01,"I"),IENS=","_DFN_","
;retrieve at most 6 entries, screening out those that are inactive
D LIST^DIC(2.02,IENS,".01",,6,,,,"I '$$INACTIVE^DGUTL4(Y)",,"OUT","MOUT")
S NUM=$P(OUT("DILIST",0),U) ;number of subrercords returned
S MORE=$P(OUT("DILIST",0),U,3) ;any more?
F I=1:1:NUM D
.S EVAL=$G(OUT("DILIST",1,I))
.S IVAL=$G(OUT("DILIST",2,I))
.S @DGARR@(I,"IEN")=IVAL
.S @DGARR@(I,"VAL")=EVAL
.S @DGARR@(I,"CODE")=$$PTR2CODE^DGUTL4(IVAL,1,4)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTRNU 8504 printed Sep 23, 2025@20:29:24 Page 2
DGPTRNU ;ISF/GJW,HIOFO/FT - PTF TRANSMISSION ;2/18/15 2:28pm
+1 ;;5.3;Registration;**884**;Aug 13, 1993;Build 31
+2 ;
+3 ;XLFDT - #10103
+4 ;
FDATE(DGDT,DGDF) ;format date as MMDDYY
+1 ;Format options
+2 ;1 - MMDDYY
+3 ;2 - MMDDYYYY
+4 NEW X,MON,DAY,YR,VAL
+5 ;default to 2-digit date
SET DGDF=$GET(DGDF,1)
+6 SET X=$$FMTE^XLFDT(DGDT,"5ZP")
+7 SET MON=$PIECE(X,"/")
+8 SET DAY=$PIECE(X,"/",2)
+9 SET YR=$PIECE(X,"/",3)
+10 if DGDF=1
SET VAL=MON_DAY_$EXTRACT(YR,3,4)
+11 if DGDF=2
SET VAL=MON_DAY_YR
+12 QUIT $SELECT(+DGDT'>0:"",1:VAL)
+13 ;
TIME(DTM) ;extract time in HHMM format from date/time
+1 NEW X,Y,H,M
+2 SET X=$$FMTE^XLFDT(DTM,"6F")
+3 SET Y=$PIECE(X,"@",2)
+4 SET H=$PIECE(Y,":")
SET M=$PIECE(Y,":",2)
+5 QUIT H_M
+6 ;
FMTICD(DGC) ;format ICD code for transmission
+1 QUIT $TRANSLATE(DGC,".","")
+2 ;
+3 ;Retrieve nodes from PTF CLOSE OUT (#45.84) where appropriate
GETNODE(DGPTF,DGHOW,DGNODE) ;
+1 ;DGHOW = 1 - use PTF CLOSE OUT node if defined, PTF otherwise
+2 ;DGHOW = 2 - use PTF file
+3 ;DGHOW = 3 - use PTF CLOSE OUT record (forced)
+4 NEW VAL,DFN,COUT,IENS45,IENS2,FLD,NODE
+5 ;the field numbers for the various STORE(*) fields
+6 SET NODE=$SELECT(DGNODE=0:0,DGNODE=32:.32,DGNODE=321:.321,DGNODE=52:.52,1:"")
+7 SET FLD=$SELECT(DGNODE=0:10,DGNODE=11:11,DGNODE=52:12,DGNODE=321:13,DGNODE=32:14,DGNODE=57:15,.3:16,1:0)
+8 SET VAL=""
+9 SET IENS45=DGPTF_","
+10 ;corresponding entry in PTF CLOSE OUT file
SET COUT=$$GET1^DIQ(45,IENS45,7.1,"I")
+11 ;ft 2/12/15
SET DFN=$$GET1^DIQ(45,IENS45,.01,"I")
+12 IF DGHOW'=3
Begin DoDot:1
+13 SET DFN=$$GET1^DIQ(45,IENS45,.01,"I")
+14 SET IENS2=$GET(DFN)_","
End DoDot:1
+15 IF DGHOW=1
SET VAL=$SELECT(COUT:$$GET1^DIQ(45.84,COUT_",",FLD),1:$GET(^DPT(DFN,DGNODE)))
+16 IF DGHOW=2
SET VAL=$GET(^DPT(DFN,.321))
+17 IF DGHOW=3
SET VAL=$$GET1^DIQ(45.84,COUT_",",FLD)
+18 QUIT VAL
+19 ;
+20 ;convenience routines for commonly used nodes
GET0(DGPTF,DGHOW) ;
+1 SET DGHOW=$GET(DGHOW,1)
+2 QUIT $$GETNODE(DGPTF,DGHOW,0)
+3 ;
GET32(DGPTF,DGHOW) ;
+1 SET DGHOW=$GET(DGHOW,1)
+2 QUIT $$GETNODE(DGPTF,DGHOW,.32)
+3 ;
GET321(DGPTF,DGHOW) ;
+1 SET DGHOW=$GET(DGHOW,1)
+2 QUIT $$GETNODE(DGPTF,DGHOW,.321)
+3 ;
GET52(DGPTF,DGHOW) ;
+1 SET DGHOW=$GET(DGHOW,1)
+2 QUIT $$GETNODE(DGPTF,DGHOW,.52)
+3 ;
POW(DGPTF) ;POW status
+1 ;returns
+2 ;1 - not a POW
+3 ;3 - POW, unknown
+4 ;4 - POW, World War I
+5 ;5 - POW, World War II (Europe)
+6 ;6 - POW, World War II (Pacific)
+7 ;7 - POW, Korea
+8 ;8 - POW, Vietnam
+9 ;9 - POW, combination
+10 NEW DG52,SI,PP,Y,VAL
+11 SET DG52=$$GET52^DGPTRNU(DGPTF)
+12 ;POW status indicated?,
SET SI=$PIECE(DG52,U,5)
+13 ;POW period
SET Y=$PIECE(DG52,U,6)
+14 SET VAL=1
+15 IF SI="Y"
Begin DoDot:1
+16 SET VAL=$SELECT(Y=0:3,Y=2:5,Y=3:6,Y=4:7,Y=5:8,Y=6:9,Y=7:"A",Y=8:"B",1:" ")
End DoDot:1
+17 QUIT VAL
+18 ;
PDIS(DGPTF) ;place of disposition
+1 NEW IENS,IENS1,X
+2 SET IENS=DGPTF_","
+3 SET X=$$GET1^DIQ(45,IENS,75,"I")
SET IENS1=X_","
+4 ;PTF code
QUIT $$GET1^DIQ(45.6,IENS1,2)
+5 ;
POS(DGPTF) ;period of service
+1 NEW IENS45,DG32,POS1,POS,MV,ELIG
+2 SET IENS45=DGPTF_","
+3 SET DG32=$$GET32^DGPTRNU(DGPTF)
+4 ;period of service from PATIENT file (pointer to file #21)
SET POS1=$PIECE(DG32,U,3)
+5 ;code
SET POS=$$GET1^DIQ(21,POS1_",",.03)
+6 ;Now, use the "APTF" cross-reference on the PATIENT MOVEMENT (#405) file to look up
+7 ;the patient movement associated with this PTF entry
+8 SET MV=""
if $DATA(^DGPM("APTF",PTF))
SET MV=$ORDER(^DGPM("APTF",PTF,0))
+9 ;If the patient movement has ODS AT ADMISSION set (for Operation Desert Shield), ensure
+10 ;that POS=6 (ODS). This is necessary because the POS may have been set to another value
+11 ;according the business rules.
+12 IF +$$GET1^DIQ(405,MV_",",11500.01)>0
SET POS=6
+13 ;admitting eligibility
SET ELIG=$$GET1^DIQ(45,IENS45,20.1,"I")
+14 ;update POS (to account for non-vet eligibilities)
SET POS=$$CKPOS^DGPTUTL(ELIG,POS)
+15 QUIT POS
+16 ;
MSTATUS(DGPTF) ;marital status
+1 NEW IENS45,DFN,IENS,X,MS
+2 SET IENS45=DGPTF_","
+3 SET DFN=$$GET1^DIQ(45,IENS45,.01,"I")
SET IENS=DFN_","
+4 SET X=$$GET1^DIQ(2,IENS,.05,"I")
+5 SET MS=$$GET1^DIQ(11,X_",",2,"I")
+6 if MS=""
SET MS="U"
+7 QUIT MS
+8 ;
ION(DGPTF) ;ionizing radiation (used by 101)
+1 ;return value
+2 ;1 - no claim of exposure
+3 ;2 - claims exposure, Japan
+4 ;3 - claims exposure, testing
+5 ;4 - claims exposure, both testing and Japan
+6 ;5 - claims exposure, underground nuclear testing
+7 ;6 - claims exposure, nuclear facility
+8 ;7 - claims exposure, other
+9 NEW DG321,DGNT,DGPOS,RE,E,VPOS
+10 SET DG321=$$GET321^DGPTRNU(DGPTF)
+11 ;radiation exposure method
SET DGNT=$PIECE(DG321,U,12)
+12 ;radiation exposure indicated
SET RE=$PIECE(DG321,U,3)
+13 SET E=" "
+14 SET DGPOS=$$POS(DGPTF)
+15 ;valid POS for ionizing radiation?
+16 SET VPOS=$SELECT(DGPOS=0:1,DGPOS=2:1,DGPOS=4:1,DGPOS=5:1,DGPOS=7:1,DGPOS=8:1,DGPOS="Z":1,1:0)
+17 if VPOS
Begin DoDot:1
+18 SET E=$SELECT(RE'="Y":1,1:DGNT)
End DoDot:1
+19 QUIT E
+20 ;
ION2(DGPTF) ;ionizing radiation (used by 701)
+1 ;returns Y(es), N(o) or space
+2 NEW G
+3 SET G=$$GET1^DIQ(45,DGPTF_",",79.27,"I")
+4 QUIT $SELECT(G="Y":"Y",G="N":"N",1:" ")
+5 ;
MST(DGPTF) ;military sexual trauma
+1 NEW IENS,X,Y
+2 SET IENS=DGPTF_","
+3 SET Y=$$GET1^DIQ(45,IENS,79.29,"I")
+4 QUIT $SELECT(Y="Y":"Y",Y="N":"N",1:" ")
+5 ;
HNC(DGPTF) ;treatment related to head/neck cancer (HNC)
+1 NEW Y,IENS
+2 SET IENS=DGPTF_","
+3 SET Y=$$GET1^DIQ(45,IENS,79.3,"I")
+4 QUIT $SELECT(Y="Y":"Y",Y="N":"N",1:" ")
+5 ;
SWASIA(DGPTF) ;treatment related to service in SW Asia
+1 NEW Y,IENS
+2 SET IENS=DGPTF_","
+3 SET Y=$$GET1^DIQ(45,IENS,79.28)
+4 QUIT $SELECT(Y="":" ",1:Y)
+5 ;
CVS(DGPTF) ;combat vet status
+1 ;returns 1=yes, 2=no
+2 NEW DG0,IENS,DFN,Y,ADATE
+3 SET DG0=$$GET0^DGPTRNU(DGPTF)
+4 SET IENS=DGPTF_","
+5 SET DFN=$$GET1^DIQ(45,IENS,.01,"I")
+6 ;admission date
SET ADATE=$PIECE(DG0,U,2)
+7 IF ADATE
SET Y=$$CVEDT^DGCV(DFN,ADATE)
+8 IF '$TEST
SET Y=$$CVEDT^DGCV(DFN,ADATE)
+9 QUIT $SELECT(+Y>0:1,1:2)
+10 ;
CVDT(DGPTF) ;combat vet date
+1 NEW DG0,IENS,DFN,ADATE,Y
+2 SET DG0=$$GET0^DGPTRNU(DGPTF)
+3 SET IENS=DGPTF_","
+4 SET DFN=$$GET1^DIQ(45,IENS,.01,"I")
+5 ;admission date
SET ADATE=+$PIECE(DG0,U,2)
+6 IF ADATE
SET Y=$$CVEDT^DGCV(DFN,ADATE)
+7 IF '$TEST
SET Y=$$CVEDT^DGCV(DFN)
+8 QUIT $SELECT(+Y>0:$PIECE(Y,U,2),1:0)
+9 ;
SHAD(DGPTF) ;SHAD/Project 112
+1 NEW IENS,Y
+2 SET IENS=DGPTF_","
+3 SET Y=$$GET1^DIQ(45,IENS,79.32,"I")
+4 QUIT $SELECT(Y="":" ",1:Y)
+5 ;
KATRINA(DGPTF) ;Katrina indicator
+1 NEW DFN,DG0,ERI
+2 SET IENS=DGPTF_","
+3 SET DG0=$$GET0(DGPTF)
SET DFN=+DG0
+4 ;emergency response indicator
SET ERI=$$EMGRES^DGUTL(DFN)
+5 ;returns "K" or " "
+6 QUIT $SELECT("^K^"[(U_ERI_U):"K",1:" ")
+7 ;
MTI(DGPTF) ;means test indicator
+1 ;return value
+2 ;AS - SC and special category veterans
+3 ;AN - NSC veterans
+4 ;B - category "B" NSC veterans
+5 ;C - MT copay required (category "C" NSC veterans)
+6 ;N - non-veterans
+7 ;X - not applicable
+8 ;U - not done/completed
+9 ;G - GMT copay required
+10 NEW VAL,IENS,MT,AO
+11 SET VAL=" "
+12 SET IENS=DGPTF_","
+13 ;treated for AO condition
SET AO=$$GET1^DIQ(45.84,IENS,79.26,"I")
+14 ;means test indicator
SET MT=$$GET1^DIQ(45.84,IENS,10,"I")
+15 SET MT=$SELECT(MT="":"U",1:MT)
+16 SET VAL=$SELECT(AO="Y":"AS",1:MT)
+17 QUIT VAL
+18 ;
AO(DGPTF) ;treated for agent orange exposure (used by 701)
+1 ;Y - yes
+2 ;N - no
+3 ;" " - unknown or no value
+4 NEW G
+5 SET G=$$GET1^DIQ(45,DGPTF_",",79.26,"I")
+6 QUIT $SELECT(G="Y":"Y",G="N":"N",1:" ")
+7 ;
AO2(DGPTF) ;agent orange exposure (used by 101)
+1 ;return value:
+2 ;1 - no claim of service in Vietnam
+3 ;2 - claims service in Vietnam, no exposure
+4 ;3 - claims service in Vietnam with exposure
+5 ;4 - claims service in Vietnam with exposure unknown
+6 ;5 - claims service in DMZ with exposure
+7 ;may return blank
+8 NEW G,DGAO,DGPOS,DG321
+9 SET DG321=$$GET321(DGPTF)
+10 SET G=" "
+11 SET DGAO=$PIECE(DG321,U,2)
+12 SET DGPOS=$$POS^DGPTRNU(DGPTF)
+13 if DGPOS=7
SET G=$SELECT($PIECE(DG321,U)'="Y":1,DGAO="N":2,DGAO="Y":3,1:4)
+14 ;Check to see if the exposure location was the Korean DMZ
+15 if (DGAO="Y")&($PIECE(DG321,U,13)="K")
SET G=5
+16 QUIT G
+17 ;
INCOME(DGPTF) ;income
+1 NEW INC,IENS,LI,PAD
+2 SET IENS=DGPTF_","
+3 SET INC=$$GET1^DIQ(45,IENS,101.07)
+4 if INC>999999
SET INC=999999
+5 SET LI=$LENGTH(INC)
+6 SET PAD=$SELECT(LI=0:"000000",LI=1:"00000",LI=2:"0000",LI=3:"000",LI=4:"00",LI=5:"0",1:"")
+7 QUIT PAD_INC
+8 ;
DISP(PTF) ;date of disposition
+1 NEW IENS
+2 SET IENS=PTF_","
+3 ;discharge date
QUIT $$GET1^DIQ(45,IENS,70,"I")
+4 ;
GETMPCR(DGTS) ;MPCR from specialty
+1 NEW ARRY,Y,Z,MPCR
+2 SET Y=$$TSDATA^DGACT(42.4,DGTS,.ARRY)
+3 SET Z=$GET(ARRY(6))
+4 IF Y>0
SET MPCR=$EXTRACT($PIECE(Z,".")_"0000",1,4)_$EXTRACT($PIECE(Z,".",2)_"00",1,2)
+5 IF '$TEST
SET MPCR=""
+6 QUIT MPCR
+7 ;
SPCODE(DGTS) ;
+1 NEW ARRY,Y,Z
+2 SET Y=$$TSDATA^DGACT(42.4,DGTS,.ARRY)
+3 SET Z=$GET(ARRY(6))
+4 QUIT $SELECT(Y>0:Z,1:"")
+5 ;
RACE(DGPTF,DGARR) ;
+1 NEW IENS45,IENS,DFN
+2 NEW OUT,MOUT
+3 NEW I,NUM,MORE,EVAL,IVAL
+4 SET IENS45=DGPTF_","
+5 SET DFN=$$GET1^DIQ(45,IENS45,.01,"I")
SET IENS=","_DFN_","
+6 ;retrieve at most 6 entries, screening out those that are inactive
+7 DO LIST^DIC(2.02,IENS,".01",,6,,,,"I '$$INACTIVE^DGUTL4(Y)",,"OUT","MOUT")
+8 ;number of subrercords returned
SET NUM=$PIECE(OUT("DILIST",0),U)
+9 ;any more?
SET MORE=$PIECE(OUT("DILIST",0),U,3)
+10 FOR I=1:1:NUM
Begin DoDot:1
+11 SET EVAL=$GET(OUT("DILIST",1,I))
+12 SET IVAL=$GET(OUT("DILIST",2,I))
+13 SET @DGARR@(I,"IEN")=IVAL
+14 SET @DGARR@(I,"VAL")=EVAL
+15 SET @DGARR@(I,"CODE")=$$PTR2CODE^DGUTL4(IVAL,1,4)
End DoDot:1
+16 QUIT
