DGPTAE02 ;ALB/MTC,HIOFO/FT - 701 Edit Checks ;3/12/15 1:51pm
;;5.3;Registration;**8,22,39,114,176,251,247,270,446,418,482,466,683,729,884,1057**;Aug 13, 1993;Build 17
;10/06/1999 ACS - Added Place of Disposition codes M,Y,Z to the
;validity checks
;5/15/2000 ACS - Added Treating Specialty 37 as a valid code
;5/16/2000 MM - Added Treating Specialties 38 & 39 as valid codes
;5/26/2000 JRP - Place of Disposition code M valid for station
; types 10, 11, 30, and 40
;09/27/2006 JRC - Added Treating Specialties 13, 30, 48, 49, 78,
; 82 and 97
;
CHECK ;
I (DGPTSP1'?1AN)!(DGPTSP2'?1AN) S DGPTERC=1 Q
I DGPTSP1="0"&((DGPTSP2'?1AN)!(DGPTSP2="0")) S DGPTERC=1 G EXIT
; No zero or double zeroes allowed
I DGPTSP1=5 G EXIT
; All codes 50-59 allowable
; New code 95:p-418
; New code 96;p-446
EXIT ;
K DGPTSP1,DGPTSP2
Q
;
DISPTY ;
N I
S DGPTERC=0
Q:"1"[DGPTDTY
I DGPTDTY=2 S DGPTERC=707 F I=10,11,30,40,42 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
I DGPTERC Q
;
;-- if dis type = To Non-Bed Care then VA aus and Out pat = no
;I DGPTDTY=2,((DGPTDVA'=2)!(DGPTDOP'=3)) S DGPTERC=707 Q
;
I DGPTDTY=3&(DGPTSTTY'["^42^") S DGPTERC=707 Q
;-- if dis type = Transfer then Out pat cannot be yes
I DGPTDTY=5,DGPTDOP=1 S DGPTERC=707
;-- if dis type = Transfer then Out pat cannot be yes, rec sta'=""
I DGPTDTY=5,DGPTDOP'=1,'DGPTDRF S DGPTERC=711 Q
;-- if dis type irr, death w/aotopsy then va asp, op care, pod = ""
I "467"[DGPTDTY,(DGPTDOP!DGPTDVA!DGPTDPD) S DGPTERC=707 Q
Q
OP ;
Q:"13"'[DGPTDOP
S DGPTERC=708 F I=10,11,40,42 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
Q
POD ;place of disposition
N I
Q:"X012347BCDFGHJKL "[DGPTDPD
; if POD NHCU then Out=no VA aus=yes
I DGPTDPD=5,((DGPTDOP'=3)!(DGPTDVA'=1)) S DGPTERC=710 Q
; if POD NHCU then Out=no VA aus=yes, rec station'=""
I DGPTDPD=5,DGPTDOP=3,DGPTDVA=1,'DGPTDRF S DGPTERC=711 Q
I "PR"[DGPTDPD,((DGPTSTTY'["^10^")!(DGPTSTTY'["^11^")) S DGPTERC=710 Q
I DGPTDPD="M" S DGPTERC=710 F I=10,11,30,40 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
I DGPTDPD="T" S DGPTERC=710 F I=10,11,40 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
I "UYZ"[DGPTDPD S DGPTERC=710 F I=10,11,20:1:27,30,40:1:42 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
Q
LEAVE ;
S DGPTLVDY=0
S DGPTL3=0 F S DGPTL3=$O(^TMP("AEDIT",$J,"N501",DGPTL3)) Q:DGPTL3="" S DGPTLVDY=DGPTLVDY+$E(^TMP("AEDIT",$J,"N501",DGPTL3),49,51)+$E(^TMP("AEDIT",$J,"N501",DGPTL3),52,54)
I (DGPTLVDY+DGPTDAS)>DGPTELP S DGPTERC=745
K DGPTL3,DGPTLVDY
Q
;
CANDP ;compensation and pension status
I "12345678"'[DGPTDCP S DGPTERC=714 Q
;-- if no POS then no edit
Q:DGPTPOS2=9
;-- if WWI then no edit
Q:DGPTPOS2=1
;-- if POW then no edit
I $L(DGPTPOW)=1,("23456789AB"[DGPTPOW) Q
D CONSIS Q:DGPTERC
D STATYP Q:DGPTERC
D CPMT Q:DGPTERC
Q
CONSIS ;
I ("01234578X"[DGPTPOS2)&("1234567"'[DGPTDCP) S DGPTERC=736 Q
I ("ABCD"[DGPTPOS2) Q
I DGPTPOS2="Z"&("1234567"'[DGPTDCP) S DGPTERC=736 Q
Q:"012345678ABCDXZ"[DGPTPOS2
S:DGPTDCP'=8 DGPTERC=736
Q
STATYP ;
Q:(DGPTSTTY["^30^")!(DGPTSTTY="^")!(DGPTSTTY="")
;Note: There is not sufficient information contained in the
;station type to adequately perform the error check of Means Test
;indicator vs admissions date. This issue should be revisited in 5.4.
;For now, error code 143 (previously set as 744) will not be checked
;in order to be sure that an error is not erroneously generated.
Q
MT ;means test
I DGPTMTC="X "&((+DGPTDTS)'<2860701) S DGPTERC=143 Q
Q:DGPTMTC="X "
I DGPTDTS<2860701 S DGPTERC=143 Q
Q
;
CPMT ;-- mt and c&p checks
I DGPTMTC="N ",DGPTDCP'=8 S DGPTERC=753 Q
I DGPTMTC="AN","24567"'[DGPTDCP S DGPTERC=753 Q
I ((DGPTMTC="B ")!(DGPTMTC="C ")!(DGPTMTC="G ")),"2467"'[DGPTDCP S DGPTERC=753 Q
I DGPTMTC="AS","1234567"'[DGPTDCP S DGPTERC=753 Q
Q
LEG ;legionnaires indicator
;I DGPTDDXE=482.8&("12"'[DGPT70LG) S DGPTERC=731 Q
Q
SUI ;suicide indicator
; -- 850 - aas - hard coded ICD codes
; -- Suicide Category is inactive JUL 1,2006
N DGINACT
I ($E(DGPTDDXE,1,3)="E95")&("12345678"[$E(DGPTDDXE,4))&("12"'[DGPT70SU) D
. I '$D(DGSCDT) D DC
. S DGINACT=$$GET1^DIQ(45.88,"2,",.03,"I")
. I DGINACT]"",$D(DGSCDT) Q:DGSCDT>DGINACT
. S DGPTERC=732 Q
Q
DRUG ;drug/substance abuse
; -- 850 - aas - hard coded ICD codes
; -- Substance Abuse Category is inactive JUL 1,2006
I DGPT70DR'?4" " S DGPTERC=733 ;should be spaces as of DG*5.3*683. 11/13/14
;S DGPTMSX=0
;I ($E(DGPTDDXE,1,4)="304.")&("013456"[$E(DGPTDDXE,5))&("0123"[$E(DGPTDDXE,6)) S DGPTMSX=1
;I ($E(DGPTDDXE,1,4)="305.")&("234579"[$E(DGPTDDXE,5))&("0123"[$E(DGPTDDXE,6)) S DGPTMSX=1
;Q:'DGPTMSX
;N DGINACT
;I $E(DGPT70DR,1)'="A"!($E(DGPT70DR,2,4)<1)!(+$E(DGPT70DR>16)) D
;. I '$D(DGSCDT) D DC
;. S DGINACT=$$GET1^DIQ(45.88,"4,",.03,"I")
;. I DGINACT]"",$D(DGSCDT) Q:DGSCDT>DGINACT
;. S DGPTERC=733
;S DGPTMSX=0
Q
AXIV ;physical sxis class
;this code will not be called when ICD10 is turned on. ft 11/13/14
I $E(DGPTDDXE,1,3)>295,$E(DGPTDDXE,1,3)<320,"0123456"'[DGPT70X4 S DGPTERC=734
Q
AXV1 ;physical axis assessment 1
;this code will not be called when ICD10 is turned on. ft 11/13/14
I (DGPTDXV1<0)!(DGPTDXV1>90) S DGPTERC=735 Q
Q
AXV2 ;physical axis assessment 2
;this code will not be called when ICD10 is turned on. ft 11/13/14
Q:DGPTDXV2=" "
I (DGPTDXV2<0)!(DGPTDXV2>90) S DGPTERC=735 Q
Q
DC ;find discharge date
S DGSCDT=$S('$D(^DGPT(PTF,70)):DT,^(70):+^(70),1:DT)
Q
RACE ;Race
I "1234567X "'[DGPT70RACE S DGPTERC=713
Q
TSC ;treatment for service condition
I "12YN "'[DGPT70TSC S DGPTERC=746
Q
AO ;agent orange
I "YN "'[DGPT70AO S DGPTERC=747
Q
IR ;ionizing radiation
I "YN "'[DGPT70IR S DGPTERC=748
Q
SWA ;southwest asia
I "YN "'[DGPT70SWA S DGPTERC=749
Q
MST ;military sexual trauma
I "YN "'[DGPT70MST S DGPTERC=752
Q
HNC ;head & neck cancer (aka environmental contaminants)
I "YN "'[DGPT70HNC S DGPTERC=754
Q
ETHNIC ;ethnicity
I '$F("^D ^DO^DP^DS^DU^H ^HO^HP^HS^HU^N ^NO^NP^NS^NU^U ^UO^UP^US^UU^ ^",U_DGPT70ETHNIC_U) S DGPTERC=704
Q
RACE16 ;races 1-6
N DGLIST
S DGLIST="^A ^AO^AP^AS^AU^B ^BO^BP^BS^BU^C ^CO^CP^CS^CU^D ^DO^DP^DS^DU^3 ^30^3P^3S^3U^8 ^80^8P^8S^8U^9 ^9O^9P^9S^9U^"
I $F(DGLIST,U_DGPTRACE16_U) S DGPTREC=757+DGLOOP
Q
CV ;combat veteran
I "012YN "'[DGPT70COMVET S DGPTERC=755
Q
SHAD ;shipboard hazard and defense
I "012YN "'[DGPT70SHAD S DGPTERC=756
Q
DXLSPOA ;check dxls poa value
I "1YNUW "'[DGPTDXLSPOA S DGPTERC=720 ; DG*5.3*1057
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTAE02 6558 printed Oct 16, 2024@18:52:05 Page 2
DGPTAE02 ;ALB/MTC,HIOFO/FT - 701 Edit Checks ;3/12/15 1:51pm
+1 ;;5.3;Registration;**8,22,39,114,176,251,247,270,446,418,482,466,683,729,884,1057**;Aug 13, 1993;Build 17
+2 ;10/06/1999 ACS - Added Place of Disposition codes M,Y,Z to the
+3 ;validity checks
+4 ;5/15/2000 ACS - Added Treating Specialty 37 as a valid code
+5 ;5/16/2000 MM - Added Treating Specialties 38 & 39 as valid codes
+6 ;5/26/2000 JRP - Place of Disposition code M valid for station
+7 ; types 10, 11, 30, and 40
+8 ;09/27/2006 JRC - Added Treating Specialties 13, 30, 48, 49, 78,
+9 ; 82 and 97
+10 ;
CHECK ;
+1 IF (DGPTSP1'?1AN)!(DGPTSP2'?1AN)
SET DGPTERC=1
QUIT
+2 IF DGPTSP1="0"&((DGPTSP2'?1AN)!(DGPTSP2="0"))
SET DGPTERC=1
GOTO EXIT
+3 ; No zero or double zeroes allowed
+4 IF DGPTSP1=5
GOTO EXIT
+5 ; All codes 50-59 allowable
+6 ; New code 95:p-418
+7 ; New code 96;p-446
EXIT ;
+1 KILL DGPTSP1,DGPTSP2
+2 QUIT
+3 ;
DISPTY ;
+1 NEW I
+2 SET DGPTERC=0
+3 if "1"[DGPTDTY
QUIT
+4 IF DGPTDTY=2
SET DGPTERC=707
FOR I=10,11,30,40,42
IF DGPTSTTY["^"_I_"^"
SET DGPTERC=0
QUIT
+5 IF DGPTERC
QUIT
+6 ;
+7 ;-- if dis type = To Non-Bed Care then VA aus and Out pat = no
+8 ;I DGPTDTY=2,((DGPTDVA'=2)!(DGPTDOP'=3)) S DGPTERC=707 Q
+9 ;
+10 IF DGPTDTY=3&(DGPTSTTY'["^42^")
SET DGPTERC=707
QUIT
+11 ;-- if dis type = Transfer then Out pat cannot be yes
+12 IF DGPTDTY=5
IF DGPTDOP=1
SET DGPTERC=707
+13 ;-- if dis type = Transfer then Out pat cannot be yes, rec sta'=""
+14 IF DGPTDTY=5
IF DGPTDOP'=1
IF 'DGPTDRF
SET DGPTERC=711
QUIT
+15 ;-- if dis type irr, death w/aotopsy then va asp, op care, pod = ""
+16 IF "467"[DGPTDTY
IF (DGPTDOP!DGPTDVA!DGPTDPD)
SET DGPTERC=707
QUIT
+17 QUIT
OP ;
+1 if "13"'[DGPTDOP
QUIT
+2 SET DGPTERC=708
FOR I=10,11,40,42
IF DGPTSTTY["^"_I_"^"
SET DGPTERC=0
QUIT
+3 QUIT
POD ;place of disposition
+1 NEW I
+2 if "X012347BCDFGHJKL "[DGPTDPD
QUIT
+3 ; if POD NHCU then Out=no VA aus=yes
+4 IF DGPTDPD=5
IF ((DGPTDOP'=3)!(DGPTDVA'=1))
SET DGPTERC=710
QUIT
+5 ; if POD NHCU then Out=no VA aus=yes, rec station'=""
+6 IF DGPTDPD=5
IF DGPTDOP=3
IF DGPTDVA=1
IF 'DGPTDRF
SET DGPTERC=711
QUIT
+7 IF "PR"[DGPTDPD
IF ((DGPTSTTY'["^10^")!(DGPTSTTY'["^11^"))
SET DGPTERC=710
QUIT
+8 IF DGPTDPD="M"
SET DGPTERC=710
FOR I=10,11,30,40
IF DGPTSTTY["^"_I_"^"
SET DGPTERC=0
QUIT
+9 IF DGPTDPD="T"
SET DGPTERC=710
FOR I=10,11,40
IF DGPTSTTY["^"_I_"^"
SET DGPTERC=0
QUIT
+10 IF "UYZ"[DGPTDPD
SET DGPTERC=710
FOR I=10,11,20:1:27,30,40:1:42
IF DGPTSTTY["^"_I_"^"
SET DGPTERC=0
QUIT
+11 QUIT
LEAVE ;
+1 SET DGPTLVDY=0
+2 SET DGPTL3=0
FOR
SET DGPTL3=$ORDER(^TMP("AEDIT",$JOB,"N501",DGPTL3))
if DGPTL3=""
QUIT
SET DGPTLVDY=DGPTLVDY+$EXTRACT(^TMP("AEDIT",$JOB,"N501",DGPTL3),49,51)+$EXTRACT(^TMP("AEDIT",$JOB,"N501",DGPTL3),52,54)
+3 IF (DGPTLVDY+DGPTDAS)>DGPTELP
SET DGPTERC=745
+4 KILL DGPTL3,DGPTLVDY
+5 QUIT
+6 ;
CANDP ;compensation and pension status
+1 IF "12345678"'[DGPTDCP
SET DGPTERC=714
QUIT
+2 ;-- if no POS then no edit
+3 if DGPTPOS2=9
QUIT
+4 ;-- if WWI then no edit
+5 if DGPTPOS2=1
QUIT
+6 ;-- if POW then no edit
+7 IF $LENGTH(DGPTPOW)=1
IF ("23456789AB"[DGPTPOW)
QUIT
+8 DO CONSIS
if DGPTERC
QUIT
+9 DO STATYP
if DGPTERC
QUIT
+10 DO CPMT
if DGPTERC
QUIT
+11 QUIT
CONSIS ;
+1 IF ("01234578X"[DGPTPOS2)&("1234567"'[DGPTDCP)
SET DGPTERC=736
QUIT
+2 IF ("ABCD"[DGPTPOS2)
QUIT
+3 IF DGPTPOS2="Z"&("1234567"'[DGPTDCP)
SET DGPTERC=736
QUIT
+4 if "012345678ABCDXZ"[DGPTPOS2
QUIT
+5 if DGPTDCP'=8
SET DGPTERC=736
+6 QUIT
STATYP ;
+1 if (DGPTSTTY["^30^")!(DGPTSTTY="^")!(DGPTSTTY="")
QUIT
+2 ;Note: There is not sufficient information contained in the
+3 ;station type to adequately perform the error check of Means Test
+4 ;indicator vs admissions date. This issue should be revisited in 5.4.
+5 ;For now, error code 143 (previously set as 744) will not be checked
+6 ;in order to be sure that an error is not erroneously generated.
+7 QUIT
MT ;means test
+1 IF DGPTMTC="X "&((+DGPTDTS)'<2860701)
SET DGPTERC=143
QUIT
+2 if DGPTMTC="X "
QUIT
+3 IF DGPTDTS<2860701
SET DGPTERC=143
QUIT
+4 QUIT
+5 ;
CPMT ;-- mt and c&p checks
+1 IF DGPTMTC="N "
IF DGPTDCP'=8
SET DGPTERC=753
QUIT
+2 IF DGPTMTC="AN"
IF "24567"'[DGPTDCP
SET DGPTERC=753
QUIT
+3 IF ((DGPTMTC="B ")!(DGPTMTC="C ")!(DGPTMTC="G "))
IF "2467"'[DGPTDCP
SET DGPTERC=753
QUIT
+4 IF DGPTMTC="AS"
IF "1234567"'[DGPTDCP
SET DGPTERC=753
QUIT
+5 QUIT
LEG ;legionnaires indicator
+1 ;I DGPTDDXE=482.8&("12"'[DGPT70LG) S DGPTERC=731 Q
+2 QUIT
SUI ;suicide indicator
+1 ; -- 850 - aas - hard coded ICD codes
+2 ; -- Suicide Category is inactive JUL 1,2006
+3 NEW DGINACT
+4 IF ($EXTRACT(DGPTDDXE,1,3)="E95")&("12345678"[$EXTRACT(DGPTDDXE,4))&("12"'[DGPT70SU)
Begin DoDot:1
+5 IF '$DATA(DGSCDT)
DO DC
+6 SET DGINACT=$$GET1^DIQ(45.88,"2,",.03,"I")
+7 IF DGINACT]""
IF $DATA(DGSCDT)
if DGSCDT>DGINACT
QUIT
+8 SET DGPTERC=732
QUIT
End DoDot:1
+9 QUIT
DRUG ;drug/substance abuse
+1 ; -- 850 - aas - hard coded ICD codes
+2 ; -- Substance Abuse Category is inactive JUL 1,2006
+3 ;should be spaces as of DG*5.3*683. 11/13/14
IF DGPT70DR'?4" "
SET DGPTERC=733
+4 ;S DGPTMSX=0
+5 ;I ($E(DGPTDDXE,1,4)="304.")&("013456"[$E(DGPTDDXE,5))&("0123"[$E(DGPTDDXE,6)) S DGPTMSX=1
+6 ;I ($E(DGPTDDXE,1,4)="305.")&("234579"[$E(DGPTDDXE,5))&("0123"[$E(DGPTDDXE,6)) S DGPTMSX=1
+7 ;Q:'DGPTMSX
+8 ;N DGINACT
+9 ;I $E(DGPT70DR,1)'="A"!($E(DGPT70DR,2,4)<1)!(+$E(DGPT70DR>16)) D
+10 ;. I '$D(DGSCDT) D DC
+11 ;. S DGINACT=$$GET1^DIQ(45.88,"4,",.03,"I")
+12 ;. I DGINACT]"",$D(DGSCDT) Q:DGSCDT>DGINACT
+13 ;. S DGPTERC=733
+14 ;S DGPTMSX=0
+15 QUIT
AXIV ;physical sxis class
+1 ;this code will not be called when ICD10 is turned on. ft 11/13/14
+2 IF $EXTRACT(DGPTDDXE,1,3)>295
IF $EXTRACT(DGPTDDXE,1,3)<320
IF "0123456"'[DGPT70X4
SET DGPTERC=734
+3 QUIT
AXV1 ;physical axis assessment 1
+1 ;this code will not be called when ICD10 is turned on. ft 11/13/14
+2 IF (DGPTDXV1<0)!(DGPTDXV1>90)
SET DGPTERC=735
QUIT
+3 QUIT
AXV2 ;physical axis assessment 2
+1 ;this code will not be called when ICD10 is turned on. ft 11/13/14
+2 if DGPTDXV2=" "
QUIT
+3 IF (DGPTDXV2<0)!(DGPTDXV2>90)
SET DGPTERC=735
QUIT
+4 QUIT
DC ;find discharge date
+1 SET DGSCDT=$SELECT('$DATA(^DGPT(PTF,70)):DT,^(70):+^(70),1:DT)
+2 QUIT
RACE ;Race
+1 IF "1234567X "'[DGPT70RACE
SET DGPTERC=713
+2 QUIT
TSC ;treatment for service condition
+1 IF "12YN "'[DGPT70TSC
SET DGPTERC=746
+2 QUIT
AO ;agent orange
+1 IF "YN "'[DGPT70AO
SET DGPTERC=747
+2 QUIT
IR ;ionizing radiation
+1 IF "YN "'[DGPT70IR
SET DGPTERC=748
+2 QUIT
SWA ;southwest asia
+1 IF "YN "'[DGPT70SWA
SET DGPTERC=749
+2 QUIT
MST ;military sexual trauma
+1 IF "YN "'[DGPT70MST
SET DGPTERC=752
+2 QUIT
HNC ;head & neck cancer (aka environmental contaminants)
+1 IF "YN "'[DGPT70HNC
SET DGPTERC=754
+2 QUIT
ETHNIC ;ethnicity
+1 IF '$FIND("^D ^DO^DP^DS^DU^H ^HO^HP^HS^HU^N ^NO^NP^NS^NU^U ^UO^UP^US^UU^ ^",U_DGPT70ETHNIC_U)
SET DGPTERC=704
+2 QUIT
RACE16 ;races 1-6
+1 NEW DGLIST
+2 SET DGLIST="^A ^AO^AP^AS^AU^B ^BO^BP^BS^BU^C ^CO^CP^CS^CU^D ^DO^DP^DS^DU^3 ^30^3P^3S^3U^8 ^80^8P^8S^8U^9 ^9O^9P^9S^9U^"
+3 IF $FIND(DGLIST,U_DGPTRACE16_U)
SET DGPTREC=757+DGLOOP
+4 QUIT
CV ;combat veteran
+1 IF "012YN "'[DGPT70COMVET
SET DGPTERC=755
+2 QUIT
SHAD ;shipboard hazard and defense
+1 IF "012YN "'[DGPT70SHAD
SET DGPTERC=756
+2 QUIT
DXLSPOA ;check dxls poa value
+1 ; DG*5.3*1057
IF "1YNUW "'[DGPTDXLSPOA
SET DGPTERC=720
+2 QUIT
