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