DGPT60PR.m

DGPT60PR ;ALB/MTC/ADL,HIOFO/FT - Edit procedure codes.  In ICD0 Procedures, current, gender ok ;2/19/15 4:31pm

 ;;5.3;Registration;**510,870,850,884**;Aug 13, 1993;Build 31

 ;;ADL;Update for CSV project;;Mar. 24, 2003

 ;

 ; ICDEX APIs - #5747

 ; ICDXCODE APIs - #5699

 ;

EN ;called from DGPT601

LOOP ;

 S DGPTPRFL=0

 F DGPTL3=1:1:$S(DGPTFMT=3:25,1:5) S DGPTERC=0 D CHKPRC I DGPTERC D ERR

EXIT ;

 K DGPTOP,DGPTOP1,DGPTL3,DGPTL4,DGPTPP,DGPTPRFL,X,X1,X2

 Q

CHKPRC ;check if the procedure code exists in file 80.1

 N SYS,EFFDATE,IMPDATE,DGPTDAT

 D EFFDATE^DGPTIC10($G(PTF))

 S SYS=$$SYS^ICDEX("PROC",EFFDATE)

 S DGPTERC=0,DGPTOP=(@("DGPTPC"_DGPTL3)),DGPTOP=$P(DGPTOP," ",1) Q:DGPTOP=""

 S DGPTERC=604+DGPTL3

 I SYS=2 F DGPTL4=1:1:$L(DGPTOP) S DGPTOP1=$E(DGPTOP,1,DGPTL4)_"."_$E(DGPTOP,DGPTL4+1,$L(DGPTOP)) I +$$CODEN^ICDEX(DGPTOP1,80.1)>0 S DGPTERC=0 D GEN Q

 I SYS=31 S DGPTOP1=DGPTOP I +$$CODEN^ICDEX(DGPTOP1,80.1)>0 S DGPTERC=0 D GEN Q

 Q

GEN ;check gender of patient

 N SYS,EFFDATE,IMPDATE,DGPTDAT

 D EFFDATE^DGPTIC10($G(PTF))

 ;DG*5.3*850

 S DGPTPP=+$$CODEN^ICDEX(DGPTOP1,80.1) I DGPTPP<1 S DGPTERC=604+DGPTL3 Q

 S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTPP,EFFDATE)

 I DGPTTMP<1!('$P(DGPTTMP,U,10)) S DGPTERC=604+DGPTL3 Q

 ;I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=651 Q

CURR ;check status and inactive date

 S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTPP,EFFDATE)  ;use date of procedure if defined, else today

 I ($P(DGPTTMP,U,10)=0)&($E(DGPTPDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=604+DGPTL3 Q

SAVE ;

 S @("DGPTPC"_DGPTL3)=DGPTOP1

ARRAY ;array is used in DGPTAEE for error display in List Manager interface

 S DGPTPRAR(DGPTPDTS)=$S($D(DGPTPRAR(DGPTPDTS)):DGPTPRAR(DGPTPDTS)_U_DGPTPP,1:DGPTPP_U)

 Q

ERR ;

 D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DGPT60PR   1800     printed  Apr 09, 2024@22:01:46                                                                                                                                                                                                    Page 2

DGPT60PR  ;ALB/MTC/ADL,HIOFO/FT - Edit procedure codes.  In ICD0 Procedures, current, gender ok ;2/19/15 4:31pm

 +1       ;;5.3;Registration;**510,870,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        ;called from DGPT601

LOOP      ;

 +1        SET DGPTPRFL=0

 +2        FOR DGPTL3=1:1:$SELECT(DGPTFMT=3:25,1:5)

               SET DGPTERC=0

               DO CHKPRC

               IF DGPTERC

                   DO ERR

EXIT      ;

 +1        KILL DGPTOP,DGPTOP1,DGPTL3,DGPTL4,DGPTPP,DGPTPRFL,X,X1,X2

 +2        QUIT 

CHKPRC    ;check if the procedure code exists in file 80.1

 +1        NEW SYS,EFFDATE,IMPDATE,DGPTDAT

 +2        DO EFFDATE^DGPTIC10($GET(PTF))

 +3        SET SYS=$$SYS^ICDEX("PROC",EFFDATE)

 +4        SET DGPTERC=0

           SET DGPTOP=(@("DGPTPC"_DGPTL3))

           SET DGPTOP=$PIECE(DGPTOP," ",1)

           if DGPTOP=""

               QUIT 

 +5        SET DGPTERC=604+DGPTL3

 +6        IF SYS=2

               FOR DGPTL4=1:1:$LENGTH(DGPTOP)

                   SET DGPTOP1=$EXTRACT(DGPTOP,1,DGPTL4)_"."_$EXTRACT(DGPTOP,DGPTL4+1,$LENGTH(DGPTOP))

                   IF +$$CODEN^ICDEX(DGPTOP1,80.1)>0

                       SET DGPTERC=0

                       DO GEN

                       QUIT 

 +7        IF SYS=31

               SET DGPTOP1=DGPTOP

               IF +$$CODEN^ICDEX(DGPTOP1,80.1)>0

                   SET DGPTERC=0

                   DO GEN

                   QUIT 

 +8        QUIT 

GEN       ;check gender of patient

 +1        NEW SYS,EFFDATE,IMPDATE,DGPTDAT

 +2        DO EFFDATE^DGPTIC10($GET(PTF))

 +3       ;DG*5.3*850

 +4        SET DGPTPP=+$$CODEN^ICDEX(DGPTOP1,80.1)

           IF DGPTPP<1

               SET DGPTERC=604+DGPTL3

               QUIT 

 +5        SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTPP,EFFDATE)

 +6        IF DGPTTMP<1!('$PIECE(DGPTTMP,U,10))

               SET DGPTERC=604+DGPTL3

               QUIT 

 +7       ;I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=651 Q

CURR      ;check status and inactive date

 +1       ;use date of procedure if defined, else today

           SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTPP,EFFDATE)

 +2        IF ($PIECE(DGPTTMP,U,10)=0)&($EXTRACT(DGPTPDTS,1,7)>$PIECE(DGPTTMP,U,12))

               SET DGPTERC=604+DGPTL3

               QUIT 

SAVE      ;

 +1        SET @("DGPTPC"_DGPTL3)=DGPTOP1

ARRAY     ;array is used in DGPTAEE for error display in List Manager interface

 +1        SET DGPTPRAR(DGPTPDTS)=$SELECT($DATA(DGPTPRAR(DGPTPDTS)):DGPTPRAR(DGPTPDTS)_U_DGPTPP,1:DGPTPP_U)

 +2        QUIT 

ERR       ;

 +1        DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)

 +2        QUIT