DGPT70DI ;ALB/MTC/ADL,HIOFO/FT - Diagnosis edits for 700's - E codes, V codes, gender and ICD9 Diag. ;2/20/15 12:20pm
;;5.3;Registration;**510,850,884,1057**;Aug 13, 1993;Build 17
;;ADL;Update for CSV Project;;Mar. 24, 2003
;
; ICDEX APIs - #5747
; ICDXCODE APIs - #5699
;
EN ;called from DGPT702
I DGPTFMT=2 F DGPTL3=1:1:9 S DGPTDIA=$P((@("DGPTGD"_DGPTL3))," ",1) S DGPTERC=0 D DIAG I DGPTERC D ERR G:DGPTEDFL EXIT
I DGPTFMT=3 F DGPTL3=2:1:25 S DGPTDIA=$P((@("DGPTGD"_DGPTL3))," ",1),DGPTPOA=@("DGPTPOA"_DGPTL3),DGPTERC=0 D I DGPTERC D ERR G:DGPTEDFL EXIT
. Q:(DGPTDIA="")!(DGPTPOA="")
. I DGPTDIA="",DGPTPOA'=" " S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) ;POA without a DX. using invalid dx error code
. Q:DGPTDIA=""
. I "1YNUW "'[DGPTPOA S DGPTREC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) D ERR ; DG*5.3*1057
. S DGPTERC=0 D DIAG
Q
;
DIAG ;
N SYS,EFFDATE,IMPDATE,DGPTDAT,SYS
D EFFDATE^DGPTIC10($G(PTF))
S SYS=$$SYS^ICDEX("DIAG",EFFDATE)
Q:DGPTDIA=""
I SYS=1 I $E(DGPTDIA,1)="E" S DGPTERC=0 D DIAGE Q
I SYS=1 I $E(DGPTDIA,1)="V" S DGPTERC=0 D DIAGV Q
S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
F DGPTL4=1:1:$L(DGPTDIA) S DGPTDIA1=$E(DGPTDIA,1,DGPTL4)_"."_$E(DGPTDIA,DGPTL4+1,$L(DGPTDIA))_" " I +$$CODEN^ICDEX(DGPTDIA1,80)>0 S DGPTERC=0 D GEN Q
Q
ERR ;
D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
Q
EXIT ;
K DGPTDIA,DGPTDIA1,DGPTDIA2,DGPTL3,DGPTL4,DGPTPOA
Q
;note: E and V codes were eliminated in ICD-10 and incorporated into the main code set.
DIAGE ; Supplementary Classification of Factors Influencing Health Status
; and Contact with Health Services.
N EFFDATE,IMPDATE,DGPTDAT,SYS
D EFFDATE^DGPTIC10($G(PTF))
Q:$E(DGPTDIA)'="E"
S SYS=$$SYS^ICDEX("DIAG",EFFDATE)
S:SYS=30 DGPTDIA1=$E(DGPTDIA,1,3)_"."_$E(DGPTDIA,4,$L(DGPTDIA))_" " ;will it ever be 30 (i.e, ICD10)?
S:SYS=1 DGPTDIA1=$E(DGPTDIA,1,4)_"."_$E(DGPTDIA,5,$L(DGPTDIA))_" "
I +$$CODEN^ICDEX(DGPTDIA1,80)<1 S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
S DGPTDIA2=+$$CODEN^ICDEX(DGPTDIA1,80) I DGPTDIA2<1 S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGPTDIA2,EFFDATE)
I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
S @("DGPTGD"_DGPTL3)=$P(DGPTDIA1," ",1)
S DGPTDIAR(DGPTDDS)=$S($D(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
Q
DIAGV ; Supplementary Classification of External Causes of Inquiry and Poisoning
N EFFDATE,IMPDATE,DGPTDAT
D EFFDATE^DGPTIC10($G(PTF))
Q:$E(DGPTDIA)'="V"
S DGPTDIA1=$E(DGPTDIA,1,3)_"."_$E(DGPTDIA,4,$L(DGPTDIA))_" "
I +$$CODEN^ICDEX(DGPTDIA1,80)<1 S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
S DGPTDIA2=+$$CODEN^ICDEX(DGPTDIA1,80) I DGPTDIA2<1 S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGPTDIA2,EFFDATE) ;use date of disp. if defined, else today
I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
S @("DGPTGD"_DGPTL3)=$P(DGPTDIA1," ",1)
S DGPTDIAR(DGPTDDS)=$S($D(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
Q
GEN ;gender - 884 no longer flags a gender error
N EFFDATE,IMPDATE,DGPTDAT
D EFFDATE^DGPTIC10($G(PTF))
S DGPTDIA2=+$$CODEN^ICDEX(DGPTDIA1,80) I DGPTDIA2<1 S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGPTDIA2,EFFDATE) ;use date of disp. if defined, else today
I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=$S(DGPTL3<10:719+DGPTL3,1:787+DGPTL3) Q
;I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=751 Q
S @("DGPTGD"_DGPTL3)=$P(DGPTDIA1," ",1)
ARRAY ;this array is used to build the error display in the List Manager interface
S DGPTDIAR(DGPTDDS)=$S($D(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPT70DI 4219 printed Sep 23, 2025@20:27:20 Page 2
DGPT70DI ;ALB/MTC/ADL,HIOFO/FT - Diagnosis edits for 700's - E codes, V codes, gender and ICD9 Diag. ;2/20/15 12:20pm
+1 ;;5.3;Registration;**510,850,884,1057**;Aug 13, 1993;Build 17
+2 ;;ADL;Update for CSV Project;;Mar. 24, 2003
+3 ;
+4 ; ICDEX APIs - #5747
+5 ; ICDXCODE APIs - #5699
+6 ;
EN ;called from DGPT702
+1 IF DGPTFMT=2
FOR DGPTL3=1:1:9
SET DGPTDIA=$PIECE((@("DGPTGD"_DGPTL3))," ",1)
SET DGPTERC=0
DO DIAG
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+2 IF DGPTFMT=3
FOR DGPTL3=2:1:25
SET DGPTDIA=$PIECE((@("DGPTGD"_DGPTL3))," ",1)
SET DGPTPOA=@("DGPTPOA"_DGPTL3)
SET DGPTERC=0
Begin DoDot:1
+3 if (DGPTDIA="")!(DGPTPOA="")
QUIT
+4 ;POA without a DX. using invalid dx error code
IF DGPTDIA=""
IF DGPTPOA'=" "
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
+5 if DGPTDIA=""
QUIT
+6 ; DG*5.3*1057
IF "1YNUW "'[DGPTPOA
SET DGPTREC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
DO ERR
+7 SET DGPTERC=0
DO DIAG
End DoDot:1
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+8 QUIT
+9 ;
DIAG ;
+1 NEW SYS,EFFDATE,IMPDATE,DGPTDAT,SYS
+2 DO EFFDATE^DGPTIC10($GET(PTF))
+3 SET SYS=$$SYS^ICDEX("DIAG",EFFDATE)
+4 if DGPTDIA=""
QUIT
+5 IF SYS=1
IF $EXTRACT(DGPTDIA,1)="E"
SET DGPTERC=0
DO DIAGE
QUIT
+6 IF SYS=1
IF $EXTRACT(DGPTDIA,1)="V"
SET DGPTERC=0
DO DIAGV
QUIT
+7 SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
+8 FOR DGPTL4=1:1:$LENGTH(DGPTDIA)
SET DGPTDIA1=$EXTRACT(DGPTDIA,1,DGPTL4)_"."_$EXTRACT(DGPTDIA,DGPTL4+1,$LENGTH(DGPTDIA))_" "
IF +$$CODEN^ICDEX(DGPTDIA1,80)>0
SET DGPTERC=0
DO GEN
QUIT
+9 QUIT
ERR ;
+1 DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
+2 QUIT
EXIT ;
+1 KILL DGPTDIA,DGPTDIA1,DGPTDIA2,DGPTL3,DGPTL4,DGPTPOA
+2 QUIT
+3 ;note: E and V codes were eliminated in ICD-10 and incorporated into the main code set.
DIAGE ; Supplementary Classification of Factors Influencing Health Status
+1 ; and Contact with Health Services.
+2 NEW EFFDATE,IMPDATE,DGPTDAT,SYS
+3 DO EFFDATE^DGPTIC10($GET(PTF))
+4 if $EXTRACT(DGPTDIA)'="E"
QUIT
+5 SET SYS=$$SYS^ICDEX("DIAG",EFFDATE)
+6 ;will it ever be 30 (i.e, ICD10)?
if SYS=30
SET DGPTDIA1=$EXTRACT(DGPTDIA,1,3)_"."_$EXTRACT(DGPTDIA,4,$LENGTH(DGPTDIA))_" "
+7 if SYS=1
SET DGPTDIA1=$EXTRACT(DGPTDIA,1,4)_"."_$EXTRACT(DGPTDIA,5,$LENGTH(DGPTDIA))_" "
+8 IF +$$CODEN^ICDEX(DGPTDIA1,80)<1
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+9 SET DGPTDIA2=+$$CODEN^ICDEX(DGPTDIA1,80)
IF DGPTDIA2<1
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+10 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGPTDIA2,EFFDATE)
+11 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+12 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTDDS,1,7)>$PIECE(DGPTTMP,U,12))
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+13 IF ($PIECE(DGPTTMP,U,11)]"")&(DGPTGEN'=$PIECE(DGPTTMP,U,11))
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+14 SET @("DGPTGD"_DGPTL3)=$PIECE(DGPTDIA1," ",1)
+15 SET DGPTDIAR(DGPTDDS)=$SELECT($DATA(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
+16 QUIT
DIAGV ; Supplementary Classification of External Causes of Inquiry and Poisoning
+1 NEW EFFDATE,IMPDATE,DGPTDAT
+2 DO EFFDATE^DGPTIC10($GET(PTF))
+3 if $EXTRACT(DGPTDIA)'="V"
QUIT
+4 SET DGPTDIA1=$EXTRACT(DGPTDIA,1,3)_"."_$EXTRACT(DGPTDIA,4,$LENGTH(DGPTDIA))_" "
+5 IF +$$CODEN^ICDEX(DGPTDIA1,80)<1
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+6 SET DGPTDIA2=+$$CODEN^ICDEX(DGPTDIA1,80)
IF DGPTDIA2<1
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+7 ;use date of disp. if defined, else today
SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGPTDIA2,EFFDATE)
+8 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+9 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTDDS,1,7)>$PIECE(DGPTTMP,U,12))
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+10 IF ($PIECE(DGPTTMP,U,11)]"")&(DGPTGEN'=$PIECE(DGPTTMP,U,11))
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+11 SET @("DGPTGD"_DGPTL3)=$PIECE(DGPTDIA1," ",1)
+12 SET DGPTDIAR(DGPTDDS)=$SELECT($DATA(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
+13 QUIT
GEN ;gender - 884 no longer flags a gender error
+1 NEW EFFDATE,IMPDATE,DGPTDAT
+2 DO EFFDATE^DGPTIC10($GET(PTF))
+3 SET DGPTDIA2=+$$CODEN^ICDEX(DGPTDIA1,80)
IF DGPTDIA2<1
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+4 ;use date of disp. if defined, else today
SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGPTDIA2,EFFDATE)
+5 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
SET DGPTERC=$SELECT(DGPTL3<10:719+DGPTL3,1:787+DGPTL3)
QUIT
+6 ;I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=751 Q
+7 SET @("DGPTGD"_DGPTL3)=$PIECE(DGPTDIA1," ",1)
ARRAY ;this array is used to build the error display in the List Manager interface
+1 SET DGPTDIAR(DGPTDDS)=$SELECT($DATA(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
+2 QUIT
