Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGRPDT

DGRPDT.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. DTUTIL(DGNEWDT,DGOLDDT,MYFLG) ; Date precision comparision API
  1.  S:$G(DGOLDDT)="" DGOLDDT="0000000"
  1.  Q:'$$VALID(.DGNEWDT) "0^INVALID DATE PARAMETER"
  1.  I $L(DGOLDDT)<7 S DGOLDDT=DGOLDDT_$E("0000000",$L(DGOLDDT)+1,7)
  1.  N X,Y,EXACTO,EXACTN,I,RTN,MSDATE,MSG
  1.  S RTN="",EXACTO=$$CHKEXC(DGOLDDT),EXACTN=$$CHKEXC(DGNEWDT)
  1.  I $G(MYFLG) Q:'$$MNTHYR(DGNEWDT) "0^Date must contain month and year"
  1.  Q:EXACTO=EXACTN "1^Same Precision"
  1.  F I=1:1:3  Q:RTN'=""  D
  1.  .S:$E(EXACTN,I)<$E(EXACTO,I) RTN="0^ is Less Precise Than Previously Entered "
  1.  .S:$E(EXACTN,I)>$E(EXACTO,I) RTN="1^ is More Precise Than Previously Entered "
  1.  .S MSG=$S(I=1:"Year",I=2:"Month",I=3:"Day",1:"")
  1.  .S:RTN'="" $P(RTN,"^",2)=MSG_$P(RTN,"^",2)_MSG
  1.  Q $S($G(RTN)'="":RTN,1:"0^Unknown Precision")
  1. CHKEXC(MSDATE) ; construct precision string (3 digit return value - YMD)
  1.  Q ($E(MSDATE,1,3)'="000")_($E(MSDATE,4,5)'="00")_($E(MSDATE,6,7)'="00")
  1. MNTHYR(MSDATE) ; ensure month and year are not imprecise (binary return value)
  1.  Q ($E(MSDATE,1,3)'="000")&($E(MSDATE,4,5)'="00")
  1. WITHIN(FRDT,TODT,CHKDT) ; is CHKDT within FRDT and TODT?
  1.  N DGRPB41,DGRPB42
  1.  Q:'$$VALID($G(CHKDT)) "0^Invalid Date"
  1.  Q:('$G(FRDT))!('$G(TODT)) "0^Missing Required Date Range"
  1.  Q:('$$VALID(FRDT)!'$$VALID(TODT)!'$$B4(FRDT,TODT,1)) "0^Invalid Date Range"
  1.  S DGRPB41=$$B4(FRDT,CHKDT,1),DGRPB42=$$B4(CHKDT,TODT,1)
  1.  I 'DGRPB41!'DGRPB42 Q "0^Not Within Valid Date Range"
  1.  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
  1. VALID(DATE) ; is this a valid Fileman date? (limits are from FR^XLFDT)
  1.  Q:'$D(DATE) 0
  1.  Q (1410102'>DATE)&(DATE'>4141015.235959)
  1. B4(DATE1,DATE2,SAME) ;is DATE1 before DATE2?
  1.  N IMPRDT,IDT,IRTN,CDATE1,CDATE2
  1.  S DATE1=$P($G(DATE1),"."),DATE2=$P($G(DATE2),".")
  1.  Q:DATE1=""!DATE2="" 1
  1.  I $G(SAME),DATE1=DATE2 Q "1^1"
  1.  I $$CHKEXC(DATE1)'=111!$$CHKEXC(DATE2)'=111 D  Q:$G(IRTN) IRTN
  1.  .S (CDATE1,CDATE2)="0000000"
  1.  .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)
  1.  .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)
  1.  .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)
  1.  .I CDATE1<CDATE2 S IRTN=1 Q
  1.  .I CDATE1=CDATE2 S IRTN="1^1" Q
  1.  Q DATE1<DATE2
  1. RWITHIN(FRDT,TODT,CHKDT1,CHKDT2) ;are CHKDT1 and CHKDT2 within FRDT and TODT?
  1.  N CHK1,CHK2
  1.  S CHK1=$$WITHIN(.FRDT,.TODT,.CHKDT1) Q:'CHK1 CHK1
  1.  S CHK2=$$WITHIN(.FRDT,.TODT,.CHKDT2) Q:'CHK2 CHK2
  1.  Q "1^Both Date are Within Date Range"_$S(($P(CHK1,"^",3)!$P(CHK2,"^",3)):"^1",1:"")
  1. COVRLP2(DFN,FRDT,TODT,IGNORE,OEFOIF) ; check conflict with type 0 and 2 (see below)
  1.  Q:('$G(DFN))!('$D(^DPT(DFN))) "0^INVALID DFN"
  1.  S RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,-1,$G(IGNORE),.OEFOIF)
  1.  Q:$P(RTN,"^")=0 RTN
  1.  S RTN=$$OVRLPCHK(DFN,.FRDT,.TODT,2,$G(IGNORE),.OEFOIF)
  1.  Q RTN
  1. 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
  1.  N RTN1,DATA,NODE,RTN,FRDT1,MSG,SUBRNG,TODT1,DGW1,DGW2,DGRW1,DGRW2,DGZ
  1.  Q:('$G(DFN))!('$D(^DPT(DFN))) "0^INVALID DFN"
  1.  I TYPE<2 D
  1.  . ; If data in MSE sub-file #2.3216, do not use old MSE fields
  1.  . I $G(MSE)!($D(^DPT(DFN,.3216))) S NODE(2.3216)=".01,.02" K IGNORE Q
  1.  . S NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298"
  1.  E  D
  1.  . ; If checking an OEF/OIF period, only check against OEF/OIF
  1.  . I $G(OEFOIF) S NODE(2.3215)=".02,.03" K IGNORE Q
  1.  . S NODE(.321)=".32104,.32105",NODE(.322)=".3222,.3223,.3225,.3226,.3228,.3229,.322011,.322012,.322017,.322018,.32202,.322021",NODE(.52)=".5293,.5294"
  1.  D:$G(IGNORE)]"" IGNORE(.NODE,.IGNORE)
  1.  D GETDAT(DFN,.NODE,.DATA) Q:'$D(DATA) "1^CANNOT FIND PATIENT DATA"
  1.  I $G(MSE) K DATA("MSE-"_MSE)  ;MSE entry to exclude (used instead of IGNORE) - DG*5.3*797
  1.  I $G(OEFOIF),$P(OEFOIF,U,2)'="" K DATA($P(OEFOIF,U,2)) ; OEF/OIF entry to exclude (used instead of IGNORE)
  1.  I TYPE<0 S DGZ=$$MSEONLY(.DATA,FRDT,TODT) S:'DGZ&$G(OEFOIF) OEFOIF(1)=1 Q DGZ
  1.  S SUBRNG="" F  S SUBRNG=$O(DATA(SUBRNG)) Q:SUBRNG=""!($D(RTN))  D
  1.  .S FRDT1=$P(DATA(SUBRNG),"^"),TODT1=$P(DATA(SUBRNG),"^",2)
  1.  .I FRDT1="",TODT1="" Q
  1.  .I 'TYPE S:$$RWITHIN(FRDT1,TODT1,.FRDT,.TODT) RTN1=$G(RTN1)+1 Q
  1.  .S MSG=$S(TYPE=1:"Military Service Episode",1:"Conflict")
  1.  . ; For OEF/OIF only - dates must be totally non-overlapping
  1.  .S DGW1=$$WITHIN(FRDT1,TODT1,.FRDT),DGW2=$$WITHIN(FRDT1,TODT1,.TODT)
  1.  .I DGW1,$S($G(OEFOIF):'$P(DGW1,"^",3),1:1) S RTN="0^This "_MSG_" overlaps with another "_MSG
  1.  .I DGW2,$S($G(OEFOIF):'$P(DGW2,"^",3),1:1) S RTN="0^This "_MSG_" overlaps with another "_MSG
  1.  .S DGRW1=$$RWITHIN(FRDT1,TODT1,.FRDT,.TODT),DGRW2=$$RWITHIN(.FRDT,.TODT,FRDT1,TODT1)
  1.  .I '$G(OEFOIF),DGRW1,'$$SAME(FRDT1,TODT1,FRDT,TODT) S RTN="0^This "_MSG_" is within another "_MSG
  1.  .I '$G(OEFOIF),DGRW2,'$$SAME(FRDT1,TODT1,FRDT,TODT) S RTN="0^Another "_MSG_" is within another "_MSG
  1.  .I $E($P($G(OEFOIF),U,2),1,3)="UNK"!($E(SUBRNG,1,3)="UNK") D
  1.  .. I FRDT,TODT,'(DGRW1!DGRW2),DGW1!DGW2 S RTN="0^This "_MSG_" is within another "_MSG
  1.  .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
  1.  I ('TYPE),'$D(RTN1) S:$G(OEFOIF) OEFOIF(1)=1 Q "0^This conflict is not within a Military Service Episode"
  1.  Q:$D(RTN) RTN
  1.  Q "1^OK"
  1. SAME(FRDT1,TODT1,FRDT,TODT) ;
  1.  N DGS1,DGS2,DGS3,DGS4
  1.  S DGS1=$$B4(FRDT,TODT1,1),DGS2=$$B4(FRDT1,TODT,1)
  1.  S DGS3=$$B4(TODT,FRDT1,1),DGS4=$$B4(TODT1,FRDT,1)
  1.  Q:$P(DGS1,"^",3) 1
  1.  Q:$P(DGS2,"^",3) 1
  1.  Q:$P(DGS3,"^",3) 1
  1.  Q:$P(DGS4,"^",3) 1
  1.  Q 0
  1. GETDAT(DFN,NODE,DATA) ;get data from the Patient (#2) file
  1.  N LOOP,SUB,SUB1,Z,Z0,TMPDAT,DATA1,ERR,DR,SUBND,X,X1
  1.  Q:('$D(NODE))!('$D(DFN))
  1.  S SUB="",Z=1
  1.  F  S SUB=$O(NODE(SUB)) Q:SUB=""  D
  1.  .S SUBND=$P(SUB,".")
  1.  .S DR=$TR(NODE(SUB),",",";") Q:DR=""
  1.  .I 'SUBND D  Q
  1.  ..D GETS^DIQ(2,DFN_",",DR,"I","TMPDAT","ERR")
  1.  ..S LOOP="F X="_$G(NODE(SUB))_" S DATA1(X)=$G(TMPDAT(2,DFN_"","",X,""I"")),Z=Z+1"
  1.  ..X LOOP
  1.  .I SUB-2=.3216 D  Q
  1.  ..; Extract data from MSE sub-file #2.3216 (DG*5.3*797)
  1.  ..S Z0=0 F  S Z0=$O(^DPT(DFN,.3216,Z0)) Q:'Z0  D GETS^DIQ(SUB,Z0_","_DFN_",",DR,"I","TMPDAT","ERR")
  1.  ..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")
  1.  . ; Extract dates from OIF OEF multiple too
  1.  . 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")
  1.  .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
  1.  S DATA("MSL")=$G(DATA1(.326))_"^"_$G(DATA1(.327))
  1.  S DATA("MSNTL")=$S($G(DATA1(.3285))="Y":$G(DATA1(.3292))_"^"_$G(DATA1(.3293)),1:"^")
  1.  S DATA("MSNNTL")=$S($G(DATA1(.32945))="Y":$G(DATA1(.3297))_"^"_$G(DATA1(.3298)),1:"^")
  1.  S DATA("VIET")=$G(DATA1(.32104))_"^"_$G(DATA1(.32105))
  1.  S DATA("LEB")=$G(DATA1(.3222))_"^"_$G(DATA1(.3223))
  1.  S DATA("GREN")=$G(DATA1(.3225))_"^"_$G(DATA1(.3226))
  1.  S DATA("PAN")=$G(DATA1(.3228))_"^"_$G(DATA1(.3229))
  1.  S DATA("GULF")=$G(DATA1(.322011))_"^"_$G(DATA1(.322012))
  1.  S DATA("SOM")=$G(DATA1(.322017))_"^"_$G(DATA1(.322018))
  1.  S DATA("YUG")=$G(DATA1(.32202))_"^"_$G(DATA1(.322021))
  1.  S DATA("COMBAT")=$G(DATA1(.5293))_"^"_$G(DATA1(.5294))
  1.  ; Set the MSE nodes (DG*5.3*797)
  1.  S Z="MSE" F  S Z=$O(DATA1(Z)) Q:Z'["MSE"  S DATA(Z)=$G(DATA1(Z,.01))_"^"_$G(DATA1(Z,.02))
  1.  ; Pick up the OEF/OIF nodes here - subscript is not numeric
  1.  S Z="O" F  S Z=$O(DATA1(Z)) Q:Z=""  S DATA(Z)=$G(DATA1(Z,.02))_"^"_$G(DATA1(Z,.03))
  1.  Q
  1. MSEONLY(DATA,FRDT,TODT) ; are these dates within the whole MSE period?
  1.  N TO,FROM,SUBRNG,FRDT1,TODT1,MSEFR,MSETO
  1.  S SUBRNG="" F  S SUBRNG=$O(DATA(SUBRNG)) Q:SUBRNG=""  D
  1.  .S FRDT1=$P(DATA(SUBRNG),"^"),TODT1=$P(DATA(SUBRNG),"^",2)
  1.  .S:FRDT1 FROM(FRDT1)="" S:TODT1 TO(TODT1)=""
  1.  S MSEFR=$O(FROM("")),MSETO=$O(TO(""),-1)
  1.  I FRDT,(('$$B4(MSEFR,FRDT,1))!'$$B4(FRDT,MSETO,1)) Q "0^Conflict From Date is Not Within Military Service Episode Dates"
  1.  I TODT,(('$$B4(TODT,MSETO,1))!'$$B4(MSEFR,TODT,1)) Q "0^Conflict End Date is Not Within Military Service Episode Dates"
  1.  Q "1^OK"
  1. CNFLCTDT(FRDT,TODT,CNFLCT) ;are these dates valid for this conflict?
  1.  Q:'$D(CNFLCT) "0^INVALID CONFLICT"
  1.  N CRNG
  1.  S CRNG=$$GETCNFDT($P(CNFLCT,"-")) Q:$TR(CRNG,"^")="" "0^INVALID CONFLICT"
  1.  Q:$P(CRNG,"^")=0 CRNG
  1.  I $G(TODT)'="",TODT<$P(CRNG,U,3) Q "0^Not Within Valid Date Range"
  1.  I $G(FRDT)="" Q $$WITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.TODT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
  1.  I $G(TODT)="" Q $$WITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.FRDT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
  1.  Q $$RWITHIN($P(CRNG,"^"),$P(CRNG,"^",2),.FRDT,.TODT)_" for Conflict - "_$$FMTE^XLFDT($P(CRNG,"^"))_" through "_$$FMTE^XLFDT($P(CRNG,"^",2))
  1. GETCNFDT(CNFLCT) ; get the date range for input conflict
  1.  Q:'$D(CNFLCT) "0^INVALID CONFLICT"
  1.  N CRNG,CNFLCT1
  1.  S CNFLCT1=$P(CNFLCT,"-")
  1.  S CRNG=$T(@(CNFLCT1)) Q:CRNG']"" "0^INVALID CONFLICT"
  1.  S CRNG=$P(CRNG,";;",2) S:$P(CRNG,"^",2)="" $P(CRNG,"^",2)=$$DT^XLFDT
  1.  S:$P(CRNG,"^")="" $P(CRNG,"^")=1410102
  1.  S:$P(CRNG,U,3)="" $P(CRNG,U,3)=$P(CRNG,U)
  1.  Q CRNG
  1. IGNORE(NODE,IFLD) ; extract top-level field to ignore when comparing
  1.  N LOOP,QLOOP,RVAL,LSTPC,PC
  1.  S LOOP="",IFLD="^"_IFLD_"^"
  1.  F  S LOOP=$O(NODE(LOOP)) Q:LOOP=""  D
  1.  .I IFLD[("^"_$P(NODE(LOOP),",")_"^") S NODE(LOOP)=$P(NODE(LOOP),",",2,99),LOOP="" Q
  1.  .S LSTPC=$L($TR(NODE(LOOP),".0123456789"))+1
  1.  .I IFLD[("^"_$P(NODE(LOOP),",",LSTPC)_"^") S NODE(LOOP)=$P(NODE(LOOP),",",1,LSTPC-1),LOOP="" Q
  1.  .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
  1.  Q
  1. CNFLCT ;; ***  DO NOT REMOVE OR CHANGE BELOW CONFLICT VALUES  ***
  1.  ;;
  1.  ;'fr dt'^'to dt'^minimum 'to dt'
  1. WWI ;;2170406^2181111
  1. WWIIE ;;2411207^2461231
  1. WWIIP ;;2411207^2461231
  1. KOR ;;2500627^2550131
  1. VIET ;;2610228^2750507
  1. LEB ;;2831001^
  1. GREN ;;2831023^2831121
  1. PAN ;;2891220^2900131
  1. GULF ;;2900802^
  1. SOM ;;2920928^
  1. YUG ;;2920622^
  1. OTHER ;;^
  1. OIF ;;3030301^^3030319
  1. OEF ;;3010901^^3010911
  1. UNK ;;3010901^^3010911