Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICD187PT

ICD187PT.m

Go to the documentation of this file.
  1. ICD187PT ; ALB/ADL - GROUPER DRIVER ; 04/11/03
  1. ;;18.0;DRG Grouper;**7**;Oct 20, 2000
  1. ;;**routine to build the new DRG global levels required for the CSV project
  1. ;;**taken from routine created by DEK to add new "66" levels to ICD0 and ICD9
  1. ;;**it addes the "DRG" levels to the 66 multiples in ICD0 (#80.1) and ICD9 (#80) and
  1. ;;**it creates the 66 multiple levels in the DRG file (ICD/#80.2)
  1. N I,FILE,CSD,NODE,FLAG,FLGN,CSIN,CSIP,CSAN,CSAP,ADATE,IDATE
  1. S U="^"
  1. F I=2:1 S CSD=$P($T(ADJDATA+I),";;",2) Q:CSD']"" D
  1. . S FILE=$P(CSD,U),NODE=$P(CSD,U,2),FLAG=$P(CSD,U,3),FLGN=$P(CSD,U,10)
  1. . S CSIN=$P(CSD,U,4),CSIP=$P(CSD,U,5),CSAN=$P(CSD,U,6)
  1. . 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)
  1. . D MAINLOOP(^DIC(FILE,0,"GL"),0)
  1. Q
  1. ;
  1. MAINLOOP(ROOT,IEN) ;
  1. N DKZ,RC,STAT,IDT,ADT,S,DRGZ S S="////"
  1. W !!!?5,"APPLYING EDITS TO FILE ",FILE,!
  1. I FILE=80.2 D CLEANUP ;Remove old "66" levels before inserting new ones into ICD file
  1. F S IEN=$O(@(ROOT_IEN_")")) Q:'+IEN D
  1. . S DKZ=$G(@(ROOT_IEN_",0)")),STAT=+$P(DKZ,U,FLAG) ; zero node, status
  1. . S IDT=$P(DKZ,U,CSIP),ADT=$P(DKZ,U,CSAP) ; in/active dates
  1. . I FILE<81 D Q
  1. . . I FILE=80.2 S MDCD=$P(DKZ,U,MDC),SURGD=$P(DKZ,U,SURG) D ALTERDRG Q
  1. . . I FILE=80 S DRGZ=$G(@(ROOT_IEN_",""DRG"")"))
  1. . . I FILE=80.1 S DRGZ="^^^^^",SS=$O(@(ROOT_IEN_",""MDC"",99999)"),-1) I SS'="" S DRGZ=$G(@(ROOT_IEN_",""MDC"","_SS_",""DRG"")"))
  1. . . D ALTERICD
  1. . D ALTERCPT
  1. Q
  1. ALTERICD ;
  1. N ANS,AD,ID,DR
  1. I 'STAT S AD=$S(IDT="":ADATE,1:IDT),DR=CSAN_S_AD
  1. E S ID=$S(IDT="":IDATE,1:IDT),DR=CSIN_S_ID_";"_CSAN_S_ADATE
  1. ;S ANS=$$EDIT0(IEN,ROOT,DR) ;*DON'T RUN TO REBUILD .01 LEVEL
  1. S ANS=1
  1. ;W !,"IEN ",IEN,$S('ANS:" IN USE",1:" EDITED")
  1. ;
  1. I 'STAT D ADDMULT(FILE,IEN,NODE,AD,1,DRGZ)
  1. I STAT D ADDMULT(FILE,IEN,NODE,ID,0,DRGZ)
  1. Q
  1. ;
  1. ALTERDRG ;
  1. N ANS,AD,ID,DR,EFFDT,EFFDT2,ACTFLG,FIRSTSET
  1. ;I $D(@(ROOT_IEN_",66)")) Q
  1. S FY=0,ACTFLG=0,FIRSTSET=0 ;Default ACTLFG=0 to start
  1. 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
  1. . S EFFDT=($E(FY,1,3)-1)_"1001" I EFFDT<2821001 Q ;Ignore dates before FY 1983
  1. . I 'FIRSTSET&(+WGHT=0) D ;1st FY date WEIGHT = 0 (INACTIVE) - must have 1st entry = ACTIVE so create one
  1. . . S EFFDT2=2821001 D ADDDRGZ(FILE,IEN,NODE,EFFDT2,1,MDCD,SURGD) ;add FY 1983 w/status of ACTIVE
  1. . . S ACTFLG=1
  1. . S FIRSTSET=1
  1. . I EFFDT=2821001&(ACTFLG) Q ;First FY date = 2830000. Don't add second EFF DT entry for FY 2830000
  1. . I ACTFLG D ADDDRGZ(FILE,IEN,NODE,EFFDT,0,MDCD,SURGD) S ACTFLG=0 Q ;add INACTIVE node
  1. . I 'ACTFLG D ADDDRGZ(FILE,IEN,NODE,EFFDT,1,MDCD,SURGD) S ACTFLG=1 ;add ACTIVE node
  1. Q
  1. ;
  1. CLEANUP ;REMOVE 66 LEVELS TO REPROCESS
  1. S CD=0
  1. F S CD=$O(^ICD(CD)) Q:CD="" K ^ICD(CD,66)
  1. Q ;CLEANUP
  1. ALTERCPT ;
  1. N DR,AD,ID,ANS,EFF,EFFS
  1. S EFF=$$EFF(FILE,IEN)
  1. S EFFS=$P(EFF,U,2),ID=$P(EFF,U,3),AD=$P(EFF,U,4),DR=CSAN_S_AD
  1. S:'EFFS DR=DR_";"_CSIN_S_ID
  1. I EFFS'=1-STAT S DR=DR_";"_FLGN_S_EFFS
  1. S ANS=$$EDIT0(IEN,ROOT,DR)
  1. ;W !,"IEN ",IEN,$S('ANS:" IN USE",1:" EDITED")
  1. ;
  1. I AD=ADATE D ADDMULT(FILE,IEN,NODE,AD,1)
  1. I 'EFFS,ID=IDATE D ADDMULT(FILE,IEN,NODE,ID,0)
  1. Q
  1. ;
  1. EFF(FILE,CODE) ;
  1. N EFILE,EFF,EFFN,STR,EFFDT,EFFST,EFFBOOL,EFFDOS,EFFDFLT
  1. S EFFDFLT="2890101^1^2900101^2890101",EFILE=^DIC(FILE,0,"GL")_CODE_",60,"
  1. S EFF=$O(@(EFILE_"""B"","_(DT+.001)_")"),-1) I 'EFF Q EFFDFLT
  1. S EFFN=$O(@(EFILE_"""B"","_EFF_",0)")) ; node 60 (effective date) sub-entry
  1. S STR=$G(@(EFILE_EFFN_",0)")) I 'STR Q EFFDFLT
  1. ;set Opposite eff. date based on status
  1. S EFFDT=+STR,EFFST=$P(STR,U,2),EFFBOOL=0
  1. F S EFF=$O(@(EFILE_"""B"","_EFF_")"),-1) Q:'EFF!EFFBOOL D
  1. . S EFFN=$O(@(EFILE_"""B"","_EFF_",0)"))
  1. . S EFFDOS=$G(@(EFILE_EFFN_",0)")) I 'EFFDOS S EFF="" Q
  1. . S EFFBOOL=(EFFST'=$P(EFFDOS,U,2))
  1. S EFFDOS=$G(EFFDOS,$S('EFFST:$P(EFFDFLT,U),1:$P(EFFDFLT,U,3)))
  1. I EFFST S $P(STR,U,3,4)=(+EFFDOS)_U_EFFDT
  1. E S $P(STR,U,3,4)=EFFDT_U_(+EFFDOS)
  1. Q STR
  1. ;
  1. EDIT0(DA,DIE,DR) ; adjust zero node
  1. N REC S REC=DA
  1. L +@(DIE_REC_",0)"):2 I D Q 1
  1. . D ^DIE
  1. . L -@(DIE_REC_",0)")
  1. Q 0
  1. ;
  1. ADDMULT(FN,IEN,NODE,X,STA,DRGZ) ; add to multiple
  1. N FDA,FDAIEN,ANS
  1. S FN=+$P(^DD(FN,NODE,0),U,2)
  1. S FDAIEN="1,"_IEN_","
  1. K ^TMP("DIERR",$J)
  1. ;S FDA(FN,FDAIEN,.01)=X ;NOT REQ'D SINCE ICD*18.0*6 ALREADY BUILT THIS LEVEL
  1. ;S FDA(FN,FDAIEN,.02)=STA ;NOT REQ'D SINCE ICD*18.0*6 ALREADY BUILT THIS LEVEL
  1. F DRGCNT=1:1:6 S FDA(FN,FDAIEN,59+DRGCNT)=$P(DRGZ,"^",DRGCNT)
  1. D UPDATE^DIE("","FDA")
  1. S ANS='$D(^TMP("DIERR",$J))
  1. ;W !,"IEN ",IEN,$S('ANS:" DIDNT",1:" DID")," ADD ",STA
  1. Q
  1. ;
  1. ADDDRGZ(FN,IEN,NODE,X,STA,MDCD,SURGD) ; add to DRG multiple
  1. N FDA,FDAIEN,ANS
  1. S FN=+$P(^DD(FN,NODE,0),U,2)
  1. S FDAIEN="+1,"_IEN_","
  1. K ^TMP("DIERR",$J)
  1. S FDA(FN,FDAIEN,.01)=X
  1. S FDA(FN,FDAIEN,.03)=STA
  1. S FDA(FN,FDAIEN,.05)=MDCD
  1. S FDA(FN,FDAIEN,.06)=SURGD
  1. ;F DRGCNT=1:1:6 S FDA(FN,FDAIEN,59+DRGCBT)=$P(DRGZ,"^",DRGCNT)
  1. D UPDATE^DIE("","FDA")
  1. S ANS='$D(^TMP("DIERR",$J))
  1. ;W !,"IEN ",IEN,$S('ANS:" DIDNT",1:" DID")," ADD ",STA
  1. Q
  1. ;
  1. SETINACT(IEN) ;set inactive dates for DRG codes
  1. N FY
  1. S FY=0
  1. F S FY=$O(^ICD(IEN,"FY",FY)) Q:FY="" I +$P(^ICD(IEN,"FY",FY,0),"^",2)=0 D Q
  1. . S DATE=$E(FY,1,3)_"1001"
  1. . I $D(^ICD(IEN,66,"B",DATE)) Q
  1. . D ADDDRGZ(FILE,IEN,NODE,DATE,0,MDCD,SURGD) ; add w/date of 10/1 of FY and STATUS of 0 (INACTIVE)
  1. . W !,"UPDATING ",IEN," TO INACTIVE"
  1. Q ;SETINACT
  1. ;
  1. UPDATE ; SET INACTIVE DRG LEVELS
  1. N I,FILE,CSD,NODE,FLAG,FLGN,CSIN,CSIP,CSAN,CSAP,ADATE,IDATE
  1. S U="^"
  1. S CSD=$P($T(ADJDATA+4),";;",2) Q:CSD']"" D
  1. . S FILE=80.2,NODE=$P(CSD,U,2),FLAG=$P(CSD,U,3),FLGN=$P(CSD,U,10)
  1. . S CSIN=$P(CSD,U,4),CSIP=$P(CSD,U,5),CSAN=$P(CSD,U,6)
  1. . 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)
  1. . S ROOT=^DIC(FILE,0,"GL"),IEN=0
  1. . ;CODE TAKE FROM MAINLOOP
  1. . N DKZ,RC,STAT,IDT,ADT,S,DRGZ S S="////"
  1. . W !!!?5,"UPDATING INACTIVE FLAG FOR ",FILE,!
  1. . F S IEN=$O(@(ROOT_IEN_")")) Q:'+IEN D
  1. . . S DKZ=$G(@(ROOT_IEN_",0)")),STAT=+$P(DKZ,U,FLAG) ; zero node, status
  1. . . S IDT=$P(DKZ,U,CSIP),ADT=$P(DKZ,U,CSAP) ; in/active dates
  1. . . S MDCD=$P(DKZ,U,MDC),SURGD=$P(DKZ,U,SURG) D SETINACT(IEN) Q
  1. Q
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1. ADJDATA ;data to add/update
  1. ;;
  1. ;;80.1^66^9^102^11^12^12^2781001^2791001^100
  1. ;;80^66^9^102^11^16^16^2781001^2791001^100
  1. ;;80.2^66^14^16^15^14^13^2821001^2791001^15^5^6
  1. Q
  1. ;;81^60^4^7^7^8^8^2890101^2900101^5
  1. ;;81.3^60^5^7^7^8^8^2890101^2900101^5
  1. ;;
  1. ;;