DGRPDT ;ALB/BRM,LBD - MILITARY SERVICE DATE UTILITIES ; 6/30/09 2:21pm
;;5.3;Registration;**562,603,626,673,731,797**;Aug 13, 1993;Build 24
;
DTUTIL(DGNEWDT,DGOLDDT,MYFLG) ; Date precision comparision API
S:$G(DGOLDDT)="" DGOLDDT="0000000"
Q:'$$VALID(.DGNEWDT) "0^INVALID DATE PARAMETER"
I $L(DGOLDDT)<7 S DGOLDDT=DGOLDDT_$E("0000000",$L(DGOLDDT)+1,7)
N X,Y,EXACTO,EXACTN,I,RTN,MSDATE,MSG
S RTN="",EXACTO=$$CHKEXC(DGOLDDT),EXACTN=$$CHKEXC(DGNEWDT)
I $G(MYFLG) Q:'$$MNTHYR(DGNEWDT) "0^Date must contain month and year"
Q:EXACTO=EXACTN "1^Same Precision"
F I=1:1:3 Q:RTN'="" D
.S:$E(EXACTN,I)<$E(EXACTO,I) RTN="0^ is Less Precise Than Previously Entered "
.S:$E(EXACTN,I)>$E(EXACTO,I) RTN="1^ is More Precise Than Previously Entered "
.S MSG=$S(I=1:"Year",I=2:"Month",I=3:"Day",1:"")
.S:RTN'="" $P(RTN,"^",2)=MSG_$P(RTN,"^",2)_MSG
Q $S($G(RTN)'="":RTN,1:"0^Unknown Precision")
CHKEXC(MSDATE) ; construct precision string (3 digit return value - YMD)
Q ($E(MSDATE,1,3)'="000")_($E(MSDATE,4,5)'="00")_($E(MSDATE,6,7)'="00")
MNTHYR(MSDATE) ; ensure month and year are not imprecise (binary return value)
Q ($E(MSDATE,1,3)'="000")&($E(MSDATE,4,5)'="00")
WITHIN(FRDT,TODT,CHKDT) ; is CHKDT within FRDT and TODT?
N DGRPB41,DGRPB42
Q:'$$VALID($G(CHKDT)) "0^Invalid Date"
Q:('$G(FRDT))!('$G(TODT)) "0^Missing Required Date Range"
Q:('$$VALID(FRDT)!'$$VALID(TODT)!'$$B4(FRDT,TODT,1)) "0^Invalid Date Range"
S DGRPB41=$$B4(FRDT,CHKDT,1),DGRPB42=$$B4(CHKDT,TODT,1)
I 'DGRPB41!'DGRPB42 Q "0^Not Within Valid Date Range"
Q "1^Date is Within Date Range"_$S($P(DGRPB41,"^",2):"^1",$P(DGRPB42,"^",2):"^1",1:"") ;add same flag if they are the same
VALID(DATE) ; is this a valid Fileman date? (limits are from FR^XLFDT)
Q:'$D(DATE) 0
Q (1410102'>DATE)&(DATE'>4141015.235959)
B4(DATE1,DATE2,SAME) ;is DATE1 before DATE2?
N IMPRDT,IDT,IRTN,CDATE1,CDATE2
S DATE1=$P($G(DATE1),"."),DATE2=$P($G(DATE2),".")
Q:DATE1=""!DATE2="" 1
I $G(SAME),DATE1=DATE2 Q "1^1"
I $$CHKEXC(DATE1)'=111!$$CHKEXC(DATE2)'=111 D Q:$G(IRTN) IRTN
.S (CDATE1,CDATE2)="0000000"
.I $E(DATE1,1,3),$E(DATE2,1,3) F I=1:1:2 S $E(@("CDATE"_I),1,3)=$E(@("DATE"_I),1,3)
.I $E(DATE1,4,5),$E(DATE2,4,5) F I=1:1:2 S $E(@("CDATE"_I),4,5)=$E(@("DATE"_I),4,5)
.I $E(DATE1,6,7),$E(DATE2,6,7) F I=1:1:2 S $E(@("CDATE"_I),6,7)=$E(@("DATE"_I),6,7)
.I CDATE1<CDATE2 S IRTN=1 Q
.I CDATE1=CDATE2 S IRTN="1^1" Q
Q DATE1<DATE2
RWITHIN(FRDT,TODT,CHKDT1,CHKDT2) ;are CHKDT1 and CHKDT2 within FRDT and TODT?
N CHK1,CHK2
S CHK1=$$WITHIN(.FRDT,.TODT,.CHKDT1) Q:'CHK1 CHK1
S CHK2=$$WITHIN(.FRDT,.TODT,.CHKDT2) Q:'CHK2 CHK2
Q "1^Both Date are Within Date Range"_$S(($P(CHK1,"^",3)!$P(CHK2,"^",3)):"^1",1:"")
COVRLP2(DFN,FRDT,TODT,IGNORE,OEFOIF) ; check conflict with type 0 and 2 (see below)
Q:('$G(DFN))!('$D(^DPT(DFN))) "0^INVALID DFN"
S RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,-1,$G(IGNORE),.OEFOIF)
Q:$P(RTN,"^")=0 RTN
S RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,2,$G(IGNORE),.OEFOIF)
Q RTN
OVRLPCHK(DFN,FRDT,TODT,TYPE,IGNORE,OEFOIF,MSE) ;check for overlapping date ranges
; pass OEFOIF by ref - return OEFOIF(1)=1: OEF/OIF "cnflct not within MSE
N RTN1,DATA,NODE,RTN,FRDT1,MSG,SUBRNG,TODT1,DGW1,DGW2,DGRW1,DGRW2,DGZ
Q:('$G(DFN))!('$D(^DPT(DFN))) "0^INVALID DFN"
I TYPE<2 D
. ; If data in MSE sub-file #2.3216, do not use old MSE fields
. I $G(MSE)!($D(^DPT(DFN,.3216))) S NODE(2.3216)=".01,.02" K IGNORE Q
. S NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298"
E D
. ; If checking an OEF/OIF period, only check against OEF/OIF
. I $G(OEFOIF) S NODE(2.3215)=".02,.03" K IGNORE Q
. S NODE(.321)=".32104,.32105",NODE(.322)=".3222,.3223,.3225,.3226,.3228,.3229,.322011,.322012,.322017,.322018,.32202,.322021",NODE(.52)=".5293,.5294"
D:$G(IGNORE)]"" IGNORE(.NODE,.IGNORE)
D GETDAT(DFN,.NODE,.DATA) Q:'$D(DATA) "1^CANNOT FIND PATIENT DATA"
I $G(MSE) K DATA("MSE-"_MSE) ;MSE entry to exclude (used instead of IGNORE) - DG*5.3*797
I $G(OEFOIF),$P(OEFOIF,U,2)'="" K DATA($P(OEFOIF,U,2)) ; OEF/OIF entry to exclude (used instead of IGNORE)
I TYPE<0 S DGZ=$$MSEONLY(.DATA,FRDT,TODT) S:'DGZ&$G(OEFOIF) OEFOIF(1)=1 Q DGZ
S SUBRNG="" F S SUBRNG=$O(DATA(SUBRNG)) Q:SUBRNG=""!($D(RTN)) D
.S FRDT1=$P(DATA(SUBRNG),"^"),TODT1=$P(DATA(SUBRNG),"^",2)
.I FRDT1="",TODT1="" Q
.I 'TYPE S:$$RWITHIN(FRDT1,TODT1,.FRDT,.TODT) RTN1=$G(RTN1)+1 Q
.S MSG=$S(TYPE=1:"Military Service Episode",1:"Conflict")
. ; For OEF/OIF only - dates must be totally non-overlapping
.S DGW1=$$WITHIN(FRDT1,TODT1,.FRDT),DGW2=$$WITHIN(FRDT1,TODT1,.TODT)
.I DGW1,$S($G(OEFOIF):'$P(DGW1,"^",3),1:1) S RTN="0^This "_MSG_" overlaps with another "_MSG
.I DGW2,$S($G(OEFOIF):'$P(DGW2,"^",3),1:1) S RTN="0^This "_MSG_" overlaps with another "_MSG
.S DGRW1=$$RWITHIN(FRDT1,TODT1,.FRDT,.TODT),DGRW2=$$RWITHIN(.FRDT,.TODT,FRDT1,TODT1)
.I '$G(OEFOIF),DGRW1,'$$SAME(FRDT1,TODT1,FRDT,TODT) S RTN="0^This "_MSG_" is within another "_MSG
.I '$G(OEFOIF),DGRW2,'$$SAME(FRDT1,TODT1,FRDT,TODT) S RTN="0^Another "_MSG_" is within another "_MSG
.I $E($P($G(OEFOIF),U,2),1,3)="UNK"!($E(SUBRNG,1,3)="UNK") D
.. I FRDT,TODT,'(DGRW1!DGRW2),DGW1!DGW2 S RTN="0^This "_MSG_" is within another "_MSG
.I (DGRW1!(DGRW2)),$S($E($P($G(OEFOIF),U,2),1,3)'="UNK"&($E(SUBRNG,1,3)'="UNK"):'$$SAME(FRDT1,TODT1,FRDT,TODT),1:$E(SUBRNG,1,3)="UNK"&(FRDT'=FRDT1!(TODT'=TODT1))) S RTN="0^This "_MSG_" is within another "_MSG
I ('TYPE),'$D(RTN1) S:$G(OEFOIF) OEFOIF(1)=1 Q "0^This conflict is not within a Military Service Episode"
Q:$D(RTN) RTN
Q "1^OK"
SAME(FRDT1,TODT1,FRDT,TODT) ;
N DGS1,DGS2,DGS3,DGS4
S DGS1=$$B4(FRDT,TODT1,1),DGS2=$$B4(FRDT1,TODT,1)
S DGS3=$$B4(TODT,FRDT1,1),DGS4=$$B4(TODT1,FRDT,1)
Q:$P(DGS1,"^",3) 1
Q:$P(DGS2,"^",3) 1
Q:$P(DGS3,"^",3) 1
Q:$P(DGS4,"^",3) 1
Q 0
GETDAT(DFN,NODE,DATA) ;get data from the Patient (#2) file
N LOOP,SUB,SUB1,Z,Z0,TMPDAT,DATA1,ERR,DR,SUBND,X,X1
Q:('$D(NODE))!('$D(DFN))
S SUB="",Z=1
F S SUB=$O(NODE(SUB)) Q:SUB="" D
.S SUBND=$P(SUB,".")
.S DR=$TR(NODE(SUB),",",";") Q:DR=""
.I 'SUBND D Q
..D GETS^DIQ(2,DFN_",",DR,"I","TMPDAT","ERR")
..S LOOP="F X="_$G(NODE(SUB))_" S DATA1(X)=$G(TMPDAT(2,DFN_"","",X,""I"")),Z=Z+1"
..X LOOP
.I SUB-2=.3216 D Q
..; Extract data from MSE sub-file #2.3216 (DG*5.3*797)
..S Z0=0 F S Z0=$O(^DPT(DFN,.3216,Z0)) Q:'Z0 D GETS^DIQ(SUB,Z0_","_DFN_",",DR,"I","TMPDAT","ERR")
..S X="" F S X=$O(TMPDAT(SUB,X)) Q:X="" S X1="" F S X1=$O(TMPDAT(SUB,X,X1)) Q:X1="" S DATA1("MSE-"_$P(X,","),X1)=TMPDAT(SUB,X,X1,"I")
. ; Extract dates from OIF OEF multiple too
. S Z0=0 F S Z0=$O(^DPT(DFN,SUB-2,Z0)) Q:'Z0 S SUB1(Z0)=+$G(^(Z0,0)) D GETS^DIQ(SUB,Z0_","_DFN_",",DR,"I","TMPDAT","ERR")
.S LOOP="F X="_$G(NODE(SUB))_" F X1=0:0 S X1=$O(SUB1(X1)) Q:'X1 S DATA1($S(SUB1(X1)=3:""UNK"",1:$$EXTERNAL^DILFD(SUB,.01,,SUB1(X1)))_""-""_X1,X)=$G(TMPDAT(SUB,X1_"",""_DFN_"","",X,""I"")),Z=Z+1" X LOOP
S DATA("MSL")=$G(DATA1(.326))_"^"_$G(DATA1(.327))
S DATA("MSNTL")=$S($G(DATA1(.3285))="Y":$G(DATA1(.3292))_"^"_$G(DATA1(.3293)),1:"^")
S DATA("MSNNTL")=$S($G(DATA1(.32945))="Y":$G(DATA1(.3297))_"^"_$G(DATA1(.3298)),1:"^")
S DATA("VIET")=$G(DATA1(.32104))_"^"_$G(DATA1(.32105))
S DATA("LEB")=$G(DATA1(.3222))_"^"_$G(DATA1(.3223))
S DATA("GREN")=$G(DATA1(.3225))_"^"_$G(DATA1(.3226))
S DATA("PAN")=$G(DATA1(.3228))_"^"_$G(DATA1(.3229))
S DATA("GULF")=$G(DATA1(.322011))_"^"_$G(DATA1(.322012))
S DATA("SOM")=$G(DATA1(.322017))_"^"_$G(DATA1(.322018))
S DATA("YUG")=$G(DATA1(.32202))_"^"_$G(DATA1(.322021))
S DATA("COMBAT")=$G(DATA1(.5293))_"^"_$G(DATA1(.5294))
; Set the MSE nodes (DG*5.3*797)
S Z="MSE" F S Z=$O(DATA1(Z)) Q:Z'["MSE" S DATA(Z)=$G(DATA1(Z,.01))_"^"_$G(DATA1(Z,.02))
; Pick up the OEF/OIF nodes here - subscript is not numeric
S Z="O" F S Z=$O(DATA1(Z)) Q:Z="" S DATA(Z)=$G(DATA1(Z,.02))_"^"_$G(DATA1(Z,.03))
Q
MSEONLY(DATA,FRDT,TODT) ; are these dates within the whole MSE period?
N TO,FROM,SUBRNG,FRDT1,TODT1,MSEFR,MSETO
S SUBRNG="" F S SUBRNG=$O(DATA(SUBRNG)) Q:SUBRNG="" D
.S FRDT1=$P(DATA(SUBRNG),"^"),TODT1=$P(DATA(SUBRNG),"^",2)
.S:FRDT1 FROM(FRDT1)="" S:TODT1 TO(TODT1)=""
S MSEFR=$O(FROM("")),MSETO=$O(TO(""),-1)
I FRDT,(('$$B4(MSEFR,FRDT,1))!'$$B4(FRDT,MSETO,1)) Q "0^Conflict From Date is Not Within Military Service Episode Dates"
I TODT,(('$$B4(TODT,MSETO,1))!'$$B4(MSEFR,TODT,1)) Q "0^Conflict End Date is Not Within Military Service Episode Dates"
Q "1^OK"
CNFLCTDT(FRDT,TODT,CNFLCT) ;are these dates valid for this conflict?
Q:'$D(CNFLCT) "0^INVALID CONFLICT"
N CRNG
S CRNG=$$GETCNFDT($P(CNFLCT,"-")) Q:$TR(CRNG,"^")="" "0^INVALID CONFLICT"
Q:$P(CRNG,"^")=0 CRNG
I $G(TODT)'="",TODT<$P(CRNG,U,3) Q "0^Not Within Valid Date Range"
I $G(FRDT)="" Q $$WITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.TODT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
I $G(TODT)="" Q $$WITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.FRDT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
Q $$RWITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.FRDT,.TODT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
GETCNFDT(CNFLCT) ; get the date range for input conflict
Q:'$D(CNFLCT) "0^INVALID CONFLICT"
N CRNG,CNFLCT1
S CNFLCT1=$P(CNFLCT,"-")
S CRNG=$T(@(CNFLCT1)) Q:CRNG']"" "0^INVALID CONFLICT"
S CRNG=$P(CRNG,";;",2) S:$P(CRNG,"^",2)="" $P(CRNG,"^",2)=$$DT^XLFDT
S:$P(CRNG,"^")="" $P(CRNG,"^")=1410102
S:$P(CRNG,U,3)="" $P(CRNG,U,3)=$P(CRNG,U)
Q CRNG
IGNORE(NODE,IFLD) ; extract top-level field to ignore when comparing
N LOOP,QLOOP,RVAL,LSTPC,PC
S LOOP="",IFLD="^"_IFLD_"^"
F S LOOP=$O(NODE(LOOP)) Q:LOOP="" D
.I IFLD[("^"_$P(NODE(LOOP),",")_"^") S NODE(LOOP)=$P(NODE(LOOP),",",2,99),LOOP="" Q
.S LSTPC=$L($TR(NODE(LOOP),".0123456789"))+1
.I IFLD[("^"_$P(NODE(LOOP),",",LSTPC)_"^") S NODE(LOOP)=$P(NODE(LOOP),",",1,LSTPC-1),LOOP="" Q
.F PC=1:1:LSTPC Q:$G(QLOOP) I IFLD[("^"_$P(NODE(LOOP),",",PC)_"^") S NODE(LOOP)=$P(NODE(LOOP),",",1,PC-1)_","_$P(NODE(LOOP),",",PC+1,99),LOOP="" Q
Q
CNFLCT ;; *** DO NOT REMOVE OR CHANGE BELOW CONFLICT VALUES ***
;;
;'fr dt'^'to dt'^minimum 'to dt'
WWI ;;2170406^2181111
WWIIE ;;2411207^2461231
WWIIP ;;2411207^2461231
KOR ;;2500627^2550131
VIET ;;2610228^2750507
LEB ;;2831001^
GREN ;;2831023^2831121
PAN ;;2891220^2900131
GULF ;;2900802^
SOM ;;2920928^
YUG ;;2920622^
OTHER ;;^
OIF ;;3030301^^3030319
OEF ;;3010901^^3010911
UNK ;;3010901^^3010911
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPDT 10513 printed Sep 23, 2025@20:32:07 Page 2
DGRPDT ;ALB/BRM,LBD - MILITARY SERVICE DATE UTILITIES ; 6/30/09 2:21pm
+1 ;;5.3;Registration;**562,603,626,673,731,797**;Aug 13, 1993;Build 24
+2 ;
DTUTIL(DGNEWDT,DGOLDDT,MYFLG) ; Date precision comparision API
+1 if $GET(DGOLDDT)=""
SET DGOLDDT="0000000"
+2 if '$$VALID(.DGNEWDT)
QUIT "0^INVALID DATE PARAMETER"
+3 IF $LENGTH(DGOLDDT)<7
SET DGOLDDT=DGOLDDT_$EXTRACT("0000000",$LENGTH(DGOLDDT)+1,7)
+4 NEW X,Y,EXACTO,EXACTN,I,RTN,MSDATE,MSG
+5 SET RTN=""
SET EXACTO=$$CHKEXC(DGOLDDT)
SET EXACTN=$$CHKEXC(DGNEWDT)
+6 IF $GET(MYFLG)
if '$$MNTHYR(DGNEWDT)
QUIT "0^Date must contain month and year"
+7 if EXACTO=EXACTN
QUIT "1^Same Precision"
+8 FOR I=1:1:3
if RTN'=""
QUIT
Begin DoDot:1
+9 if $EXTRACT(EXACTN,I)<$EXTRACT(EXACTO,I)
SET RTN="0^ is Less Precise Than Previously Entered "
+10 if $EXTRACT(EXACTN,I)>$EXTRACT(EXACTO,I)
SET RTN="1^ is More Precise Than Previously Entered "
+11 SET MSG=$SELECT(I=1:"Year",I=2:"Month",I=3:"Day",1:"")
+12 if RTN'=""
SET $PIECE(RTN,"^",2)=MSG_$PIECE(RTN,"^",2)_MSG
End DoDot:1
+13 QUIT $SELECT($GET(RTN)'="":RTN,1:"0^Unknown Precision")
CHKEXC(MSDATE) ; construct precision string (3 digit return value - YMD)
+1 QUIT ($EXTRACT(MSDATE,1,3)'="000")_($EXTRACT(MSDATE,4,5)'="00")_($EXTRACT(MSDATE,6,7)'="00")
MNTHYR(MSDATE) ; ensure month and year are not imprecise (binary return value)
+1 QUIT ($EXTRACT(MSDATE,1,3)'="000")&($EXTRACT(MSDATE,4,5)'="00")
WITHIN(FRDT,TODT,CHKDT) ; is CHKDT within FRDT and TODT?
+1 NEW DGRPB41,DGRPB42
+2 if '$$VALID($GET(CHKDT))
QUIT "0^Invalid Date"
+3 if ('$GET(FRDT))!('$GET(TODT))
QUIT "0^Missing Required Date Range"
+4 if ('$$VALID(FRDT)!'$$VALID(TODT)!'$$B4(FRDT,TODT,1))
QUIT "0^Invalid Date Range"
+5 SET DGRPB41=$$B4(FRDT,CHKDT,1)
SET DGRPB42=$$B4(CHKDT,TODT,1)
+6 IF 'DGRPB41!'DGRPB42
QUIT "0^Not Within Valid Date Range"
+7 ;add same flag if they are the same
QUIT "1^Date is Within Date Range"_$SELECT($PIECE(DGRPB41,"^",2):"^1",$PIECE(DGRPB42,"^",2):"^1",1:"")
VALID(DATE) ; is this a valid Fileman date? (limits are from FR^XLFDT)
+1 if '$DATA(DATE)
QUIT 0
+2 QUIT (1410102'>DATE)&(DATE'>4141015.235959)
B4(DATE1,DATE2,SAME) ;is DATE1 before DATE2?
+1 NEW IMPRDT,IDT,IRTN,CDATE1,CDATE2
+2 SET DATE1=$PIECE($GET(DATE1),".")
SET DATE2=$PIECE($GET(DATE2),".")
+3 if DATE1=""!DATE2=""
QUIT 1
+4 IF $GET(SAME)
IF DATE1=DATE2
QUIT "1^1"
+5 IF $$CHKEXC(DATE1)'=111!$$CHKEXC(DATE2)'=111
Begin DoDot:1
+6 SET (CDATE1,CDATE2)="0000000"
+7 IF $EXTRACT(DATE1,1,3)
IF $EXTRACT(DATE2,1,3)
FOR I=1:1:2
SET $EXTRACT(@("CDATE"_I),1,3)=$EXTRACT(@("DATE"_I),1,3)
+8 IF $EXTRACT(DATE1,4,5)
IF $EXTRACT(DATE2,4,5)
FOR I=1:1:2
SET $EXTRACT(@("CDATE"_I),4,5)=$EXTRACT(@("DATE"_I),4,5)
+9 IF $EXTRACT(DATE1,6,7)
IF $EXTRACT(DATE2,6,7)
FOR I=1:1:2
SET $EXTRACT(@("CDATE"_I),6,7)=$EXTRACT(@("DATE"_I),6,7)
+10 IF CDATE1<CDATE2
SET IRTN=1
QUIT
+11 IF CDATE1=CDATE2
SET IRTN="1^1"
QUIT
End DoDot:1
if $GET(IRTN)
QUIT IRTN
+12 QUIT DATE1<DATE2
RWITHIN(FRDT,TODT,CHKDT1,CHKDT2) ;are CHKDT1 and CHKDT2 within FRDT and TODT?
+1 NEW CHK1,CHK2
+2 SET CHK1=$$WITHIN(.FRDT,.TODT,.CHKDT1)
if 'CHK1
QUIT CHK1
+3 SET CHK2=$$WITHIN(.FRDT,.TODT,.CHKDT2)
if 'CHK2
QUIT CHK2
+4 QUIT "1^Both Date are Within Date Range"_$SELECT(($PIECE(CHK1,"^",3)!$PIECE(CHK2,"^",3)):"^1",1:"")
COVRLP2(DFN,FRDT,TODT,IGNORE,OEFOIF) ; check conflict with type 0 and 2 (see below)
+1 if ('$GET(DFN))!('$DATA(^DPT(DFN)))
QUIT "0^INVALID DFN"
+2 SET RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,-1,$GET(IGNORE),.OEFOIF)
+3 if $PIECE(RTN,"^")=0
QUIT RTN
+4 SET RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,2,$GET(IGNORE),.OEFOIF)
+5 QUIT RTN
OVRLPCHK(DFN,FRDT,TODT,TYPE,IGNORE,OEFOIF,MSE) ;check for overlapping date ranges
+1 ; pass OEFOIF by ref - return OEFOIF(1)=1: OEF/OIF "cnflct not within MSE
+2 NEW RTN1,DATA,NODE,RTN,FRDT1,MSG,SUBRNG,TODT1,DGW1,DGW2,DGRW1,DGRW2,DGZ
+3 if ('$GET(DFN))!('$DATA(^DPT(DFN)))
QUIT "0^INVALID DFN"
+4 IF TYPE<2
Begin DoDot:1
+5 ; If data in MSE sub-file #2.3216, do not use old MSE fields
+6 IF $GET(MSE)!($DATA(^DPT(DFN,.3216)))
SET NODE(2.3216)=".01,.02"
KILL IGNORE
QUIT
+7 SET NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298"
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 ; If checking an OEF/OIF period, only check against OEF/OIF
+10 IF $GET(OEFOIF)
SET NODE(2.3215)=".02,.03"
KILL IGNORE
QUIT
+11 SET NODE(.321)=".32104,.32105"
SET NODE(.322)=".3222,.3223,.3225,.3226,.3228,.3229,.322011,.322012,.322017,.322018,.32202,.322021"
SET NODE(.52)=".5293,.5294"
End DoDot:1
+12 if $GET(IGNORE)]""
DO IGNORE(.NODE,.IGNORE)
+13 DO GETDAT(DFN,.NODE,.DATA)
if '$DATA(DATA)
QUIT "1^CANNOT FIND PATIENT DATA"
+14 ;MSE entry to exclude (used instead of IGNORE) - DG*5.3*797
IF $GET(MSE)
KILL DATA("MSE-"_MSE)
+15 ; OEF/OIF entry to exclude (used instead of IGNORE)
IF $GET(OEFOIF)
IF $PIECE(OEFOIF,U,2)'=""
KILL DATA($PIECE(OEFOIF,U,2))
+16 IF TYPE<0
SET DGZ=$$MSEONLY(.DATA,FRDT,TODT)
if 'DGZ&$GET(OEFOIF)
SET OEFOIF(1)=1
QUIT DGZ
+17 SET SUBRNG=""
FOR
SET SUBRNG=$ORDER(DATA(SUBRNG))
if SUBRNG=""!($DATA(RTN))
QUIT
Begin DoDot:1
+18 SET FRDT1=$PIECE(DATA(SUBRNG),"^")
SET TODT1=$PIECE(DATA(SUBRNG),"^",2)
+19 IF FRDT1=""
IF TODT1=""
QUIT
+20 IF 'TYPE
if $$RWITHIN(FRDT1,TODT1,.FRDT,.TODT)
SET RTN1=$GET(RTN1)+1
QUIT
+21 SET MSG=$SELECT(TYPE=1:"Military Service Episode",1:"Conflict")
+22 ; For OEF/OIF only - dates must be totally non-overlapping
+23 SET DGW1=$$WITHIN(FRDT1,TODT1,.FRDT)
SET DGW2=$$WITHIN(FRDT1,TODT1,.TODT)
+24 IF DGW1
IF $SELECT($GET(OEFOIF):'$PIECE(DGW1,"^",3),1:1)
SET RTN="0^This "_MSG_" overlaps with another "_MSG
+25 IF DGW2
IF $SELECT($GET(OEFOIF):'$PIECE(DGW2,"^",3),1:1)
SET RTN="0^This "_MSG_" overlaps with another "_MSG
+26 SET DGRW1=$$RWITHIN(FRDT1,TODT1,.FRDT,.TODT)
SET DGRW2=$$RWITHIN(.FRDT,.TODT,FRDT1,TODT1)
+27 IF '$GET(OEFOIF)
IF DGRW1
IF '$$SAME(FRDT1,TODT1,FRDT,TODT)
SET RTN="0^This "_MSG_" is within another "_MSG
+28 IF '$GET(OEFOIF)
IF DGRW2
IF '$$SAME(FRDT1,TODT1,FRDT,TODT)
SET RTN="0^Another "_MSG_" is within another "_MSG
+29 IF $EXTRACT($PIECE($GET(OEFOIF),U,2),1,3)="UNK"!($EXTRACT(SUBRNG,1,3)="UNK")
Begin DoDot:2
+30 IF FRDT
IF TODT
IF '(DGRW1!DGRW2)
IF DGW1!DGW2
SET RTN="0^This "_MSG_" is within another "_MSG
End DoDot:2
+31 IF (DGRW1!(DGRW2))
IF $SELECT($EXTRACT($PIECE($GET(OEFOIF),U,2),1,3)'="UNK"&($EXTRACT(SUBRNG,1,3)'="UNK"):'$$SAME(FRDT1,TODT1,FRDT,TODT),1:$EXTRACT(SUBRNG,1,3)="UNK"&(FRDT'=FRDT1!(TODT'=TODT1)))
SET RTN="0^This "_MSG_" is within another "_MSG
End DoDot:1
+32 IF ('TYPE)
IF '$DATA(RTN1)
if $GET(OEFOIF)
SET OEFOIF(1)=1
QUIT "0^This conflict is not within a Military Service Episode"
+33 if $DATA(RTN)
QUIT RTN
+34 QUIT "1^OK"
SAME(FRDT1,TODT1,FRDT,TODT) ;
+1 NEW DGS1,DGS2,DGS3,DGS4
+2 SET DGS1=$$B4(FRDT,TODT1,1)
SET DGS2=$$B4(FRDT1,TODT,1)
+3 SET DGS3=$$B4(TODT,FRDT1,1)
SET DGS4=$$B4(TODT1,FRDT,1)
+4 if $PIECE(DGS1,"^",3)
QUIT 1
+5 if $PIECE(DGS2,"^",3)
QUIT 1
+6 if $PIECE(DGS3,"^",3)
QUIT 1
+7 if $PIECE(DGS4,"^",3)
QUIT 1
+8 QUIT 0
GETDAT(DFN,NODE,DATA) ;get data from the Patient (#2) file
+1 NEW LOOP,SUB,SUB1,Z,Z0,TMPDAT,DATA1,ERR,DR,SUBND,X,X1
+2 if ('$DATA(NODE))!('$DATA(DFN))
QUIT
+3 SET SUB=""
SET Z=1
+4 FOR
SET SUB=$ORDER(NODE(SUB))
if SUB=""
QUIT
Begin DoDot:1
+5 SET SUBND=$PIECE(SUB,".")
+6 SET DR=$TRANSLATE(NODE(SUB),",",";")
if DR=""
QUIT
+7 IF 'SUBND
Begin DoDot:2
+8 DO GETS^DIQ(2,DFN_",",DR,"I","TMPDAT","ERR")
+9 SET LOOP="F X="_$GET(NODE(SUB))_" S DATA1(X)=$G(TMPDAT(2,DFN_"","",X,""I"")),Z=Z+1"
+10 XECUTE LOOP
End DoDot:2
QUIT
+11 IF SUB-2=.3216
Begin DoDot:2
+12 ; Extract data from MSE sub-file #2.3216 (DG*5.3*797)
+13 SET Z0=0
FOR
SET Z0=$ORDER(^DPT(DFN,.3216,Z0))
if 'Z0
QUIT
DO GETS^DIQ(SUB,Z0_","_DFN_",",DR,"I","TMPDAT","ERR")
+14 SET X=""
FOR
SET X=$ORDER(TMPDAT(SUB,X))
if X=""
QUIT
SET X1=""
FOR
SET X1=$ORDER(TMPDAT(SUB,X,X1))
if X1=""
QUIT
SET DATA1("MSE-"_$PIECE(X,","),X1)=TMPDAT(SUB,X,X1,"I")
End DoDot:2
QUIT
+15 ; Extract dates from OIF OEF multiple too
+16 SET Z0=0
FOR
SET Z0=$ORDER(^DPT(DFN,SUB-2,Z0))
if 'Z0
QUIT
SET SUB1(Z0)=+$GET(^(Z0,0))
DO GETS^DIQ(SUB,Z0_","_DFN_",",DR,"I","TMPDAT","ERR")
+17 SET LOOP="F X="_$GET(NODE(SUB))_" F X1=0:0 S X1=$O(SUB1(X1)) Q:'X1 S DATA1($S(SUB1(X1)=3:""UNK"",1:$$EXTERNAL^DILFD(SUB,.01,,SUB1(X1)))_""-""_X1,X)=$G(TMPDAT(SUB,X1_"",""_DFN_"","",X,""I"")),Z=Z+1"
XECUTE LOOP
End DoDot:1
+18 SET DATA("MSL")=$GET(DATA1(.326))_"^"_$GET(DATA1(.327))
+19 SET DATA("MSNTL")=$SELECT($GET(DATA1(.3285))="Y":$GET(DATA1(.3292))_"^"_$GET(DATA1(.3293)),1:"^")
+20 SET DATA("MSNNTL")=$SELECT($GET(DATA1(.32945))="Y":$GET(DATA1(.3297))_"^"_$GET(DATA1(.3298)),1:"^")
+21 SET DATA("VIET")=$GET(DATA1(.32104))_"^"_$GET(DATA1(.32105))
+22 SET DATA("LEB")=$GET(DATA1(.3222))_"^"_$GET(DATA1(.3223))
+23 SET DATA("GREN")=$GET(DATA1(.3225))_"^"_$GET(DATA1(.3226))
+24 SET DATA("PAN")=$GET(DATA1(.3228))_"^"_$GET(DATA1(.3229))
+25 SET DATA("GULF")=$GET(DATA1(.322011))_"^"_$GET(DATA1(.322012))
+26 SET DATA("SOM")=$GET(DATA1(.322017))_"^"_$GET(DATA1(.322018))
+27 SET DATA("YUG")=$GET(DATA1(.32202))_"^"_$GET(DATA1(.322021))
+28 SET DATA("COMBAT")=$GET(DATA1(.5293))_"^"_$GET(DATA1(.5294))
+29 ; Set the MSE nodes (DG*5.3*797)
+30 SET Z="MSE"
FOR
SET Z=$ORDER(DATA1(Z))
if Z'["MSE"
QUIT
SET DATA(Z)=$GET(DATA1(Z,.01))_"^"_$GET(DATA1(Z,.02))
+31 ; Pick up the OEF/OIF nodes here - subscript is not numeric
+32 SET Z="O"
FOR
SET Z=$ORDER(DATA1(Z))
if Z=""
QUIT
SET DATA(Z)=$GET(DATA1(Z,.02))_"^"_$GET(DATA1(Z,.03))
+33 QUIT
MSEONLY(DATA,FRDT,TODT) ; are these dates within the whole MSE period?
+1 NEW TO,FROM,SUBRNG,FRDT1,TODT1,MSEFR,MSETO
+2 SET SUBRNG=""
FOR
SET SUBRNG=$ORDER(DATA(SUBRNG))
if SUBRNG=""
QUIT
Begin DoDot:1
+3 SET FRDT1=$PIECE(DATA(SUBRNG),"^")
SET TODT1=$PIECE(DATA(SUBRNG),"^",2)
+4 if FRDT1
SET FROM(FRDT1)=""
if TODT1
SET TO(TODT1)=""
End DoDot:1
+5 SET MSEFR=$ORDER(FROM(""))
SET MSETO=$ORDER(TO(""),-1)
+6 IF FRDT
IF (('$$B4(MSEFR,FRDT,1))!'$$B4(FRDT,MSETO,1))
QUIT "0^Conflict From Date is Not Within Military Service Episode Dates"
+7 IF TODT
IF (('$$B4(TODT,MSETO,1))!'$$B4(MSEFR,TODT,1))
QUIT "0^Conflict End Date is Not Within Military Service Episode Dates"
+8 QUIT "1^OK"
CNFLCTDT(FRDT,TODT,CNFLCT) ;are these dates valid for this conflict?
+1 if '$DATA(CNFLCT)
QUIT "0^INVALID CONFLICT"
+2 NEW CRNG
+3 SET CRNG=$$GETCNFDT($PIECE(CNFLCT,"-"))
if $TRANSLATE(CRNG,"^")=""
QUIT "0^INVALID CONFLICT"
+4 if $PIECE(CRNG,"^")=0
QUIT CRNG
+5 IF $GET(TODT)'=""
IF TODT<$PIECE(CRNG,U,3)
QUIT "0^Not Within Valid Date Range"
+6 IF $GET(FRDT)=""
QUIT $$WITHIN($PIECE(CRNG,"^"),$PIECE(CRNG,"^",2),.TODT)_" for Conflict - "_$$FMTE^XLFDT($PIECE(CRNG,"^"))_" through "_$$FMTE^XLFDT($PIECE(CRNG,"^",2))
+7 IF $GET(TODT)=""
QUIT $$WITHIN($PIECE(CRNG,"^"),$PIECE(CRNG,"^",2),.FRDT)_" for Conflict - "_$$FMTE^XLFDT($PIECE(CRNG,"^"))_" through "_$$FMTE^XLFDT($PIECE(CRNG,"^",2))
+8 QUIT $$RWITHIN($PIECE(CRNG,"^"),$PIECE(CRNG,"^",2),.FRDT,.TODT)_" for Conflict - "_$$FMTE^XLFDT($PIECE(CRNG,"^"))_" through "_$$FMTE^XLFDT($PIECE(CRNG,"^",2))
GETCNFDT(CNFLCT) ; get the date range for input conflict
+1 if '$DATA(CNFLCT)
QUIT "0^INVALID CONFLICT"
+2 NEW CRNG,CNFLCT1
+3 SET CNFLCT1=$PIECE(CNFLCT,"-")
+4 SET CRNG=$TEXT(@(CNFLCT1))
if CRNG']""
QUIT "0^INVALID CONFLICT"
+5 SET CRNG=$PIECE(CRNG,";;",2)
if $PIECE(CRNG,"^",2)=""
SET $PIECE(CRNG,"^",2)=$$DT^XLFDT
+6 if $PIECE(CRNG,"^")=""
SET $PIECE(CRNG,"^")=1410102
+7 if $PIECE(CRNG,U,3)=""
SET $PIECE(CRNG,U,3)=$PIECE(CRNG,U)
+8 QUIT CRNG
IGNORE(NODE,IFLD) ; extract top-level field to ignore when comparing
+1 NEW LOOP,QLOOP,RVAL,LSTPC,PC
+2 SET LOOP=""
SET IFLD="^"_IFLD_"^"
+3 FOR
SET LOOP=$ORDER(NODE(LOOP))
if LOOP=""
QUIT
Begin DoDot:1
+4 IF IFLD[("^"_$PIECE(NODE(LOOP),",")_"^")
SET NODE(LOOP)=$PIECE(NODE(LOOP),",",2,99)
SET LOOP=""
QUIT
+5 SET LSTPC=$LENGTH($TRANSLATE(NODE(LOOP),".0123456789"))+1
+6 IF IFLD[("^"_$PIECE(NODE(LOOP),",",LSTPC)_"^")
SET NODE(LOOP)=$PIECE(NODE(LOOP),",",1,LSTPC-1)
SET LOOP=""
QUIT
+7 FOR PC=1:1:LSTPC
if $GET(QLOOP)
QUIT
IF IFLD[("^"_$PIECE(NODE(LOOP),",",PC)_"^")
SET NODE(LOOP)=$PIECE(NODE(LOOP),",",1,PC-1)_","_$PIECE(NODE(LOOP),",",PC+1,99)
SET LOOP=""
QUIT
End DoDot:1
+8 QUIT
CNFLCT ;; *** DO NOT REMOVE OR CHANGE BELOW CONFLICT VALUES ***
+1 ;;
+2 ;'fr dt'^'to dt'^minimum 'to dt'
WWI ;;2170406^2181111
WWIIE ;;2411207^2461231
WWIIP ;;2411207^2461231
KOR ;;2500627^2550131
VIET ;;2610228^2750507
LEB ;;2831001^
GREN ;;2831023^2831121
PAN ;;2891220^2900131
GULF ;;2900802^
SOM ;;2920928^
YUG ;;2920622^
OTHER ;;^
OIF ;;3030301^^3030319
OEF ;;3010901^^3010911
UNK ;;3010901^^3010911
