- DGPT70DX ;ALB/MTC/ADL - DXLS Edit Checks for 701 ; 13 NOV 92
- ;;5.3;Registration;**510,1015**;Aug 13, 1993;Build 21
- ;;ADL;Update for CSV Project;;Mar 24, 2003
- ;
- ;
- EN ;-- check dxls
- S DGPTDDXE=$P(DGPTDDXE," ",1)
- S DGPTERC=0
- NOE ;
- I $E(DGPTDDXE,1)="E" S DGPTERC=750 Q
- I $E(DGPTDDXE,1)="V" S DGPTERC=0 D DIAGV G:DGPTERC EXIT D SET G:DGPTERC EXIT G GENDR
- Q:"VE"[$E(DGPTDDXE,1)
- NUM ;
- 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
- S DGPTERC=715 G EXIT
- SET ;
- S J=$O(^ICD9("AB",DGPTDIA1,0)) I J="" S DGPTERC=715 Q
- S DGPTTMP=$$ICDDX^ICDCODE(J,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today
- I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=715 Q
- I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=715 Q
- Q
- GENDR ;
- S DGPTTMP=$$ICDDX^ICDCODE(J,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today
- G:$P(DGPTTMP,U,11)']"" DDXE
- I $P(DGPTTMP,U,11)'=DGPTGEN S DGPTERC=751 G EXIT
- DDXE ;
- S ICDDX(1)=J
- S DGPTDDXE=$P(DGPTDIA1," ",1)
- EXIT ;
- K J,J1,DGPTDIA1
- Q
- DIAGV ;
- S DGPTDIA1=$E(DGPTDDXE,1,3)_"."_$E(DGPTDDXE,4,$L(DGPTDDXE))_" "
- I '$D(^ICD9("AB",DGPTDIA1)) S DGPTERC=715
- Q
- DGPT70DX ;ALB/MTC/ADL - DXLS Edit Checks for 701 ; 13 NOV 92
- +1 ;;5.3;Registration;**510,1015**;Aug 13, 1993;Build 21
- +2 ;;ADL;Update for CSV Project;;Mar 24, 2003
- +3 ;
- +4 ;
- EN ;-- check dxls
- +1 SET DGPTDDXE=$PIECE(DGPTDDXE," ",1)
- +2 SET DGPTERC=0
- NOE ;
- +1 IF $EXTRACT(DGPTDDXE,1)="E"
- SET DGPTERC=750
- QUIT
- +2 IF $EXTRACT(DGPTDDXE,1)="V"
- SET DGPTERC=0
- DO DIAGV
- IF DGPTERC
- GOTO EXIT
- DO SET
- IF DGPTERC
- GOTO EXIT
- GOTO GENDR
- +3 IF "VE"[$EXTRACT(DGPTDDXE,1)
- QUIT
- NUM ;
- +1 SET J1=$LENGTH(DGPTDDXE)
- FOR J=1:1:3
- SET DGPTDIA1=$EXTRACT(DGPTDDXE,1,J)_"."_$EXTRACT(DGPTDDXE,J+1,J1)_" "
- IF $DATA(^ICD9("AB",DGPTDIA1))
- DO SET
- IF 'DGPTERC
- GOTO GENDR
- +2 SET DGPTERC=715
- GOTO EXIT
- SET ;
- +1 SET J=$ORDER(^ICD9("AB",DGPTDIA1,0))
- IF J=""
- SET DGPTERC=715
- QUIT
- +2 ;use date of disp. if defined, else today
- SET DGPTTMP=$$ICDDX^ICDCODE(J,$SELECT($GET(DGPTDDS)'="":DGPTDDS,1:DT))
- +3 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
- SET DGPTERC=715
- QUIT
- +4 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTDDS,1,7)>$PIECE(DGPTTMP,U,12))
- SET DGPTERC=715
- QUIT
- +5 QUIT
- GENDR ;
- +1 ;use date of disp. if defined, else today
- SET DGPTTMP=$$ICDDX^ICDCODE(J,$SELECT($GET(DGPTDDS)'="":DGPTDDS,1:DT))
- +2 IF $PIECE(DGPTTMP,U,11)']""
- GOTO DDXE
- +3 IF $PIECE(DGPTTMP,U,11)'=DGPTGEN
- SET DGPTERC=751
- GOTO EXIT
- DDXE ;
- +1 SET ICDDX(1)=J
- +2 SET DGPTDDXE=$PIECE(DGPTDIA1," ",1)
- EXIT ;
- +1 KILL J,J1,DGPTDIA1
- +2 QUIT
- DIAGV ;
- +1 SET DGPTDIA1=$EXTRACT(DGPTDDXE,1,3)_"."_$EXTRACT(DGPTDDXE,4,$LENGTH(DGPTDDXE))_" "
- +2 IF '$DATA(^ICD9("AB",DGPTDIA1))
- SET DGPTERC=715
- +3 QUIT
