source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPDT.m@ 1578

Last change on this file since 1578 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 9.4 KB
Line 
1DGRPDT ;ALB/BRM - MILITARY SERVICE DATE UTILITIES ; 1/18/05 4:27pm
2 ;;5.3;Registration;**562,603,626,673,731**;Aug 13, 1993;Build 8
3 ;
4DTUTIL(DGNEWDT,DGOLDDT,MYFLG) ; Date precision comparision API
5 S:$G(DGOLDDT)="" DGOLDDT="0000000"
6 Q:'$$VALID(.DGNEWDT) "0^INVALID DATE PARAMETER"
7 I $L(DGOLDDT)<7 S DGOLDDT=DGOLDDT_$E("0000000",$L(DGOLDDT)+1,7)
8 N X,Y,EXACTO,EXACTN,I,RTN,MSDATE,MSG
9 S RTN="",EXACTO=$$CHKEXC(DGOLDDT),EXACTN=$$CHKEXC(DGNEWDT)
10 I $G(MYFLG) Q:'$$MNTHYR(DGNEWDT) "0^Date must contain month and year"
11 Q:EXACTO=EXACTN "1^Same Precision"
12 F I=1:1:3 Q:RTN'="" D
13 .S:$E(EXACTN,I)<$E(EXACTO,I) RTN="0^ is Less Precise Than Previously Entered "
14 .S:$E(EXACTN,I)>$E(EXACTO,I) RTN="1^ is More Precise Than Previously Entered "
15 .S MSG=$S(I=1:"Year",I=2:"Month",I=3:"Day",1:"")
16 .S:RTN'="" $P(RTN,"^",2)=MSG_$P(RTN,"^",2)_MSG
17 Q $S($G(RTN)'="":RTN,1:"0^Unknown Precision")
18CHKEXC(MSDATE) ; construct precision string (3 digit return value - YMD)
19 Q ($E(MSDATE,1,3)'="000")_($E(MSDATE,4,5)'="00")_($E(MSDATE,6,7)'="00")
20MNTHYR(MSDATE) ; ensure month and year are not imprecise (binary return value)
21 Q ($E(MSDATE,1,3)'="000")&($E(MSDATE,4,5)'="00")
22WITHIN(FRDT,TODT,CHKDT) ; is CHKDT within FRDT and TODT?
23 N DGRPB41,DGRPB42
24 Q:'$$VALID($G(CHKDT)) "0^Invalid Date"
25 Q:('$G(FRDT))!('$G(TODT)) "0^Missing Required Date Range"
26 Q:('$$VALID(FRDT)!'$$VALID(TODT)!'$$B4(FRDT,TODT,1)) "0^Invalid Date Range"
27 S DGRPB41=$$B4(FRDT,CHKDT,1),DGRPB42=$$B4(CHKDT,TODT,1)
28 I 'DGRPB41!'DGRPB42 Q "0^Not Within Valid Date Range"
29 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
30VALID(DATE) ; is this a valid Fileman date? (limits are from FR^XLFDT)
31 Q:'$D(DATE) 0
32 Q (1410102'>DATE)&(DATE'>4141015.235959)
33B4(DATE1,DATE2,SAME) ;is DATE1 before DATE2?
34 N IMPRDT,IDT,IRTN,CDATE1,CDATE2
35 S DATE1=$P($G(DATE1),"."),DATE2=$P($G(DATE2),".")
36 Q:DATE1=""!DATE2="" 1
37 I $G(SAME),DATE1=DATE2 Q "1^1"
38 I $$CHKEXC(DATE1)'=111!$$CHKEXC(DATE2)'=111 D Q:$G(IRTN) IRTN
39 .S (CDATE1,CDATE2)="0000000"
40 .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)
41 .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)
42 .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)
43 .I CDATE1<CDATE2 S IRTN=1 Q
44 .I CDATE1=CDATE2 S IRTN="1^1" Q
45 Q DATE1<DATE2
46RWITHIN(FRDT,TODT,CHKDT1,CHKDT2) ;are CHKDT1 and CHKDT2 within FRDT and TODT?
47 N CHK1,CHK2
48 S CHK1=$$WITHIN(.FRDT,.TODT,.CHKDT1) Q:'CHK1 CHK1
49 S CHK2=$$WITHIN(.FRDT,.TODT,.CHKDT2) Q:'CHK2 CHK2
50 Q "1^Both Date are Within Date Range"_$S(($P(CHK1,"^",3)!$P(CHK2,"^",3)):"^1",1:"")
51COVRLP2(DFN,FRDT,TODT,IGNORE,OEFOIF) ; check conflict with type 0 and 2 (see below)
52 Q:('$G(DFN))!('$D(^DPT(DFN))) "0^INVALID DFN"
53 S RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,-1,$G(IGNORE),.OEFOIF)
54 Q:$P(RTN,"^")=0 RTN
55 S RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,2,$G(IGNORE),.OEFOIF)
56 Q RTN
57OVRLPCHK(DFN,FRDT,TODT,TYPE,IGNORE,OEFOIF) ;check for overlapping date ranges
58 ; pass OEFOIF by ref - return OEFOIF(1)=1: OEF/OIF "cnflct not within MSE
59 N RTN1,DATA,NODE,RTN,FRDT1,MSG,SUBRNG,TODT1,DGW1,DGW2,DGRW1,DGRW2,DGZ
60 Q:('$G(DFN))!('$D(^DPT(DFN))) "0^INVALID DFN"
61 I TYPE<2 D
62 . S NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298"
63 E D
64 . ; If checking an OEF/OIF period, only check against OEF/OIF
65 . I $G(OEFOIF) S NODE(2.3215)=".02,.03" K IGNORE Q
66 . S NODE(.321)=".32104,.32105",NODE(.322)=".3222,.3223,.3225,.3226,.3228,.3229,.322011,.322012,.322017,.322018,.32202,.322021",NODE(.52)=".5293,.5294"
67 D:$G(IGNORE)]"" IGNORE(.NODE,.IGNORE)
68 D GETDAT(DFN,.NODE,.DATA) Q:'$D(DATA) "1^CANNOT FIND PATIENT DATA"
69 I $G(OEFOIF),$P(OEFOIF,U,2)'="" K DATA($P(OEFOIF,U,2)) ; OEF/OIF entry to exclude (used instead of IGNORE)
70 I TYPE<0 S DGZ=$$MSEONLY(.DATA,FRDT,TODT) S:'DGZ&$G(OEFOIF) OEFOIF(1)=1 Q DGZ
71 S SUBRNG="" F S SUBRNG=$O(DATA(SUBRNG)) Q:SUBRNG=""!($D(RTN)) D
72 .S FRDT1=$P(DATA(SUBRNG),"^"),TODT1=$P(DATA(SUBRNG),"^",2)
73 .I FRDT1="",TODT1="" Q
74 .I 'TYPE S:$$RWITHIN(FRDT1,TODT1,.FRDT,.TODT) RTN1=$G(RTN1)+1 Q
75 .S MSG=$S(TYPE=1:"Military Service Episode",1:"Conflict")
76 . ; For OEF/OIF only - dates must be totally non-overlapping
77 .S DGW1=$$WITHIN(FRDT1,TODT1,.FRDT),DGW2=$$WITHIN(FRDT1,TODT1,.TODT)
78 .I DGW1,$S($G(OEFOIF):'$P(DGW1,"^",3),1:1) S RTN="0^This "_MSG_" overlaps with another "_MSG
79 .I DGW2,$S($G(OEFOIF):'$P(DGW2,"^",3),1:1) S RTN="0^This "_MSG_" overlaps with another "_MSG
80 .S DGRW1=$$RWITHIN(FRDT1,TODT1,.FRDT,.TODT),DGRW2=$$RWITHIN(.FRDT,.TODT,FRDT1,TODT1)
81 .I '$G(OEFOIF),DGRW1,'$$SAME(FRDT1,TODT1,FRDT,TODT) S RTN="0^This "_MSG_" is within another "_MSG
82 .I '$G(OEFOIF),DGRW2,'$$SAME(FRDT1,TODT1,FRDT,TODT) S RTN="0^Another "_MSG_" is within another "_MSG
83 .I $E($P($G(OEFOIF),U,2),1,3)="UNK"!($E(SUBRNG,1,3)="UNK") D
84 .. I FRDT,TODT,'(DGRW1!DGRW2),DGW1!DGW2 S RTN="0^This "_MSG_" is within another "_MSG
85 .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
86 I ('TYPE),'$D(RTN1) S:$G(OEFOIF) OEFOIF(1)=1 Q "0^This conflict is not within a Military Service Episode"
87 Q:$D(RTN) RTN
88 Q "1^OK"
89SAME(FRDT1,TODT1,FRDT,TODT) ;
90 N DGS1,DGS2,DGS3,DGS4
91 S DGS1=$$B4(FRDT,TODT1,1),DGS2=$$B4(FRDT1,TODT,1)
92 S DGS3=$$B4(TODT,FRDT1,1),DGS4=$$B4(TODT1,FRDT,1)
93 Q:$P(DGS1,"^",3) 1
94 Q:$P(DGS2,"^",3) 1
95 Q:$P(DGS3,"^",3) 1
96 Q:$P(DGS4,"^",3) 1
97 Q 0
98GETDAT(DFN,NODE,DATA) ;get data from the Patient (#2) file
99 N LOOP,SUB,SUB1,Z,Z0,TMPDAT,DATA1,ERR,DR,SUBND,X,X1
100 Q:('$D(NODE))!('$D(DFN))
101 S SUB="",Z=1
102 F S SUB=$O(NODE(SUB)) Q:SUB="" D
103 .S SUBND=$P(SUB,".")
104 .S DR=$TR(NODE(SUB),",",";") Q:DR=""
105 .I 'SUBND D Q
106 ..D GETS^DIQ(2,DFN_",",DR,"I","TMPDAT","ERR")
107 ..S LOOP="F X="_$G(NODE(SUB))_" S DATA1(X)=$G(TMPDAT(2,DFN_"","",X,""I"")),Z=Z+1"
108 ..X LOOP
109 . ; Extract dates from OIF OEF multiple too
110 . 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")
111 .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
112 S DATA("MSL")=$G(DATA1(.326))_"^"_$G(DATA1(.327))
113 S DATA("MSNTL")=$S($G(DATA1(.3285))="Y":$G(DATA1(.3292))_"^"_$G(DATA1(.3293)),1:"^")
114 S DATA("MSNNTL")=$S($G(DATA1(.32945))="Y":$G(DATA1(.3297))_"^"_$G(DATA1(.3298)),1:"^")
115 S DATA("VIET")=$G(DATA1(.32104))_"^"_$G(DATA1(.32105))
116 S DATA("LEB")=$G(DATA1(.3222))_"^"_$G(DATA1(.3223))
117 S DATA("GREN")=$G(DATA1(.3225))_"^"_$G(DATA1(.3226))
118 S DATA("PAN")=$G(DATA1(.3228))_"^"_$G(DATA1(.3229))
119 S DATA("GULF")=$G(DATA1(.322011))_"^"_$G(DATA1(.322012))
120 S DATA("SOM")=$G(DATA1(.322017))_"^"_$G(DATA1(.322018))
121 S DATA("YUG")=$G(DATA1(.32202))_"^"_$G(DATA1(.322021))
122 S DATA("COMBAT")=$G(DATA1(.5293))_"^"_$G(DATA1(.5294))
123 ; Pick up the OEF/OIF nodes here - subscript is not numeric
124 S Z=" " F S Z=$O(DATA1(Z)) Q:Z="" S DATA(Z)=$G(DATA1(Z,.02))_"^"_$G(DATA1(Z,.03))
125 Q
126MSEONLY(DATA,FRDT,TODT) ; are these dates within the whole MSE period?
127 N TO,FROM,SUBRNG,FRDT1,TODT1,MSEFR,MSETO
128 S SUBRNG="" F S SUBRNG=$O(DATA(SUBRNG)) Q:SUBRNG="" D
129 .S FRDT1=$P(DATA(SUBRNG),"^"),TODT1=$P(DATA(SUBRNG),"^",2)
130 .S:FRDT1 FROM(FRDT1)="" S:TODT1 TO(TODT1)=""
131 S MSEFR=$O(FROM("")),MSETO=$O(TO(""),-1)
132 I FRDT,(('$$B4(MSEFR,FRDT,1))!'$$B4(FRDT,MSETO,1)) Q "0^Conflict From Date is Not Within Military Service Episode Dates"
133 I TODT,(('$$B4(TODT,MSETO,1))!'$$B4(MSEFR,TODT,1)) Q "0^Conflict End Date is Not Within Military Service Episode Dates"
134 Q "1^OK"
135CNFLCTDT(FRDT,TODT,CNFLCT) ;are these dates valid for this conflict?
136 Q:'$D(CNFLCT) "0^INVALID CONFLICT"
137 N CRNG
138 S CRNG=$$GETCNFDT($P(CNFLCT,"-")) Q:$TR(CRNG,"^")="" "0^INVALID CONFLICT"
139 Q:$P(CRNG,"^")=0 CRNG
140 I $G(TODT)'="",TODT<$P(CRNG,U,3) Q "0^Not Within Valid Date Range"
141 I $G(FRDT)="" Q $$WITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.TODT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
142 I $G(TODT)="" Q $$WITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.FRDT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
143 Q $$RWITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.FRDT,.TODT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
144GETCNFDT(CNFLCT) ; get the date range for input conflict
145 Q:'$D(CNFLCT) "0^INVALID CONFLICT"
146 N CRNG,CNFLCT1
147 S CNFLCT1=$P(CNFLCT,"-")
148 S CRNG=$T(@(CNFLCT1)) Q:CRNG']"" "0^INVALID CONFLICT"
149 S CRNG=$P(CRNG,";;",2) S:$P(CRNG,"^",2)="" $P(CRNG,"^",2)=$$DT^XLFDT
150 S:$P(CRNG,"^")="" $P(CRNG,"^")=1410102
151 S:$P(CRNG,U,3)="" $P(CRNG,U,3)=$P(CRNG,U)
152 Q CRNG
153IGNORE(NODE,IFLD) ; extract top-level field to ignore when comparing
154 N LOOP,QLOOP,RVAL,LSTPC,PC
155 S LOOP="",IFLD="^"_IFLD_"^"
156 F S LOOP=$O(NODE(LOOP)) Q:LOOP="" D
157 .I IFLD[("^"_$P(NODE(LOOP),",")_"^") S NODE(LOOP)=$P(NODE(LOOP),",",2,99),LOOP="" Q
158 .S LSTPC=$L($TR(NODE(LOOP),".0123456789"))+1
159 .I IFLD[("^"_$P(NODE(LOOP),",",LSTPC)_"^") S NODE(LOOP)=$P(NODE(LOOP),",",1,LSTPC-1),LOOP="" Q
160 .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
161 Q
162CNFLCT ;; *** DO NOT REMOVE OR CHANGE BELOW CONFLICT VALUES ***
163 ;;
164 ;'fr dt'^'to dt'^minimum 'to dt'
165WWI ;;2170406^2181111
166WWIIE ;;2411207^2461231
167WWIIP ;;2411207^2461231
168KOR ;;2500627^2550131
169VIET ;;2610228^2750507
170LEB ;;2831001^
171GREN ;;2831023^2831121
172PAN ;;2891220^2900131
173GULF ;;2900802^
174SOM ;;2920928^
175YUG ;;2920622^
176OTHER ;;^
177OIF ;;3030301^^3030319
178OEF ;;3010901^^3010911
179UNK ;;3010901^^3010911
Note: See TracBrowser for help on using the repository browser.