| [613] | 1 | DGPT60PR ;ALB/MTC/ADL - Edit procedure codes. In ICD0 Procedures, current, gender ok ; 17 NOV 92
|
|---|
| 2 | ;;5.3;Registration;**510**;Aug 13, 1993
|
|---|
| 3 | ;;ADL;Update for CSV project;;Mar. 24, 2003
|
|---|
| 4 | ;
|
|---|
| 5 | EN ;
|
|---|
| 6 | LOOP ;
|
|---|
| 7 | S DGPTPRFL=0
|
|---|
| 8 | F DGPTL3=1:1:5 S DGPTERC=0 D CHKPRC I DGPTERC D ERR
|
|---|
| 9 | EXIT ;
|
|---|
| 10 | K DGPTOP,DGPTOP1,DGPTL3,DGPTL4,DGPTPP,DGPTPRFL,X,X1,X2
|
|---|
| 11 | Q
|
|---|
| 12 | CHKPRC ;
|
|---|
| 13 | S DGPTERC=0,DGPTOP=(@("DGPTPC"_DGPTL3)),DGPTOP=$P(DGPTOP," ",1) Q:DGPTOP=""
|
|---|
| 14 | S DGPTERC=604+DGPTL3
|
|---|
| 15 | 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
|
|---|
| 16 | Q
|
|---|
| 17 | GEN ;
|
|---|
| 18 | S DGPTPP=$O(^ICD0("AB",DGPTOP1,0)) I DGPTPP="" S DGPTERC=604+DGPTL3 Q
|
|---|
| 19 | S DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$S($G(DGPTPDTS)'="":DGPTPDTS,1:DT)) ;use date of procedure if defined, else today
|
|---|
| 20 | I DGPTTMP<1!('$P(DGPTTMP,U,10)) S DGPTERC=604+DGPTL3 Q
|
|---|
| 21 | I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=651 Q
|
|---|
| 22 | CURR ;
|
|---|
| 23 | S DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$S($G(DGPTPDTS)'="":DGPTPDTS,1:DT)) ;use date of procedure if defined, else today
|
|---|
| 24 | I ($P(DGPTTMP,U,10)=0)&($E(DGPTPDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=604+DGPTL3 Q
|
|---|
| 25 | SAVE ;
|
|---|
| 26 | S @("DGPTPC"_DGPTL3)=DGPTOP1
|
|---|
| 27 | ARRAY ;
|
|---|
| 28 | S DGPTPRAR(DGPTPDTS)=$S($D(DGPTPRAR(DGPTPDTS)):DGPTPRAR(DGPTPDTS)_U_DGPTPP,1:DGPTPP_U)
|
|---|
| 29 | Q
|
|---|
| 30 | ERR ;
|
|---|
| 31 | D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
|
|---|
| 32 | Q
|
|---|
| 33 | ;
|
|---|
