DGPT60PR.m

DGPT60PR ;ALB/MTC/ADL - Edit procedure codes.  In ICD0 Procedures, current, gender ok ; 17 NOV 92

 ;;5.3;Registration;**510,1015**;Aug 13, 1993;Build 21

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

 ;

EN ;

LOOP ;

 S DGPTPRFL=0

 F DGPTL3=1:1:5 S DGPTERC=0 D CHKPRC I DGPTERC D ERR

EXIT ;

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

 Q

CHKPRC ;

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

 S DGPTERC=604+DGPTL3

 F DGPTL4=1:1:$L(DGPTOP) S DGPTOP1=$E(DGPTOP,1,DGPTL4)_"."_$E(DGPTOP,DGPTL4+1,$L(DGPTOP)) I $D(^ICD0("AB",DGPTOP1)) S DGPTERC=0 D GEN Q

 Q

GEN ;

 S DGPTPP=$O(^ICD0("AB",DGPTOP1,0)) I DGPTPP="" S DGPTERC=604+DGPTL3 Q

 S DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$S($G(DGPTPDTS)'="":DGPTPDTS,1:DT))  ;use date of procedure if defined, else today

 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 ;

 S DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$S($G(DGPTPDTS)'="":DGPTPDTS,1:DT))  ;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 ;

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

 Q

ERR ;

 D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)

 Q

 ;

DGPT60PR  ;ALB/MTC/ADL - Edit procedure codes.  In ICD0 Procedures, current, gender ok ; 17 NOV 92

 +1       ;;5.3;Registration;**510,1015**;Aug 13, 1993;Build 21

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

 +3       ;

EN        ;

LOOP      ;

 +1        SET DGPTPRFL=0

 +2        FOR DGPTL3=1: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    ;

 +1        SET DGPTERC=0

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

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

           IF DGPTOP=""

               QUIT 

 +2        SET DGPTERC=604+DGPTL3

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

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

               IF $DATA(^ICD0("AB",DGPTOP1))

                   SET DGPTERC=0

                   DO GEN

                   QUIT 

 +4        QUIT 

GEN       ;

 +1        SET DGPTPP=$ORDER(^ICD0("AB",DGPTOP1,0))

           IF DGPTPP=""

               SET DGPTERC=604+DGPTL3

               QUIT 

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

           SET DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$SELECT($GET(DGPTPDTS)'="":DGPTPDTS,1:DT))

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

               SET DGPTERC=604+DGPTL3

               QUIT 

 +4        IF $PIECE(DGPTTMP,U,11)]""&(DGPTGEN'=$PIECE(DGPTTMP,U,11))

               SET DGPTERC=651

               QUIT 

CURR      ;

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

           SET DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$SELECT($GET(DGPTPDTS)'="":DGPTPDTS,1:DT))

 +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     ;

 +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 

 +3       ;