- DGPT70DI ;ALB/MTC/ADL - Diagnosis edits for 700's - E codes, V codes, gender and ICD9 Diag. ; 16 NOV 92
- ;;5.3;Registration;**510,1015**;Aug 13, 1993;Build 21
- ;;ADL;Update for CSV Project;;Mar. 24, 2003
- ;
- EN ;
- F DGPTL3=1:1:9 S DGPTDIA=$P((@("DGPTGD"_DGPTL3))," ",1) S DGPTERC=0 D DIAG I DGPTERC D ERR G:DGPTEDFL EXIT
- Q
- ;
- DIAG ;
- Q:DGPTDIA=""
- I $E(DGPTDIA,1)="E" S DGPTERC=0 D DIAGE Q
- I $E(DGPTDIA,1)="V" S DGPTERC=0 D DIAGV Q
- S DGPTERC=719+DGPTL3
- F DGPTL4=1:1:$L(DGPTDIA) S DGPTDIA1=$E(DGPTDIA,1,DGPTL4)_"."_$E(DGPTDIA,DGPTL4+1,$L(DGPTDIA))_" " I $D(^ICD9("AB",DGPTDIA1)) S DGPTERC=0 D GEN Q
- Q
- ERR ;
- D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
- Q
- EXIT ;
- K DGPTDIA,DGPTDIA1,DGPTDIA2,DGPTL3,DGPTL4
- Q
- DIAGE ;
- Q:$E(DGPTDIA)'="E"
- S DGPTDIA1=$E(DGPTDIA,1,4)_"."_$E(DGPTDIA,5,$L(DGPTDIA))_" "
- I '$D(^ICD9("AB",DGPTDIA1)) S DGPTERC=719+DGPTL3 Q
- S DGPTDIA2=$O(^ICD9("AB",DGPTDIA1,0)) I DGPTDIA2="" S DGPTERC=719+DGPTL3 Q
- S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today
- I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=719+DGPTL3 Q
- I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=719+DGPTL3 Q
- I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=719+DGPTL3 Q
- S @("DGPTGD"_DGPTL3)=$P(DGPTDIA1," ",1)
- S DGPTDIAR(DGPTDDS)=$S($D(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
- Q
- DIAGV ;
- Q:$E(DGPTDIA)'="V"
- S DGPTDIA1=$E(DGPTDIA,1,3)_"."_$E(DGPTDIA,4,$L(DGPTDIA))_" "
- I '$D(^ICD9("AB",DGPTDIA1)) S DGPTERC=719+DGPTL3 Q
- S DGPTDIA2=$O(^ICD9("AB",DGPTDIA1,0)) I DGPTDIA2="" S DGPTERC=719+DGPTL3 Q
- S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today
- I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=719+DGPTL3 Q
- I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=719+DGPTL3 Q
- I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=719+DGPTL3 Q
- S @("DGPTGD"_DGPTL3)=$P(DGPTDIA1," ",1)
- S DGPTDIAR(DGPTDDS)=$S($D(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
- Q
- GEN ;
- S DGPTDIA2=$O(^ICD9("AB",DGPTDIA1,0)) I DGPTDIA2="" S DGPTERC=719+DGPTL3 Q
- S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today
- I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=719+DGPTL3 Q
- I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=751 Q
- S @("DGPTGD"_DGPTL3)=$P(DGPTDIA1," ",1)
- ARRAY ;
- S DGPTDIAR(DGPTDDS)=$S($D(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
- Q
- DGPT70DI ;ALB/MTC/ADL - Diagnosis edits for 700's - E codes, V codes, gender and ICD9 Diag. ; 16 NOV 92
- +1 ;;5.3;Registration;**510,1015**;Aug 13, 1993;Build 21
- +2 ;;ADL;Update for CSV Project;;Mar. 24, 2003
- +3 ;
- EN ;
- +1 FOR DGPTL3=1:1:9
- SET DGPTDIA=$PIECE((@("DGPTGD"_DGPTL3))," ",1)
- SET DGPTERC=0
- DO DIAG
- IF DGPTERC
- DO ERR
- IF DGPTEDFL
- GOTO EXIT
- +2 QUIT
- +3 ;
- DIAG ;
- +1 IF DGPTDIA=""
- QUIT
- +2 IF $EXTRACT(DGPTDIA,1)="E"
- SET DGPTERC=0
- DO DIAGE
- QUIT
- +3 IF $EXTRACT(DGPTDIA,1)="V"
- SET DGPTERC=0
- DO DIAGV
- QUIT
- +4 SET DGPTERC=719+DGPTL3
- +5 FOR DGPTL4=1:1:$LENGTH(DGPTDIA)
- SET DGPTDIA1=$EXTRACT(DGPTDIA,1,DGPTL4)_"."_$EXTRACT(DGPTDIA,DGPTL4+1,$LENGTH(DGPTDIA))_" "
- IF $DATA(^ICD9("AB",DGPTDIA1))
- SET DGPTERC=0
- DO GEN
- QUIT
- +6 QUIT
- ERR ;
- +1 DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
- +2 QUIT
- EXIT ;
- +1 KILL DGPTDIA,DGPTDIA1,DGPTDIA2,DGPTL3,DGPTL4
- +2 QUIT
- DIAGE ;
- +1 IF $EXTRACT(DGPTDIA)'="E"
- QUIT
- +2 SET DGPTDIA1=$EXTRACT(DGPTDIA,1,4)_"."_$EXTRACT(DGPTDIA,5,$LENGTH(DGPTDIA))_" "
- +3 IF '$DATA(^ICD9("AB",DGPTDIA1))
- SET DGPTERC=719+DGPTL3
- QUIT
- +4 SET DGPTDIA2=$ORDER(^ICD9("AB",DGPTDIA1,0))
- IF DGPTDIA2=""
- SET DGPTERC=719+DGPTL3
- QUIT
- +5 ;use date of disp. if defined, else today
- SET DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$SELECT($GET(DGPTDDS)'="":DGPTDDS,1:DT))
- +6 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
- SET DGPTERC=719+DGPTL3
- QUIT
- +7 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTDDS,1,7)>$PIECE(DGPTTMP,U,12))
- SET DGPTERC=719+DGPTL3
- QUIT
- +8 IF ($PIECE(DGPTTMP,U,11)]"")&(DGPTGEN'=$PIECE(DGPTTMP,U,11))
- SET DGPTERC=719+DGPTL3
- QUIT
- +9 SET @("DGPTGD"_DGPTL3)=$PIECE(DGPTDIA1," ",1)
- +10 SET DGPTDIAR(DGPTDDS)=$SELECT($DATA(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
- +11 QUIT
- DIAGV ;
- +1 IF $EXTRACT(DGPTDIA)'="V"
- QUIT
- +2 SET DGPTDIA1=$EXTRACT(DGPTDIA,1,3)_"."_$EXTRACT(DGPTDIA,4,$LENGTH(DGPTDIA))_" "
- +3 IF '$DATA(^ICD9("AB",DGPTDIA1))
- SET DGPTERC=719+DGPTL3
- QUIT
- +4 SET DGPTDIA2=$ORDER(^ICD9("AB",DGPTDIA1,0))
- IF DGPTDIA2=""
- SET DGPTERC=719+DGPTL3
- QUIT
- +5 ;use date of disp. if defined, else today
- SET DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$SELECT($GET(DGPTDDS)'="":DGPTDDS,1:DT))
- +6 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
- SET DGPTERC=719+DGPTL3
- QUIT
- +7 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTDDS,1,7)>$PIECE(DGPTTMP,U,12))
- SET DGPTERC=719+DGPTL3
- QUIT
- +8 IF ($PIECE(DGPTTMP,U,11)]"")&(DGPTGEN'=$PIECE(DGPTTMP,U,11))
- SET DGPTERC=719+DGPTL3
- QUIT
- +9 SET @("DGPTGD"_DGPTL3)=$PIECE(DGPTDIA1," ",1)
- +10 SET DGPTDIAR(DGPTDDS)=$SELECT($DATA(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
- +11 QUIT
- GEN ;
- +1 SET DGPTDIA2=$ORDER(^ICD9("AB",DGPTDIA1,0))
- IF DGPTDIA2=""
- SET DGPTERC=719+DGPTL3
- QUIT
- +2 ;use date of disp. if defined, else today
- SET DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$SELECT($GET(DGPTDDS)'="":DGPTDDS,1:DT))
- +3 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
- SET DGPTERC=719+DGPTL3
- QUIT
- +4 IF $PIECE(DGPTTMP,U,11)]""&(DGPTGEN'=$PIECE(DGPTTMP,U,11))
- SET DGPTERC=751
- QUIT
- +5 SET @("DGPTGD"_DGPTL3)=$PIECE(DGPTDIA1," ",1)
- ARRAY ;
- +1 SET DGPTDIAR(DGPTDDS)=$SELECT($DATA(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2)
- +2 QUIT
