source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPT60PR.m@ 1569

Last change on this file since 1569 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.3 KB
Line 
1DGPT60PR ;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 ;
5EN ;
6LOOP ;
7 S DGPTPRFL=0
8 F DGPTL3=1:1:5 S DGPTERC=0 D CHKPRC I DGPTERC D ERR
9EXIT ;
10 K DGPTOP,DGPTOP1,DGPTL3,DGPTL4,DGPTPP,DGPTPRFL,X,X1,X2
11 Q
12CHKPRC ;
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
17GEN ;
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
22CURR ;
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
25SAVE ;
26 S @("DGPTPC"_DGPTL3)=DGPTOP1
27ARRAY ;
28 S DGPTPRAR(DGPTPDTS)=$S($D(DGPTPRAR(DGPTPDTS)):DGPTPRAR(DGPTPDTS)_U_DGPTPP,1:DGPTPP_U)
29 Q
30ERR ;
31 D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
32 Q
33 ;
Note: See TracBrowser for help on using the repository browser.