source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPT50DI.m@ 1607

DGPT50DI ;ALB/MTC/ADL - Edit diagnoses.Check ICD DIAGNOSES, current, gender correct ; 16 NOV 92
 ;;5.3;Registration;**510**;Aug 13, 1993
 ;;ADL;Updated for CSV project;;Mar 24, 2003
 ;
EN ;
 F I=1:1:5 S DGPTDIB=$P(@("DGPTMD"_I)," ",1) S DGPTERC=0 D DIAG(I) I DGPTERC D ERR G:DGPTEDFL EXIT
 D EXIT
 Q
DIAG(I) ;
 Q:DGPTDIB=""
 I $E(DGPTDIB,1)="E" S DGPTERC=0 D DIAGE Q
 I $E(DGPTDIB,1)="V" S DGPTERC=0 D DIAGV Q
 S DGPTDIB1=$E(DGPTDIB_"     ",1,3)_"."_$E(DGPTDIB_"     ",4,5)_" "
 I $D(^ICD9("AB",DGPTDIB1)) S DGPTERC=0 D GEN(I) Q
 Q
ERR ;
 D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
 Q
EXIT ;
 K DGPTDIB,DGPTDIB1,DGPTDIB2,I
 Q
DIAGE ;
 Q:$E(DGPTDIB)'="E"
 I I=1 S DGPTERC=550 Q
 S DGPTDIB1=$E(DGPTDIB,1,4)_"."_$E(DGPTDIB,5,$L(DGPTDIB))_" "
 I '$D(^ICD9("AB",DGPTDIB1)) S DGPTERC=509+I Q
 S X=$O(^ICD9("AB",DGPTDIB1,0)) I X="" S DGPTERC=509+I Q
 S DGPTTMP=$$ICDDX^ICDCODE(X,$S($G(DGPTMDTS)'="":DGPTMDTS,1:DT))  ;use date of movement if defined, else today
 I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q
 I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=509+I Q
 I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=791+I Q
 S @("DGPTMD"_I)=$P(DGPTDIB1," ",1)
 Q
DIAGV ; DIAG CODES = "V##.0-2# "
 Q:$E(DGPTDIB)'="V"
 S DGPTDIB1=$E(DGPTDIB,1,3)_"."_$E(DGPTDIB,4,$L(DGPTDIB))_" "
 I '$D(^ICD9("AB",DGPTDIB1)) S DGPTERC=509+I Q
 S X=$O(^ICD9("AB",DGPTDIB1,0)) I X="" S DGPTERC=509+I Q
 S DGPTTMP=$$ICDDX^ICDCODE(X,$S($G(DGPTMDTS)'="":DGPTMDTS,1:DT))  ;use date of movement if defined, else today
 I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q
 I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=509+I Q
 I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=509+I Q
 S @("DGPTMD"_I)=$P(DGPTDIB1," ",1)
 Q
GEN(I) ;
 S DGPTDIB2=$O(^ICD9("AB",DGPTDIB1,0)) I DGPTDIB2="" S DGPTERC=509+I Q
 S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIB2,$S($G(DGPTMDTS)'="":DGPTMDTS,1:DT))  ;use date of movement if defined, else today
 I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q
 I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=551 Q
 S @("DGPTMD"_I)=$P(DGPTDIB1," ",1)
 Q