- DGPT70DX ;ALB/MTC/ADL,HIOFO/FT - DXLS Edit Checks for 701 ;3/3/15 12:46pm
- ;;5.3;Registration;**510,850,884**;Aug 13, 1993;Build 31
- ;;ADL;Update for CSV Project;;Mar 24, 2003
- ;
- ; ICDEX APIs - #5747
- ; ICDXCODE APIs - #5699
- ;
- EN ;-- check dxls for entire stay
- S DGPTDDXE=$P(DGPTDDXE," ",1) ;DGPTDDXE = dxls for entire stay
- S DGPTERC=0
- NOE ;quit if code starts with E
- ;E = Supplementary Classification of Factors Influencing Health Status
- ; and Contact with Health Services.
- ;V = Supplementary Classification of External Causes of Inquiry and Poisoning
- N SYS,EFFDATE,IMPDATE,DGPTDAT
- D EFFDATE^DGPTIC10($G(PTF))
- S SYS=$$SYS^ICDEX("DIAG",EFFDATE)
- I SYS=1 I $E(DGPTDDXE,1)="E" S DGPTERC=750 Q
- I SYS=1 I $E(DGPTDDXE,1)="V" S DGPTERC=0 D DIAGV G:DGPTERC EXIT D SET G:DGPTERC EXIT G GENDR
- I SYS=1 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 +$$CODEN^ICDEX(DGPTDIA1,80)>0 D SET G:'DGPTERC GENDR
- S DGPTERC=715 G EXIT
- SET ;
- N EFFDATE,IMPDATE,DGPTDAT
- D EFFDATE^DGPTIC10($G(PTF))
- S J=+$$CODEN^ICDEX(DGPTDIA1,80) I J<1 S DGPTERC=715 Q
- S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",J,EFFDATE)
- 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 ;patient's gender
- N EFFDATE,IMPDATE,DGPTDAT
- D EFFDATE^DGPTIC10($G(PTF))
- S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",J,EFFDATE)
- 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 ;Supplementary Classification of External Causes of Inquiry and Poisoning
- S DGPTDIA1=$E(DGPTDDXE,1,3)_"."_$E(DGPTDDXE,4,$L(DGPTDDXE))_" "
- I +$$CODEN^ICDEX(DGPTDIA1,80)<1 S DGPTERC=715
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPT70DX 1820 printed Jan 18, 2025@03:52:09 Page 2
- DGPT70DX ;ALB/MTC/ADL,HIOFO/FT - DXLS Edit Checks for 701 ;3/3/15 12:46pm
- +1 ;;5.3;Registration;**510,850,884**;Aug 13, 1993;Build 31
- +2 ;;ADL;Update for CSV Project;;Mar 24, 2003
- +3 ;
- +4 ; ICDEX APIs - #5747
- +5 ; ICDXCODE APIs - #5699
- +6 ;
- EN ;-- check dxls for entire stay
- +1 ;DGPTDDXE = dxls for entire stay
- SET DGPTDDXE=$PIECE(DGPTDDXE," ",1)
- +2 SET DGPTERC=0
- NOE ;quit if code starts with E
- +1 ;E = Supplementary Classification of Factors Influencing Health Status
- +2 ; and Contact with Health Services.
- +3 ;V = Supplementary Classification of External Causes of Inquiry and Poisoning
- +4 NEW SYS,EFFDATE,IMPDATE,DGPTDAT
- +5 DO EFFDATE^DGPTIC10($GET(PTF))
- +6 SET SYS=$$SYS^ICDEX("DIAG",EFFDATE)
- +7 IF SYS=1
- IF $EXTRACT(DGPTDDXE,1)="E"
- SET DGPTERC=750
- QUIT
- +8 IF SYS=1
- IF $EXTRACT(DGPTDDXE,1)="V"
- SET DGPTERC=0
- DO DIAGV
- if DGPTERC
- GOTO EXIT
- DO SET
- if DGPTERC
- GOTO EXIT
- GOTO GENDR
- +9 IF SYS=1
- 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 +$$CODEN^ICDEX(DGPTDIA1,80)>0
- DO SET
- if 'DGPTERC
- GOTO GENDR
- +2 SET DGPTERC=715
- GOTO EXIT
- SET ;
- +1 NEW EFFDATE,IMPDATE,DGPTDAT
- +2 DO EFFDATE^DGPTIC10($GET(PTF))
- +3 SET J=+$$CODEN^ICDEX(DGPTDIA1,80)
- IF J<1
- SET DGPTERC=715
- QUIT
- +4 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",J,EFFDATE)
- +5 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
- SET DGPTERC=715
- QUIT
- +6 IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTDDS,1,7)>$PIECE(DGPTTMP,U,12))
- SET DGPTERC=715
- QUIT
- +7 QUIT
- GENDR ;patient's gender
- +1 NEW EFFDATE,IMPDATE,DGPTDAT
- +2 DO EFFDATE^DGPTIC10($GET(PTF))
- +3 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",J,EFFDATE)
- +4 if $PIECE(DGPTTMP,U,11)']""
- GOTO DDXE
- +5 ;I $P(DGPTTMP,U,11)'=DGPTGEN S DGPTERC=751 G EXIT
- DDXE ;
- +1 SET ICDDX(1)=J
- +2 SET DGPTDDXE=$PIECE(DGPTDIA1," ",1)
- EXIT ;
- +1 KILL J,J1,DGPTDIA1
- +2 QUIT
- DIAGV ;Supplementary Classification of External Causes of Inquiry and Poisoning
- +1 SET DGPTDIA1=$EXTRACT(DGPTDDXE,1,3)_"."_$EXTRACT(DGPTDDXE,4,$LENGTH(DGPTDDXE))_" "
- +2 IF +$$CODEN^ICDEX(DGPTDIA1,80)<1
- SET DGPTERC=715
- +3 QUIT