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

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

initial load of WorldVistAEHR

File size: 1.2 KB
RevLine 
[613]1DGPT70DX ;ALB/MTC/ADL - DXLS Edit Checks for 701 ; 13 NOV 92
2 ;;5.3;Registration;**510**;Aug 13, 1993
3 ;;ADL;Update for CSV Project;;Mar 24, 2003
4 ;
5 ;
6EN ;-- check dxls
7 S DGPTDDXE=$P(DGPTDDXE," ",1)
8 S DGPTERC=0
9NOE ;
10 I $E(DGPTDDXE,1)="E" S DGPTERC=750 Q
11 I $E(DGPTDDXE,1)="V" S DGPTERC=0 D DIAGV G:DGPTERC EXIT D SET G:DGPTERC EXIT G GENDR
12 Q:"VE"[$E(DGPTDDXE,1)
13NUM ;
14 S J1=$L(DGPTDDXE) F J=1:1:3 S DGPTDIA1=$E(DGPTDDXE,1,J)_"."_$E(DGPTDDXE,J+1,J1)_" " I $D(^ICD9("AB",DGPTDIA1)) D SET G:'DGPTERC GENDR
15 S DGPTERC=715 G EXIT
16SET ;
17 S J=$O(^ICD9("AB",DGPTDIA1,0)) I J="" S DGPTERC=715 Q
18 S DGPTTMP=$$ICDDX^ICDCODE(J,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today
19 I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=715 Q
20 I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=715 Q
21 Q
22GENDR ;
23 S DGPTTMP=$$ICDDX^ICDCODE(J,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today
24 G:$P(DGPTTMP,U,11)']"" DDXE
25 I $P(DGPTTMP,U,11)'=DGPTGEN S DGPTERC=751 G EXIT
26DDXE ;
27 S ICDDX(1)=J
28 S DGPTDDXE=$P(DGPTDIA1," ",1)
29EXIT ;
30 K J,J1,DGPTDIA1
31 Q
32DIAGV ;
33 S DGPTDIA1=$E(DGPTDDXE,1,3)_"."_$E(DGPTDDXE,4,$L(DGPTDDXE))_" "
34 I '$D(^ICD9("AB",DGPTDIA1)) S DGPTERC=715
35 Q
Note: See TracBrowser for help on using the repository browser.