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

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.1 KB
Line 
1DGPT50DI ;ALB/MTC/ADL - Edit diagnoses.Check ICD DIAGNOSES, current, gender correct ; 16 NOV 92
2 ;;5.3;Registration;**510**;Aug 13, 1993
3 ;;ADL;Updated for CSV project;;Mar 24, 2003
4 ;
5EN ;
6 F I=1:1:5 S DGPTDIB=$P(@("DGPTMD"_I)," ",1) S DGPTERC=0 D DIAG(I) I DGPTERC D ERR G:DGPTEDFL EXIT
7 D EXIT
8 Q
9DIAG(I) ;
10 Q:DGPTDIB=""
11 I $E(DGPTDIB,1)="E" S DGPTERC=0 D DIAGE Q
12 I $E(DGPTDIB,1)="V" S DGPTERC=0 D DIAGV Q
13 S DGPTDIB1=$E(DGPTDIB_" ",1,3)_"."_$E(DGPTDIB_" ",4,5)_" "
14 I $D(^ICD9("AB",DGPTDIB1)) S DGPTERC=0 D GEN(I) Q
15 Q
16ERR ;
17 D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
18 Q
19EXIT ;
20 K DGPTDIB,DGPTDIB1,DGPTDIB2,I
21 Q
22DIAGE ;
23 Q:$E(DGPTDIB)'="E"
24 I I=1 S DGPTERC=550 Q
25 S DGPTDIB1=$E(DGPTDIB,1,4)_"."_$E(DGPTDIB,5,$L(DGPTDIB))_" "
26 I '$D(^ICD9("AB",DGPTDIB1)) S DGPTERC=509+I Q
27 S X=$O(^ICD9("AB",DGPTDIB1,0)) I X="" S DGPTERC=509+I Q
28 S DGPTTMP=$$ICDDX^ICDCODE(X,$S($G(DGPTMDTS)'="":DGPTMDTS,1:DT)) ;use date of movement if defined, else today
29 I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q
30 I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=509+I Q
31 I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=791+I Q
32 S @("DGPTMD"_I)=$P(DGPTDIB1," ",1)
33 Q
34DIAGV ; DIAG CODES = "V##.0-2# "
35 Q:$E(DGPTDIB)'="V"
36 S DGPTDIB1=$E(DGPTDIB,1,3)_"."_$E(DGPTDIB,4,$L(DGPTDIB))_" "
37 I '$D(^ICD9("AB",DGPTDIB1)) S DGPTERC=509+I Q
38 S X=$O(^ICD9("AB",DGPTDIB1,0)) I X="" S DGPTERC=509+I Q
39 S DGPTTMP=$$ICDDX^ICDCODE(X,$S($G(DGPTMDTS)'="":DGPTMDTS,1:DT)) ;use date of movement if defined, else today
40 I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q
41 I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=509+I Q
42 I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=509+I Q
43 S @("DGPTMD"_I)=$P(DGPTDIB1," ",1)
44 Q
45GEN(I) ;
46 S DGPTDIB2=$O(^ICD9("AB",DGPTDIB1,0)) I DGPTDIB2="" S DGPTERC=509+I Q
47 S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIB2,$S($G(DGPTMDTS)'="":DGPTMDTS,1:DT)) ;use date of movement if defined, else today
48 I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q
49 I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=551 Q
50 S @("DGPTMD"_I)=$P(DGPTDIB1," ",1)
51 Q
Note: See TracBrowser for help on using the repository browser.