- DGPT50DI ;ALB/MTC/ADL - Edit diagnoses.Check ICD DIAGNOSES, current, gender correct ; 16 NOV 92
- ;;5.3;Registration;**510,1015**;Aug 13, 1993;Build 21
- ;;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
- DGPT50DI ;ALB/MTC/ADL - Edit diagnoses.Check ICD DIAGNOSES, current, gender correct ; 16 NOV 92
- +1 ;;5.3;Registration;**510,1015**;Aug 13, 1993;Build 21
- +2 ;;ADL;Updated for CSV project;;Mar 24, 2003
- +3 ;
- EN ;
- +1 FOR I=1:1:5
- SET DGPTDIB=$PIECE(@("DGPTMD"_I)," ",1)
- SET DGPTERC=0
- DO DIAG(I)
- IF DGPTERC
- DO ERR
- IF DGPTEDFL
- GOTO EXIT
- +2 DO EXIT
- +3 QUIT
- DIAG(I) ;
- +1 IF DGPTDIB=""
- QUIT
- +2 IF $EXTRACT(DGPTDIB,1)="E"
- SET DGPTERC=0
- DO DIAGE
- QUIT
- +3 IF $EXTRACT(DGPTDIB,1)="V"
- SET DGPTERC=0
- DO DIAGV
- QUIT
- +4 SET DGPTDIB1=$EXTRACT(DGPTDIB_" ",1,3)_"."_$EXTRACT(DGPTDIB_" ",4,5)_" "
- +5 IF $DATA(^ICD9("AB",DGPTDIB1))
- SET DGPTERC=0
- DO GEN(I)
- QUIT
- +6 QUIT
- ERR ;
- +1 DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
- +2 QUIT
- EXIT ;
- +1 KILL DGPTDIB,DGPTDIB1,DGPTDIB2,I
- +2 QUIT
- DIAGE ;
- +1 IF $EXTRACT(DGPTDIB)'="E"
- QUIT
- +2 IF I=1
- SET DGPTERC=550
- QUIT
- +3 SET DGPTDIB1=$EXTRACT(DGPTDIB,1,4)_"."_$EXTRACT(DGPTDIB,5,$LENGTH(DGPTDIB))_" "
- +4 IF '$DATA(^ICD9("AB",DGPTDIB1))
- SET DGPTERC=509+I
- QUIT
- +5 SET X=$ORDER(^ICD9("AB",DGPTDIB1,0))
- IF X=""
- SET DGPTERC=509+I
- QUIT
- +6 ;use date of movement if defined, else today
- SET DGPTTMP=$$ICDDX^ICDCODE(X,$SELECT($GET(DGPTMDTS)'="":DGPTMDTS,1:DT))
- +7 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
- SET DGPTERC=509+I
- QUIT
- +8 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTMDTS,1,7)>$PIECE(DGPTTMP,U,12))
- SET DGPTERC=509+I
- QUIT
- +9 IF ($PIECE(DGPTTMP,U,11)]"")&(DGPTGEN'=$PIECE(DGPTTMP,U,11))
- SET DGPTERC=791+I
- QUIT
- +10 SET @("DGPTMD"_I)=$PIECE(DGPTDIB1," ",1)
- +11 QUIT
- DIAGV ; DIAG CODES = "V##.0-2# "
- +1 IF $EXTRACT(DGPTDIB)'="V"
- QUIT
- +2 SET DGPTDIB1=$EXTRACT(DGPTDIB,1,3)_"."_$EXTRACT(DGPTDIB,4,$LENGTH(DGPTDIB))_" "
- +3 IF '$DATA(^ICD9("AB",DGPTDIB1))
- SET DGPTERC=509+I
- QUIT
- +4 SET X=$ORDER(^ICD9("AB",DGPTDIB1,0))
- IF X=""
- SET DGPTERC=509+I
- QUIT
- +5 ;use date of movement if defined, else today
- SET DGPTTMP=$$ICDDX^ICDCODE(X,$SELECT($GET(DGPTMDTS)'="":DGPTMDTS,1:DT))
- +6 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
- SET DGPTERC=509+I
- QUIT
- +7 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTMDTS,1,7)>$PIECE(DGPTTMP,U,12))
- SET DGPTERC=509+I
- QUIT
- +8 IF ($PIECE(DGPTTMP,U,11)]"")&(DGPTGEN'=$PIECE(DGPTTMP,U,11))
- SET DGPTERC=509+I
- QUIT
- +9 SET @("DGPTMD"_I)=$PIECE(DGPTDIB1," ",1)
- +10 QUIT
- GEN(I) ;
- +1 SET DGPTDIB2=$ORDER(^ICD9("AB",DGPTDIB1,0))
- IF DGPTDIB2=""
- SET DGPTERC=509+I
- QUIT
- +2 ;use date of movement if defined, else today
- SET DGPTTMP=$$ICDDX^ICDCODE(DGPTDIB2,$SELECT($GET(DGPTMDTS)'="":DGPTMDTS,1:DT))
- +3 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
- SET DGPTERC=509+I
- QUIT
- +4 IF $PIECE(DGPTTMP,U,11)]""&(DGPTGEN'=$PIECE(DGPTTMP,U,11))
- SET DGPTERC=551
- QUIT
- +5 SET @("DGPTMD"_I)=$PIECE(DGPTDIB1," ",1)
- +6 QUIT
