DGPT70DX.m

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