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

DGPTAE02.m

Go to the documentation of this file.
  1. 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
  1. ;10/06/1999 ACS - Added Place of Disposition codes M,Y,Z to the
  1. ;validity checks
  1. ;5/15/2000 ACS - Added Treating Specialty 37 as a valid code
  1. ;5/16/2000 MM - Added Treating Specialties 38 & 39 as valid codes
  1. ;5/26/2000 JRP - Place of Disposition code M valid for station
  1. ; types 10, 11, 30, and 40
  1. ;09/27/2006 JRC - Added Treating Specialties 13, 30, 48, 49, 78,
  1. ; 82 and 97
  1. ;
  1. CHECK ;
  1. I (DGPTSP1'?1AN)!(DGPTSP2'?1AN) S DGPTERC=1 Q
  1. I DGPTSP1="0"&((DGPTSP2'?1AN)!(DGPTSP2="0")) S DGPTERC=1 G EXIT
  1. ; No zero or double zeroes allowed
  1. I DGPTSP1=5 G EXIT
  1. ; All codes 50-59 allowable
  1. ; New code 95:p-418
  1. ; New code 96;p-446
  1. EXIT ;
  1. K DGPTSP1,DGPTSP2
  1. Q
  1. ;
  1. DISPTY ;
  1. N I
  1. S DGPTERC=0
  1. Q:"1"[DGPTDTY
  1. I DGPTDTY=2 S DGPTERC=707 F I=10,11,30,40,42 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
  1. I DGPTERC Q
  1. ;
  1. ;-- if dis type = To Non-Bed Care then VA aus and Out pat = no
  1. ;I DGPTDTY=2,((DGPTDVA'=2)!(DGPTDOP'=3)) S DGPTERC=707 Q
  1. ;
  1. I DGPTDTY=3&(DGPTSTTY'["^42^") S DGPTERC=707 Q
  1. ;-- if dis type = Transfer then Out pat cannot be yes
  1. I DGPTDTY=5,DGPTDOP=1 S DGPTERC=707
  1. ;-- if dis type = Transfer then Out pat cannot be yes, rec sta'=""
  1. I DGPTDTY=5,DGPTDOP'=1,'DGPTDRF S DGPTERC=711 Q
  1. ;-- if dis type irr, death w/aotopsy then va asp, op care, pod = ""
  1. I "467"[DGPTDTY,(DGPTDOP!DGPTDVA!DGPTDPD) S DGPTERC=707 Q
  1. Q
  1. OP ;
  1. Q:"13"'[DGPTDOP
  1. S DGPTERC=708 F I=10,11,40,42 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
  1. Q
  1. POD ;place of disposition
  1. N I
  1. Q:"X012347BCDFGHJKL "[DGPTDPD
  1. ; if POD NHCU then Out=no VA aus=yes
  1. I DGPTDPD=5,((DGPTDOP'=3)!(DGPTDVA'=1)) S DGPTERC=710 Q
  1. ; if POD NHCU then Out=no VA aus=yes, rec station'=""
  1. I DGPTDPD=5,DGPTDOP=3,DGPTDVA=1,'DGPTDRF S DGPTERC=711 Q
  1. I "PR"[DGPTDPD,((DGPTSTTY'["^10^")!(DGPTSTTY'["^11^")) S DGPTERC=710 Q
  1. I DGPTDPD="M" S DGPTERC=710 F I=10,11,30,40 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
  1. I DGPTDPD="T" S DGPTERC=710 F I=10,11,40 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
  1. I "UYZ"[DGPTDPD S DGPTERC=710 F I=10,11,20:1:27,30,40:1:42 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
  1. Q
  1. LEAVE ;
  1. S DGPTLVDY=0
  1. 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)
  1. I (DGPTLVDY+DGPTDAS)>DGPTELP S DGPTERC=745
  1. K DGPTL3,DGPTLVDY
  1. Q
  1. ;
  1. CANDP ;compensation and pension status
  1. I "12345678"'[DGPTDCP S DGPTERC=714 Q
  1. ;-- if no POS then no edit
  1. Q:DGPTPOS2=9
  1. ;-- if WWI then no edit
  1. Q:DGPTPOS2=1
  1. ;-- if POW then no edit
  1. I $L(DGPTPOW)=1,("23456789AB"[DGPTPOW) Q
  1. D CONSIS Q:DGPTERC
  1. D STATYP Q:DGPTERC
  1. D CPMT Q:DGPTERC
  1. Q
  1. CONSIS ;
  1. I ("01234578X"[DGPTPOS2)&("1234567"'[DGPTDCP) S DGPTERC=736 Q
  1. I ("ABCD"[DGPTPOS2) Q
  1. I DGPTPOS2="Z"&("1234567"'[DGPTDCP) S DGPTERC=736 Q
  1. Q:"012345678ABCDXZ"[DGPTPOS2
  1. S:DGPTDCP'=8 DGPTERC=736
  1. Q
  1. STATYP ;
  1. Q:(DGPTSTTY["^30^")!(DGPTSTTY="^")!(DGPTSTTY="")
  1. ;Note: There is not sufficient information contained in the
  1. ;station type to adequately perform the error check of Means Test
  1. ;indicator vs admissions date. This issue should be revisited in 5.4.
  1. ;For now, error code 143 (previously set as 744) will not be checked
  1. ;in order to be sure that an error is not erroneously generated.
  1. Q
  1. MT ;means test
  1. I DGPTMTC="X "&((+DGPTDTS)'<2860701) S DGPTERC=143 Q
  1. Q:DGPTMTC="X "
  1. I DGPTDTS<2860701 S DGPTERC=143 Q
  1. Q
  1. ;
  1. CPMT ;-- mt and c&p checks
  1. I DGPTMTC="N ",DGPTDCP'=8 S DGPTERC=753 Q
  1. I DGPTMTC="AN","24567"'[DGPTDCP S DGPTERC=753 Q
  1. I ((DGPTMTC="B ")!(DGPTMTC="C ")!(DGPTMTC="G ")),"2467"'[DGPTDCP S DGPTERC=753 Q
  1. I DGPTMTC="AS","1234567"'[DGPTDCP S DGPTERC=753 Q
  1. Q
  1. LEG ;legionnaires indicator
  1. ;I DGPTDDXE=482.8&("12"'[DGPT70LG) S DGPTERC=731 Q
  1. Q
  1. SUI ;suicide indicator
  1. ; -- 850 - aas - hard coded ICD codes
  1. ; -- Suicide Category is inactive JUL 1,2006
  1. N DGINACT
  1. I ($E(DGPTDDXE,1,3)="E95")&("12345678"[$E(DGPTDDXE,4))&("12"'[DGPT70SU) D
  1. . I '$D(DGSCDT) D DC
  1. . S DGINACT=$$GET1^DIQ(45.88,"2,",.03,"I")
  1. . I DGINACT]"",$D(DGSCDT) Q:DGSCDT>DGINACT
  1. . S DGPTERC=732 Q
  1. Q
  1. DRUG ;drug/substance abuse
  1. ; -- 850 - aas - hard coded ICD codes
  1. ; -- Substance Abuse Category is inactive JUL 1,2006
  1. I DGPT70DR'?4" " S DGPTERC=733 ;should be spaces as of DG*5.3*683. 11/13/14
  1. ;S DGPTMSX=0
  1. ;I ($E(DGPTDDXE,1,4)="304.")&("013456"[$E(DGPTDDXE,5))&("0123"[$E(DGPTDDXE,6)) S DGPTMSX=1
  1. ;I ($E(DGPTDDXE,1,4)="305.")&("234579"[$E(DGPTDDXE,5))&("0123"[$E(DGPTDDXE,6)) S DGPTMSX=1
  1. ;Q:'DGPTMSX
  1. ;N DGINACT
  1. ;I $E(DGPT70DR,1)'="A"!($E(DGPT70DR,2,4)<1)!(+$E(DGPT70DR>16)) D
  1. ;. I '$D(DGSCDT) D DC
  1. ;. S DGINACT=$$GET1^DIQ(45.88,"4,",.03,"I")
  1. ;. I DGINACT]"",$D(DGSCDT) Q:DGSCDT>DGINACT
  1. ;. S DGPTERC=733
  1. ;S DGPTMSX=0
  1. Q
  1. AXIV ;physical sxis class
  1. ;this code will not be called when ICD10 is turned on. ft 11/13/14
  1. I $E(DGPTDDXE,1,3)>295,$E(DGPTDDXE,1,3)<320,"0123456"'[DGPT70X4 S DGPTERC=734
  1. Q
  1. AXV1 ;physical axis assessment 1
  1. ;this code will not be called when ICD10 is turned on. ft 11/13/14
  1. I (DGPTDXV1<0)!(DGPTDXV1>90) S DGPTERC=735 Q
  1. Q
  1. AXV2 ;physical axis assessment 2
  1. ;this code will not be called when ICD10 is turned on. ft 11/13/14
  1. Q:DGPTDXV2=" "
  1. I (DGPTDXV2<0)!(DGPTDXV2>90) S DGPTERC=735 Q
  1. Q
  1. DC ;find discharge date
  1. S DGSCDT=$S('$D(^DGPT(PTF,70)):DT,^(70):+^(70),1:DT)
  1. Q
  1. RACE ;Race
  1. I "1234567X "'[DGPT70RACE S DGPTERC=713
  1. Q
  1. TSC ;treatment for service condition
  1. I "12YN "'[DGPT70TSC S DGPTERC=746
  1. Q
  1. AO ;agent orange
  1. I "YN "'[DGPT70AO S DGPTERC=747
  1. Q
  1. IR ;ionizing radiation
  1. I "YN "'[DGPT70IR S DGPTERC=748
  1. Q
  1. SWA ;southwest asia
  1. I "YN "'[DGPT70SWA S DGPTERC=749
  1. Q
  1. MST ;military sexual trauma
  1. I "YN "'[DGPT70MST S DGPTERC=752
  1. Q
  1. HNC ;head & neck cancer (aka environmental contaminants)
  1. I "YN "'[DGPT70HNC S DGPTERC=754
  1. Q
  1. ETHNIC ;ethnicity
  1. 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
  1. Q
  1. RACE16 ;races 1-6
  1. N DGLIST
  1. 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^"
  1. I $F(DGLIST,U_DGPTRACE16_U) S DGPTREC=757+DGLOOP
  1. Q
  1. CV ;combat veteran
  1. I "012YN "'[DGPT70COMVET S DGPTERC=755
  1. Q
  1. SHAD ;shipboard hazard and defense
  1. I "012YN "'[DGPT70SHAD S DGPTERC=756
  1. Q
  1. DXLSPOA ;check dxls poa value
  1. I "1YNUW "'[DGPTDXLSPOA S DGPTERC=720 ; DG*5.3*1057
  1. Q