DGPT50DI ;ALB/MTC/ADL,HIOFO/FT - Edit diagnoses-Check ICD DIAGNOSES, current, gender correct ;2/20/15 12:19pm
;;5.3;Registration;**510,850,884,1057**;Aug 13, 1993;Build 17
;;ADL;Updated for CSV project;;Mar 24, 2003
;
; ICDEX APIs - #5747
; ICDXCODE APIs - #5699
;
EN ;
I DGPTFMT=2 F I=1:1:5 S DGPTDIB=$P(@("DGPTMD"_I)," ",1) S DGPTERC=0 D DIAG(I) I DGPTERC D ERR G:DGPTEDFL EXIT
I DGPTFMT=3 F I=1:1:25 S DGPTDIB=$P(@("DGPTMD"_I)," ",1),DGPTPOAI=@("DGPTMPOA"_I) D I DGPTERC D ERR G:DGPTEDFL EXIT
.I DGPTDIB="",DGPTPOAI'=" " S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) D ERR ;should not have a poa if the dx is null. using invalid dx error code
.I "1YNUW "'[DGPTPOAI S DGPTREC=$S(I<6:509+I,I<20:510+I,1:538+I) D ERR ; 1,Y,N,U,W or space only DG*5.3*1057
.S DGPTERC=0 D DIAG(I)
D EXIT
Q
DIAG(I) ;
Q:DGPTDIB=""
N SYS,EFFDATE,IMPDATE,DGPTDAT
D EFFDATE^DGPTIC10($G(PTF))
S SYS=$$SYS^ICDEX("DIAG",EFFDATE)
I SYS=1 I $E(DGPTDIB,1)="E" S DGPTERC=0 D DIAGE Q
I SYS=1 I $E(DGPTDIB,1)="V" S DGPTERC=0 D DIAGV Q
S DGPTDIB1=$E(DGPTDIB_" ",1,3)_"."_$E(DGPTDIB_" ",4,7)_" "
I +$$CODEN^ICDEX(DGPTDIB1,80)>0 S DGPTERC=0 D GEN(I) Q
Q
ERR ;
D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
Q
EXIT ;
K DGPTDIB,DGPTDIB1,DGPTDIB2,I,DGPTPOAI
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 SYS,EFFDATE,IMPDATE,DGPTDAT
D EFFDATE^DGPTIC10($G(PTF))
Q:$E(DGPTDIB)'="E"
I I=1 S DGPTERC=550 Q
S DGPTDIB1=$E(DGPTDIB,1,4)_"."_$E(DGPTDIB,5,$L(DGPTDIB))_" "
S X=+$$CODEN^ICDEX(DGPTDIB1,80) I X<1 S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",X,EFFDATE)
I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
;I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=791+I Q ;ft 12/1/14 791 didn't exist before patch 884
S @("DGPTMD"_I)=$P(DGPTDIB1," ",1)
Q
DIAGV ; DIAG CODES = "V##.0-2# "
;Supplementary Classification of External Causes of Inquiry and Poisoning
N SYS,EFFDATE,IMPDATE,DGPTDAT
D EFFDATE^DGPTIC10($G(PTF))
Q:$E(DGPTDIB)'="V"
S DGPTDIB1=$E(DGPTDIB,1,3)_"."_$E(DGPTDIB,4,$L(DGPTDIB))_" "
I +$$CODEN^ICDEX(DGPTDIB1,80)<1 S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
S X=+$$CODEN^ICDEX(DGPTDIB1,80) I X<1 S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",X,EFFDATE) ;use date of movement if defined, else today
I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
S @("DGPTMD"_I)=$P(DGPTDIB1," ",1)
Q
GEN(I) ;gender check - 884 no longer flags a gender error
N SYS,EFFDATE,IMPDATE,DGPTDAT
D EFFDATE^DGPTIC10($G(PTF))
S DGPTDIB2=+$$CODEN^ICDEX(DGPTDIB1,80) I DGPTDIB2<1 S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGPTDIB2,EFFDATE)
I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=$S(I<6:509+I,I<20:510+I,1:538+I) Q
;I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=551 Q
S @("DGPTMD"_I)=$P(DGPTDIB1," ",1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPT50DI 3432 printed Apr 09, 2024@21:59:24 Page 2
DGPT50DI ;ALB/MTC/ADL,HIOFO/FT - Edit diagnoses-Check ICD DIAGNOSES, current, gender correct ;2/20/15 12:19pm
+1 ;;5.3;Registration;**510,850,884,1057**;Aug 13, 1993;Build 17
+2 ;;ADL;Updated for CSV project;;Mar 24, 2003
+3 ;
+4 ; ICDEX APIs - #5747
+5 ; ICDXCODE APIs - #5699
+6 ;
EN ;
+1 IF DGPTFMT=2
FOR I=1:1:5
SET DGPTDIB=$PIECE(@("DGPTMD"_I)," ",1)
SET DGPTERC=0
DO DIAG(I)
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+2 IF DGPTFMT=3
FOR I=1:1:25
SET DGPTDIB=$PIECE(@("DGPTMD"_I)," ",1)
SET DGPTPOAI=@("DGPTMPOA"_I)
Begin DoDot:1
+3 ;should not have a poa if the dx is null. using invalid dx error code
IF DGPTDIB=""
IF DGPTPOAI'=" "
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
DO ERR
+4 ; 1,Y,N,U,W or space only DG*5.3*1057
IF "1YNUW "'[DGPTPOAI
SET DGPTREC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
DO ERR
+5 SET DGPTERC=0
DO DIAG(I)
End DoDot:1
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+6 DO EXIT
+7 QUIT
DIAG(I) ;
+1 if DGPTDIB=""
QUIT
+2 NEW SYS,EFFDATE,IMPDATE,DGPTDAT
+3 DO EFFDATE^DGPTIC10($GET(PTF))
+4 SET SYS=$$SYS^ICDEX("DIAG",EFFDATE)
+5 IF SYS=1
IF $EXTRACT(DGPTDIB,1)="E"
SET DGPTERC=0
DO DIAGE
QUIT
+6 IF SYS=1
IF $EXTRACT(DGPTDIB,1)="V"
SET DGPTERC=0
DO DIAGV
QUIT
+7 SET DGPTDIB1=$EXTRACT(DGPTDIB_" ",1,3)_"."_$EXTRACT(DGPTDIB_" ",4,7)_" "
+8 IF +$$CODEN^ICDEX(DGPTDIB1,80)>0
SET DGPTERC=0
DO GEN(I)
QUIT
+9 QUIT
ERR ;
+1 DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
+2 QUIT
EXIT ;
+1 KILL DGPTDIB,DGPTDIB1,DGPTDIB2,I,DGPTPOAI
+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 SYS,EFFDATE,IMPDATE,DGPTDAT
+3 DO EFFDATE^DGPTIC10($GET(PTF))
+4 if $EXTRACT(DGPTDIB)'="E"
QUIT
+5 IF I=1
SET DGPTERC=550
QUIT
+6 SET DGPTDIB1=$EXTRACT(DGPTDIB,1,4)_"."_$EXTRACT(DGPTDIB,5,$LENGTH(DGPTDIB))_" "
+7 SET X=+$$CODEN^ICDEX(DGPTDIB1,80)
IF X<1
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+8 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",X,EFFDATE)
+9 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+10 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTMDTS,1,7)>$PIECE(DGPTTMP,U,12))
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+11 ;I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=791+I Q ;ft 12/1/14 791 didn't exist before patch 884
+12 SET @("DGPTMD"_I)=$PIECE(DGPTDIB1," ",1)
+13 QUIT
DIAGV ; DIAG CODES = "V##.0-2# "
+1 ;Supplementary Classification of External Causes of Inquiry and Poisoning
+2 NEW SYS,EFFDATE,IMPDATE,DGPTDAT
+3 DO EFFDATE^DGPTIC10($GET(PTF))
+4 if $EXTRACT(DGPTDIB)'="V"
QUIT
+5 SET DGPTDIB1=$EXTRACT(DGPTDIB,1,3)_"."_$EXTRACT(DGPTDIB,4,$LENGTH(DGPTDIB))_" "
+6 IF +$$CODEN^ICDEX(DGPTDIB1,80)<1
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+7 SET X=+$$CODEN^ICDEX(DGPTDIB1,80)
IF X<1
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+8 ;use date of movement if defined, else today
SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",X,EFFDATE)
+9 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+10 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTMDTS,1,7)>$PIECE(DGPTTMP,U,12))
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+11 IF ($PIECE(DGPTTMP,U,11)]"")&(DGPTGEN'=$PIECE(DGPTTMP,U,11))
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+12 SET @("DGPTMD"_I)=$PIECE(DGPTDIB1," ",1)
+13 QUIT
GEN(I) ;gender check - 884 no longer flags a gender error
+1 NEW SYS,EFFDATE,IMPDATE,DGPTDAT
+2 DO EFFDATE^DGPTIC10($GET(PTF))
+3 SET DGPTDIB2=+$$CODEN^ICDEX(DGPTDIB1,80)
IF DGPTDIB2<1
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+4 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGPTDIB2,EFFDATE)
+5 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
SET DGPTERC=$SELECT(I<6:509+I,I<20:510+I,1:538+I)
QUIT
+6 ;I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=551 Q
+7 SET @("DGPTMD"_I)=$PIECE(DGPTDIB1," ",1)
+8 QUIT
