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