DGPT70DX.m

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 ---DGPT70DX   1820     printed  Apr 09, 2024@21:44:33                                                                                                                                                                                                    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