source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD187PT.m@ 1420

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1ICD187PT ; ALB/ADL - GROUPER DRIVER ; 04/11/03
2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000
3 ;;**routine to build the new DRG global levels required for the CSV project
4 ;;**taken from routine created by DEK to add new "66" levels to ICD0 and ICD9
5 ;;**it addes the "DRG" levels to the 66 multiples in ICD0 (#80.1) and ICD9 (#80) and
6 ;;**it creates the 66 multiple levels in the DRG file (ICD/#80.2)
7 N I,FILE,CSD,NODE,FLAG,FLGN,CSIN,CSIP,CSAN,CSAP,ADATE,IDATE
8 S U="^"
9 F I=2:1 S CSD=$P($T(ADJDATA+I),";;",2) Q:CSD']"" D
10 . S FILE=$P(CSD,U),NODE=$P(CSD,U,2),FLAG=$P(CSD,U,3),FLGN=$P(CSD,U,10)
11 . S CSIN=$P(CSD,U,4),CSIP=$P(CSD,U,5),CSAN=$P(CSD,U,6)
12 . S CSAP=$P(CSD,U,7),ADATE=$P(CSD,U,8),IDATE=$P(CSD,U,9),MDC=$P(CSD,U,11),SURG=$P(CSD,U,12)
13 . D MAINLOOP(^DIC(FILE,0,"GL"),0)
14 Q
15 ;
16MAINLOOP(ROOT,IEN) ;
17 N DKZ,RC,STAT,IDT,ADT,S,DRGZ S S="////"
18 W !!!?5,"APPLYING EDITS TO FILE ",FILE,!
19 I FILE=80.2 D CLEANUP ;Remove old "66" levels before inserting new ones into ICD file
20 F S IEN=$O(@(ROOT_IEN_")")) Q:'+IEN D
21 . S DKZ=$G(@(ROOT_IEN_",0)")),STAT=+$P(DKZ,U,FLAG) ; zero node, status
22 . S IDT=$P(DKZ,U,CSIP),ADT=$P(DKZ,U,CSAP) ; in/active dates
23 . I FILE<81 D Q
24 . . I FILE=80.2 S MDCD=$P(DKZ,U,MDC),SURGD=$P(DKZ,U,SURG) D ALTERDRG Q
25 . . I FILE=80 S DRGZ=$G(@(ROOT_IEN_",""DRG"")"))
26 . . I FILE=80.1 S DRGZ="^^^^^",SS=$O(@(ROOT_IEN_",""MDC"",99999)"),-1) I SS'="" S DRGZ=$G(@(ROOT_IEN_",""MDC"","_SS_",""DRG"")"))
27 . . D ALTERICD
28 . D ALTERCPT
29 Q
30ALTERICD ;
31 N ANS,AD,ID,DR
32 I 'STAT S AD=$S(IDT="":ADATE,1:IDT),DR=CSAN_S_AD
33 E S ID=$S(IDT="":IDATE,1:IDT),DR=CSIN_S_ID_";"_CSAN_S_ADATE
34 ;S ANS=$$EDIT0(IEN,ROOT,DR) ;*DON'T RUN TO REBUILD .01 LEVEL
35 S ANS=1
36 ;W !,"IEN ",IEN,$S('ANS:" IN USE",1:" EDITED")
37 ;
38 I 'STAT D ADDMULT(FILE,IEN,NODE,AD,1,DRGZ)
39 I STAT D ADDMULT(FILE,IEN,NODE,ID,0,DRGZ)
40 Q
41 ;
42ALTERDRG ;
43 N ANS,AD,ID,DR,EFFDT,EFFDT2,ACTFLG,FIRSTSET
44 ;I $D(@(ROOT_IEN_",66)")) Q
45 S FY=0,ACTFLG=0,FIRSTSET=0 ;Default ACTLFG=0 to start
46 F S FY=$O(@(ROOT_IEN_",""FY"",FY)")) Q:FY="" S FYINFO=^(FY,0),WGHT=$P(FYINFO,U,2),UPDT=$S((+WGHT)&('ACTFLG):1,(+WGHT=0)&(ACTFLG):1,1:0) I UPDT!('FIRSTSET) D
47 . S EFFDT=($E(FY,1,3)-1)_"1001" I EFFDT<2821001 Q ;Ignore dates before FY 1983
48 . I 'FIRSTSET&(+WGHT=0) D ;1st FY date WEIGHT = 0 (INACTIVE) - must have 1st entry = ACTIVE so create one
49 . . S EFFDT2=2821001 D ADDDRGZ(FILE,IEN,NODE,EFFDT2,1,MDCD,SURGD) ;add FY 1983 w/status of ACTIVE
50 . . S ACTFLG=1
51 . S FIRSTSET=1
52 . I EFFDT=2821001&(ACTFLG) Q ;First FY date = 2830000. Don't add second EFF DT entry for FY 2830000
53 . I ACTFLG D ADDDRGZ(FILE,IEN,NODE,EFFDT,0,MDCD,SURGD) S ACTFLG=0 Q ;add INACTIVE node
54 . I 'ACTFLG D ADDDRGZ(FILE,IEN,NODE,EFFDT,1,MDCD,SURGD) S ACTFLG=1 ;add ACTIVE node
55 Q
56 ;
57CLEANUP ;REMOVE 66 LEVELS TO REPROCESS
58 S CD=0
59 F S CD=$O(^ICD(CD)) Q:CD="" K ^ICD(CD,66)
60 Q ;CLEANUP
61ALTERCPT ;
62 N DR,AD,ID,ANS,EFF,EFFS
63 S EFF=$$EFF(FILE,IEN)
64 S EFFS=$P(EFF,U,2),ID=$P(EFF,U,3),AD=$P(EFF,U,4),DR=CSAN_S_AD
65 S:'EFFS DR=DR_";"_CSIN_S_ID
66 I EFFS'=1-STAT S DR=DR_";"_FLGN_S_EFFS
67 S ANS=$$EDIT0(IEN,ROOT,DR)
68 ;W !,"IEN ",IEN,$S('ANS:" IN USE",1:" EDITED")
69 ;
70 I AD=ADATE D ADDMULT(FILE,IEN,NODE,AD,1)
71 I 'EFFS,ID=IDATE D ADDMULT(FILE,IEN,NODE,ID,0)
72 Q
73 ;
74EFF(FILE,CODE) ;
75 N EFILE,EFF,EFFN,STR,EFFDT,EFFST,EFFBOOL,EFFDOS,EFFDFLT
76 S EFFDFLT="2890101^1^2900101^2890101",EFILE=^DIC(FILE,0,"GL")_CODE_",60,"
77 S EFF=$O(@(EFILE_"""B"","_(DT+.001)_")"),-1) I 'EFF Q EFFDFLT
78 S EFFN=$O(@(EFILE_"""B"","_EFF_",0)")) ; node 60 (effective date) sub-entry
79 S STR=$G(@(EFILE_EFFN_",0)")) I 'STR Q EFFDFLT
80 ;set Opposite eff. date based on status
81 S EFFDT=+STR,EFFST=$P(STR,U,2),EFFBOOL=0
82 F S EFF=$O(@(EFILE_"""B"","_EFF_")"),-1) Q:'EFF!EFFBOOL D
83 . S EFFN=$O(@(EFILE_"""B"","_EFF_",0)"))
84 . S EFFDOS=$G(@(EFILE_EFFN_",0)")) I 'EFFDOS S EFF="" Q
85 . S EFFBOOL=(EFFST'=$P(EFFDOS,U,2))
86 S EFFDOS=$G(EFFDOS,$S('EFFST:$P(EFFDFLT,U),1:$P(EFFDFLT,U,3)))
87 I EFFST S $P(STR,U,3,4)=(+EFFDOS)_U_EFFDT
88 E S $P(STR,U,3,4)=EFFDT_U_(+EFFDOS)
89 Q STR
90 ;
91EDIT0(DA,DIE,DR) ; adjust zero node
92 N REC S REC=DA
93 L +@(DIE_REC_",0)"):2 I D Q 1
94 . D ^DIE
95 . L -@(DIE_REC_",0)")
96 Q 0
97 ;
98ADDMULT(FN,IEN,NODE,X,STA,DRGZ) ; add to multiple
99 N FDA,FDAIEN,ANS
100 S FN=+$P(^DD(FN,NODE,0),U,2)
101 S FDAIEN="1,"_IEN_","
102 K ^TMP("DIERR",$J)
103 ;S FDA(FN,FDAIEN,.01)=X ;NOT REQ'D SINCE ICD*18.0*6 ALREADY BUILT THIS LEVEL
104 ;S FDA(FN,FDAIEN,.02)=STA ;NOT REQ'D SINCE ICD*18.0*6 ALREADY BUILT THIS LEVEL
105 F DRGCNT=1:1:6 S FDA(FN,FDAIEN,59+DRGCNT)=$P(DRGZ,"^",DRGCNT)
106 D UPDATE^DIE("","FDA")
107 S ANS='$D(^TMP("DIERR",$J))
108 ;W !,"IEN ",IEN,$S('ANS:" DIDNT",1:" DID")," ADD ",STA
109 Q
110 ;
111ADDDRGZ(FN,IEN,NODE,X,STA,MDCD,SURGD) ; add to DRG multiple
112 N FDA,FDAIEN,ANS
113 S FN=+$P(^DD(FN,NODE,0),U,2)
114 S FDAIEN="+1,"_IEN_","
115 K ^TMP("DIERR",$J)
116 S FDA(FN,FDAIEN,.01)=X
117 S FDA(FN,FDAIEN,.03)=STA
118 S FDA(FN,FDAIEN,.05)=MDCD
119 S FDA(FN,FDAIEN,.06)=SURGD
120 ;F DRGCNT=1:1:6 S FDA(FN,FDAIEN,59+DRGCBT)=$P(DRGZ,"^",DRGCNT)
121 D UPDATE^DIE("","FDA")
122 S ANS='$D(^TMP("DIERR",$J))
123 ;W !,"IEN ",IEN,$S('ANS:" DIDNT",1:" DID")," ADD ",STA
124 Q
125 ;
126SETINACT(IEN) ;set inactive dates for DRG codes
127 N FY
128 S FY=0
129 F S FY=$O(^ICD(IEN,"FY",FY)) Q:FY="" I +$P(^ICD(IEN,"FY",FY,0),"^",2)=0 D Q
130 . S DATE=$E(FY,1,3)_"1001"
131 . I $D(^ICD(IEN,66,"B",DATE)) Q
132 . D ADDDRGZ(FILE,IEN,NODE,DATE,0,MDCD,SURGD) ; add w/date of 10/1 of FY and STATUS of 0 (INACTIVE)
133 . W !,"UPDATING ",IEN," TO INACTIVE"
134 Q ;SETINACT
135 ;
136UPDATE ; SET INACTIVE DRG LEVELS
137 N I,FILE,CSD,NODE,FLAG,FLGN,CSIN,CSIP,CSAN,CSAP,ADATE,IDATE
138 S U="^"
139 S CSD=$P($T(ADJDATA+4),";;",2) Q:CSD']"" D
140 . S FILE=80.2,NODE=$P(CSD,U,2),FLAG=$P(CSD,U,3),FLGN=$P(CSD,U,10)
141 . S CSIN=$P(CSD,U,4),CSIP=$P(CSD,U,5),CSAN=$P(CSD,U,6)
142 . S CSAP=$P(CSD,U,7),ADATE=$P(CSD,U,8),IDATE=$P(CSD,U,9),MDC=$P(CSD,U,11),SURG=$P(CSD,U,12)
143 . S ROOT=^DIC(FILE,0,"GL"),IEN=0
144 . ;CODE TAKE FROM MAINLOOP
145 . N DKZ,RC,STAT,IDT,ADT,S,DRGZ S S="////"
146 . W !!!?5,"UPDATING INACTIVE FLAG FOR ",FILE,!
147 . F S IEN=$O(@(ROOT_IEN_")")) Q:'+IEN D
148 . . S DKZ=$G(@(ROOT_IEN_",0)")),STAT=+$P(DKZ,U,FLAG) ; zero node, status
149 . . S IDT=$P(DKZ,U,CSIP),ADT=$P(DKZ,U,CSAP) ; in/active dates
150 . . S MDCD=$P(DKZ,U,MDC),SURGD=$P(DKZ,U,SURG) D SETINACT(IEN) Q
151 Q
152 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153ADJDATA ;data to add/update
154 ;;
155 ;;80.1^66^9^102^11^12^12^2781001^2791001^100
156 ;;80^66^9^102^11^16^16^2781001^2791001^100
157 ;;80.2^66^14^16^15^14^13^2821001^2791001^15^5^6
158 Q
159 ;;81^60^4^7^7^8^8^2890101^2900101^5
160 ;;81.3^60^5^7^7^8^8^2890101^2900101^5
161 ;;
162 ;;
Note: See TracBrowser for help on using the repository browser.