BCSVUT ;IHS/MSC/BWF - CSV Utility ;20-Mar-2008 13:34;AA
;;1.0;BCSV;;APR 23, 2010
;=================================================================
; Utility Routine
Q
LCKFILES ;
N DD
F DD=80.3,80.2,81.11,80.1,80,81,81.3,9999999.88 D
.S $P(^DD(DD,0,"DI"),"^",2)="Y"
Q
UNLCKFLS ;
N DD
F DD=80.3,80.2,81.11,80.1,80,81,81.3,9999999.88 D
.S $P(^DD(DD,0,"DI"),"^",2)="N"
Q
UPDFWT ; Update IENS for Fiscal Weights and Trims on file 80.2
N ICDIEN,FYIEN,NEWFYIEN,LASTITEM
S ICDIEN=0
F S ICDIEN=$O(^ICD(ICDIEN)) Q:'ICDIEN D
.S FYIEN=0 F S FYIEN=$O(^ICD(ICDIEN,"FY",FYIEN)) Q:'FYIEN D
..S NEWFYIEN=$$CONVERT(FYIEN)
..I NEWFYIEN'?7N Q
..M ^ICD(ICDIEN,"FY",NEWFYIEN)=^ICD(ICDIEN,"FY",FYIEN)
..K ^ICD(ICDIEN,"FY",FYIEN)
..S LASTITEM=$O(^ICD(ICDIEN,"FY",9999999),-1)
..S $P(^ICD(ICDIEN,"FY",0),U,2)=LASTITEM
Q
CONVERT(IEN) ;
; Convert IEN from IHS format into VA format.
I IEN<100&(IEN>7) S IEN=2_IEN_0000 Q IEN
I (IEN=0)!((IEN>0)&(IEN<8)) S IEN=3_IEN_0000 Q IEN
Q
; Input
; AGE - Value passed in to be converted into days (passed in value is in years)
AGECON(AGE) ;
I 'AGE Q ""
Q (AGE*365)
; Input
; AGE - Value passed in to be converted into days (passed in value is in years)
; IEN - IEN of the entry being evaluated
; FLD - Field Number for file 80. This will be used to determine which IHS field the data should come from.
AGECON80(AGE,IEN,FLD) ;
N IHSFLD,IHSAGE
S IHSFLD=$S(FLD=14:9999999.01,FLD=15:9999999.02,1:0)
Q:'IHSFLD ""
S IHSAGE=$$GET1^DIQ(80,IEN,IHSFLD,"I")
I IHSAGE Q IHSAGE
Q:'AGE ""
S IHSAGE=$$AGECON(AGE)
Q IHSAGE
UPDBEFY ; Update Breakeven Fiscal Year/Quarter IEN'S in file 80.2
N ICDIEN,BEFYIEN,NEWBEIEN,LASTITEM
S ICDIEN=0
F S ICDIEN=$O(^ICD(ICDIEN)) Q:'ICDIEN D
.S BEFYIEN=0 F S BEFYIEN=$O(^ICD(ICDIEN,"BE",BEFYIEN)) Q:'BEFYIEN D
..S NEWBEIEN=$$NEWBEIEN(BEFYIEN)
..I NEWBEIEN'?5N Q
..M ^ICD(ICDIEN,"BE",NEWBEIEN)=^ICD(ICDIEN,"BE",BEFYIEN)
..K ^ICD(ICDIEN,"BE",BEFYIEN)
..S LASTITEM=$O(^ICD(ICDIEN,"BE",9999999),-1)
..S $P(^ICD(ICDIEN,"BE",0),U,2)=LASTITEM
Q
NEWBEIEN(BEIEN) ;
N NEWBEIEN,NEWFYIEN,NEWIEN
I BEIEN>799 S NEWIEN=19_BEIEN
I BEIEN<800 S NEWIEN=10_BEIEN
Q BEIEN
;
; Input FILE - File number for moving data into the versioning multiple
; DAT - Data indicating which fields need to be pulled, and where they will be placed.
; INACT - Inactivate this entry?
; 0 or "" - Inactivate
; 1 - Skip inactivation
;
VERSION(IEN,FUNC,INACT) ; Place information into versioning mutiples for unmapped entries.
; Entries that are not mapped will be inactivated.
I FUNC="" Q
S INACT=+$G(INACT)
S FUNC=FUNC_"("_IEN_","_INACT_")"
D @FUNC
Q
; INPUT IEN - IEN to entry in target file
; INACT - Inactive this entry?
; 0 or "" - Inactive
; 1 - skip inactivation
VER801(IEN,INACT) ;
N PROC,DESC,ACTDT,FDA,NEWIEN
; Get procedure name and activation date for versioned information.
S PROC=$$GET1^DIQ(80.1,IEN,4,"E")
S DESC=$$GET1^DIQ(80.1,IEN,10,"E")
S ACTDT=$$GET1^DIQ(80.1,IEN,12,"I")
I 'ACTDT S ACTDT=DT
S FDA(80.167,"+1,"_IEN_",",.01)=ACTDT
D UPDATE^DIE(,"FDA","NEWIEN") K FDA
I $D(NEWIEN) D
.S FDA(80.167,NEWIEN(1)_IEN_",",1)=PROC
.D FILE^DIE(,"FDA")
K FDA,NEWIEN
S FDA(80.168,"+1,"_IEN_",",.01)=ACTDT
D UPDATE^DIE(,"FDA","NEWIEN")
I $D(NEWIEN) D
.S FDA(80.168,NEWIEN(1)_","_IEN_",",1)=DESC
.D UPDATE^DIE(,"FDA")
K FDA,NEWIEN
I $G(INACT)!($D(^XCSV("ICD0","MAP","Z",IEN))) D FILE^DIE(,"FDA") Q
S FDA(80.1,IEN_",",100)=1
I '$$GET1^DIQ(80.1,IEN,102,"I") S FDA(80.1,IEN_",",102)=DT
D FILE^DIE(,"FDA")
Q
; INPUT IEN - IEN to entry in target file
; INACT - Inactive this entry?
; 0 or "" - Inactive
; 1 - skip inactivation
VER80(IEN,INACT) ;
N DIAG,DESC,ACTDT,FDA,NEWIEN,EFFDT
S DIAG=$$GET1^DIQ(80,IEN,3,"E")
S DESC=$$GET1^DIQ(80,IEN,10,"E")
S (ACTDT,EFFDT)=$$GET1^DIQ(80,IEN,16,"I")
I 'ACTDT S ACTDT=DT,EFFDT=2700101
S FDA(80.066,"+1,"_IEN_",",.01)=EFFDT
D UPDATE^DIE(,"FDA","NEWIEN") K FDA
I $D(NEWIEN) D
.S FDA(80.066,NEWIEN(1)_","_IEN_",",.02)=$S(INACT=1:1,1:0)
S FDA(80.067,"+1,"_IEN_",",.01)=ACTDT
D UPDATE^DIE(,"FDA","NEWIEN") K FDA
I $D(NEWIEN) D
.S FDA(80.067,NEWIEN(1)_","_IEN_",",1)=DIAG
.D FILE^DIE(,"FDA")
K FDA,NEWIEN
S FDA(80.068,"+1,"_IEN_",",.01)=ACTDT
D UPDATE^DIE(,"FDA","NEWIEN") K FDA
I $D(NEWIEN) D
.S FDA(80.068,NEWIEN(1)_","_IEN_",",1)=DESC
.D UPDATE^DIE(,"FDA")
K FDA,NEWIEN
I $G(INACT)!($D(^XCSV("ICD9","MAP","Z",IEN))) D FILE^DIE(,"FDA") Q
S FDA(80,IEN_",",100)=1
I '$$GET1^DIQ(80,IEN,102,"I") S FDA(80,IEN_",",102)=DT
D FILE^DIE(,"FDA")
Q
; INPUT IEN (required) - IEN to entry in target file
; INACT (optional) - Inactive this entry?
; 0 or "" - Inactive
; 1 - skip inactivation
VER802(IEN,INACT) ;
N DESC,FDA,ACTDT,NEWIEN,DNODE,LOOP
S DNODE=0 F S DNODE=$O(^ICD(IEN,1,DNODE)) Q:'DNODE D
.S DESCARY(DNODE)=$G(^ICD(IEN,1,DNODE,0))
S ACTDT=$$GET1^DIQ(80.2,IEN,14,"I")
I 'ACTDT S ACTDT=DT
S FDA(80.268,"+1,"_IEN_",",.01)=ACTDT
D UPDATE^DIE(,"FDA","NEWIEN")
I $D(NEWIEN) D
.S LOOP=0
.F S LOOP=$O(DESCARY(LOOP)) Q:'LOOP D
..S FDA(80.2681,"+"_LOOP_","_NEWIEN(1)_","_IEN_",",.01)=$G(DESCARY(LOOP))
.D UPDATE^DIE(,"FDA")
K FDA,NEWIEN
I $G(INACT)!($D(^XCSV("ICD","MAP","Z",IEN))) D FILE^DIE(,"FDA") Q
S FDA(80.2,IEN_",",15)=1
I '$$GET1^DIQ(80.2,IEN,16,"I") S FDA(80.2,IEN_",",16)=DT
D FILE^DIE(,"FDA")
Q
VER803(IEN,INACT) ;
; Nothing to do here.
Q
; INPUT IEN (required) - IEN to entry in target file
; INACT (optional) - Inactive this entry?
; 0 or "" - Inactive
; 1 - skip inactivation
VER81(IEN,INACT) ;
N SHNAME,DESCARY,ACTDT,FDA,NEWIEN,LOOP,DNODE,NEWIEN
S SHNAME=$$GET1^DIQ(81,IEN,2,"E")
S DNODE=0 F S DNODE=$O(^ICPT(IEN,"D",DNODE)) Q:'DNODE D
.S DESCARY(DNODE)=$G(^ICPT(IEN,"D",DNODE,0))
S ACTDT=$$GET1^DIQ(81,IEN,8,"I")
I 'ACTDT S ACTDT=DT
S FDA(81.061,"+1,"_IEN_",",.01)=ACTDT
D UPDATE^DIE(,"FDA","NEWIEN")
I $D(NEWIEN) D
.S FDA(81.061,NEWIEN(1)_IEN_",",1)=SHNAME
.D FILE^DIE(,"FDA")
K FDA,NEWIEN
S FDA(81.062,"+1,"_IEN_",",.01)=ACTDT
D UPDATE^DIE(,"FDA","NEWIEN") K FDA
I $D(NEWIEN) D
.S LOOP=0
.F S LOOP=$O(DESCARY(LOOP)) Q:'LOOP D
..S FDA(81.621,"+"_LOOP_","_NEWIEN(1)_","_IEN_",",.01)=$G(DESCARY(LOOP))
D UPDATE^DIE(,"FDA") K FDA
I $G(INACT)!($D(^XCSV("ICPT","MAP","Z",IEN))) D FILE^DIE(,"FDA") Q
S FDA(81,IEN_",",5)=1
I '$$GET1^DIQ(81,IEN,7,"I") S FDA(81,IEN_",",7)=DT
D FILE^DIE(,"FDA")
Q
VER811(IEN,INACT) ;
; Nothing to do.
Q
; INPUT IEN (required) - IEN to entry in target file
; INACT (optional) - Inactive this entry?
; 0 or "" - Inactive
; 1 - skip inactivation
VER813(IEN,INACT) ;
N NAME,DESC,ACTDT,FDA,NEWIEN
S NAME=$$GET1^DIQ(81.3,IEN,.02,"E")
S DNODE=0 F S DNODE=$O(^DIC(81.3,IEN,"D",DNODE)) Q:'DNODE D
.S ^TMP($J,DNODE,0)=$G(^DIC(81.3,IEN,"D",DNODE,0))
S ACTDT=$$GET1^DIQ(81.3,IEN,8,"I")
I 'ACTDT S ACTDT=DT
S FDA(81.361,"+1,"_IEN_",",.01)=ACTDT
D UPDATE^DIE(,"FDA","NEWIEN")
I $D(NEWIEN) D
.S FDA(81.361,NEWIEN(1)_IEN_",",1)=NAME
.D FILE^DIE(,"FDA",)
K FDA,NEWIEN
S FDA(81.362,"+1,"_IEN_",",.01)=ACTDT
D UPDATE^DIE(,"FDA","NEWIEN") K FDA
; set up wp field using WP^DIE
I '$D(NEWIEN) Q
D WP^DIE(81.362,NEWIEN(1)_","_IEN_",",1,"","^TMP($J)")
Q
;
UPDCODES ;
N FIL,QUIT,LINE,DAT,FILDAT,VADAT,VAXLOC,FDA,VAXFIL,NEWIEN,J,VAIEN,DA,DIK,FLD
N GLOBPATH,AGELOW,AGEHI
S QUIT=0
F J=1:1 D Q:QUIT
.S LINE=$T(FILES+J^BCSVMP)
.S DAT=$P(LINE,";;",2)
.I DAT="" S QUIT=1 Q
.S FILDAT=$P(DAT,"||"),VADAT=$P(FILDAT,"/",2)
.S VAXLOC=$P(VADAT,";"),VAXFIL=$P(VADAT,";",2)
.I VAXLOC["|" S GLOBPATH="^"_$TR(VAXLOC,"|","(")_")"
.E S GLOBPATH="^"_VAXLOC
.S VAIEN=0
.F S VAIEN=$O(^XCSV(VAXLOC,"DATA",VAIEN)) Q:'VAIEN D
..; If the VAIEN has an entry that has been mapped to it (i.e, the "B" x-ref exists), quit.
..K NEWIEN
..S FLD=$P($G(^XCSV(VAXLOC,"DATA",VAIEN,0)),"^")
..I $D(^XCSV(VAXLOC,"MAP","B",VAIEN)) Q
..; Add the new entry
..S FDA(VAXFIL,"+1,",.01)=FLD
..I VAXFIL=80 S FDA(VAXFIL,"+1,",3)="HOLD TEXT"
..I VAXFIL=81.3 S FDA(VAXFIL,"+1,",.02)="HOLD TEXT"
..I VAXFIL=80.2 S NEWIEN(1)=$P(FLD,"DRG",2)
..I VAXFIL=81 D
...S NEWIEN(1)=$S(FLD?5N:+FLD,FLD?1U4N:$A($E(FLD))_$E(FLD,2,5),1:1000000)
...I $G(NEWIEN(1))=1000000 N I S I=999999 F S I=$O(^ICPT(I)) Q:I<999999 S NEWIEN(1)=I+1
..D UPDATE^DIE(,"FDA","NEWIEN") K FDA
..; Use the new IEN value to merge data
..Q:'$G(NEWIEN(1))
..M @GLOBPATH@(NEWIEN(1))=^XCSV(VAXLOC,"DATA",VAIEN)
..S ^XCSV(VAXLOC,"MAP","B",VAIEN)=NEWIEN(1),^XCSV(VAXLOC,"NEW",NEWIEN(1))=""
..; Set the "Z" x-ref to hold a list of entries that are new.
..; Used to resolve pointers in the next step.
..S ^XCSV(VAXLOC,"MAP","Z",NEWIEN(1))=""
..; Reset the ptr value for fld 3 in 81.1
..S (AGELOW,AGEHI)=0
..I VAXFIL=80 D
...S AGELOW=$P($G(^ICD9(NEWIEN(1),0)),U,14) I AGELOW S $P(^ICD9(NEWIEN(1),0),U,14)=$$AGECON(AGELOW)
...S AGEHI=$P($G(^ICD9(NEWIEN(1),0)),U,15) I AGEHI S $P(^ICD9(NEWIEN(1),0),U,15)=$$AGECON(AGEHI)
..I VAXFIL=81 D
...S AGELOW=$P($G(^ICPT(NEWIEN(1),10)),U) I AGELOW S $P(^ICPT(NEWIEN(1),10),U)=$$AGECON(AGELOW)
...S AGEHI=$P($G(^ICPT(NEWIEN(1),10)),U,2) I AGEHI S $P(^ICPT(NEWIEN(1),10),U,2)=$$AGECON(AGEHI)
..I VAXFIL=81.1 D
...S CURPTR=$$GET1^DIQ(81.1,NEWIEN(1),.01,"I")
...S FDA(VAXFIL,NEWIEN(1),3)=$G(^XCSV(VAXLOC,"MAP",CURPTR)) D FILE^DIE(,"FDA") K FDA
..I GLOBPATH[")" S DIK=$P(GLOBPATH,")")_","
..E S DIK=GLOBPATH_"("
..S DA=NEWIEN(1) D IX1^DIK
..K NEWIEN,DA,DIK
Q
RPALL ;
D RP802,RP801,RP80
Q
RP802 ;
N IEN,SUBIEN,OVAL,NVAL
S IEN=0 F S IEN=$O(^ICD(IEN)) Q:'IEN D
.S SUBIEN=0 F S SUBIEN=$O(^ICD(IEN,66,SUBIEN)) Q:'SUBIEN D
..S OVAL=$$GET1^DIQ(80.266,SUBIEN_","_IEN,.05,"I")
..Q:'OVAL
..S NVAL=$G(^XCSV("ICD","MAP","B",OVAL))
..S FDA(80.266,SUBIEN_","_IEN_",",.05)=NVAL D FILE^DIE(,"FDA") K FDA
Q
RP801 ;
N IEN,DATA,LOOP,MDCPTR,NEWPTR,NEWDAT,VAL,NVAL,SIEN1,SIEN2,SIEN3,SIEN2PTR,SIEN3PTR,NIEN2PTR,NIEN3PTR,CNT
S IEN=0 F S IEN=$O(^ICD0(IEN)) Q:'IEN D
.; Correct pointers in field 7 multiple
.K DATA,DATA71,NEWDAT
.M DATA71=^ICD0(IEN,2)
.M DATA=^ICD0(IEN,"MDC")
.S LOOP=0 F S LOOP=$O(DATA(LOOP)) Q:'LOOP D
..S MDCPTR=$G(DATA(LOOP,0)),NEWPTR=$G(^XCSV("ICM","MAP","B",LOOP))
..S NEWDAT(0)=DATA(0)
..Q:'NEWPTR
..S NEWDAT(NEWPTR,0)=NEWPTR
..F I=1:1:6 D
...I '$D(DATA(LOOP,"DRG")) Q
...S VAL=$P(DATA(LOOP,"DRG"),U,I) Q:VAL=""
...S NVAL=$G(^XCSV("ICD","MAP","B",VAL))
...Q:NVAL=""
...S $P(NEWDAT(NEWPTR,"DRG"),U,I)=NVAL
.S Z2=$O(^ICD0(IEN,"MDC",""),-1)
.S CNT=0
.S CNTLP=0 F S CNTLP=$O(^ICD0(IEN,"MDC",CNTLP)) Q:'CNTLP D
..S CNT=CNT+1
.S:$D(^ICD0(IEN,"MDC")) $P(NEWDAT(0),U,4)=CNT
.; Now handle field 66
.S SIEN=0 F S SIEN=$O(^ICD0(IEN,66,SIEN)) Q:'SIEN D
..F I=1:1:5 D
...Q:'$D(^ICD0(IEN,66,SIEN,"DRG"))
...S VAL=$P(^ICD0(IEN,66,SIEN,"DRG"),U,I) Q:VAL=""
...S NVAL=$G(^XCSV("ICD","MAP","B",VAL))
...S $P(^ICD0(IEN,66,SIEN,"DRG"),U,I)=NVAL
..; Now handle field 71 and all subfiles
.S SIEN1=0 F S SIEN1=$O(DATA71(SIEN1)) Q:'SIEN1 D
..S SIEN2=0 F S SIEN2=$O(DATA71(SIEN1,1,SIEN2)) Q:'SIEN2 D
...S SIEN2PTR=$G(DATA71(SIEN1,1,SIEN2,0))
...S NIEN2PTR=$G(^XCSV("ICM","MAP","B",SIEN2PTR))
...; If the pointer values are the same, do not change anything.
...;Q:NIEN2PTR=SIEN2PTR
...K DATA71(SIEN1,1,"B",SIEN2PTR,SIEN2)
...I 'NIEN2PTR K DATA71(SIEN1,1,SIEN2) Q
...S DATA71(SIEN1,1,SIEN2,0)=NIEN2PTR
...S DATA71(SIEN1,1,"B",NIEN2PTR,SIEN2)=""
...S SIEN3=0 F S SIEN3=$O(DATA71(SIEN1,1,SIEN2,1,SIEN3)) Q:'SIEN3 D
....S SIEN3PTR=$G(DATA71(SIEN1,1,SIEN2,1,SIEN3,0))
....S NIEN3PTR=$G(^XCSV("ICD","MAP","B",SIEN3PTR))
....I 'NIEN3PTR K DATA71(SIEN1,1,SIEN2,1,SIEN3) Q
....I SIEN3PTR=NIEN3PTR Q
....S DATA71(SIEN1,1,SIEN2,1,SIEN3,0)=NIEN3PTR
....K DATA71(SIEN1,1,SIEN2,1,"B",SIEN3PTR,SIEN3)
....S DATA71(SIEN1,1,SIEN2,1,"B",NIEN3PTR,SIEN3)=""
.S:$D(^ICD0(IEN,"MDC")) ($P(NEWDAT(0),U,2),$P(NEWDAT(0),U,3))=$O(NEWDAT(""),-1)
.; Merge updated array back into multiple.
.K ^ICD0(IEN,"MDC") M ^ICD0(IEN,"MDC")=NEWDAT
.K ^ICD0(IEN,2) M ^ICD0(IEN,2)=DATA71
Q
RP80 ;
N IEN,ZNODE,CNT,NPTR,P3,I,J,SIEN,NIEN,DATA,ODAT,NPTR,OPTR,SIEN2,VAL,NVAL,SSCNT
S IEN=0 F S IEN=$O(^ICD9(IEN)) Q:'IEN D
.F J="N","R" D
..I '$D(^ICD9(IEN,J)) Q
..I '$O(^ICD9(IEN,J,0)) Q
..S ZNODE=$G(^ICD9(IEN,J,0))
..S ^TMP("BCSVUT",$J,0)=ZNODE
..S (SIEN,CNT)=0 F S SIEN=$O(^ICD9(IEN,J,SIEN)) Q:'SIEN D
...S NPTR=$G(^XCSV("ICD9","MAP","B",SIEN)) Q:'NPTR
...S CNT=CNT+1
...S ^TMP("BCSVUT",$J,NPTR,0)=NPTR,^TMP("BCSVUT",$J,"B",NPTR,NPTR)=""
..S P3=$O(^TMP("BCSVUT",$J,"B"),-1)
..S:$D(^ICD9(IEN,J)) $P(^TMP("BCSVUT",$J,0),U,3)=P3,$P(^TMP("BCSVUT",$J,0),U,4)=CNT
..K ^ICD9(IEN,J)
..M ^ICD9(IEN,J)=^TMP("BCSVUT",$J)
..K ^TMP("BCSVUT",$J)
.S SIEN=0 F S SIEN=$O(^ICD9(IEN,2,SIEN)) Q:'SIEN D
..S OPTR=$G(^ICD9(IEN,2,SIEN,0))
..S NPTR=$G(^XCSV("ICD9","MAP","B",OPTR))
..I NPTR=OPTR Q
..I NPTR="" K ^ICD9(IEN,2,SIEN),^ICD9("ACC",IEN,OPTR) Q
..S ^ICD9(IEN,2,SIEN,0)=NPTR
..K ^ICD9("ACC",IEN,OPTR) S ^ICD9("ACC",IEN,NPTR)=""
.S SSCNT=0
.S SIEN=0 F S SIEN=$O(^ICD9(IEN,2,SIEN)) Q:'SIEN D
..S SSCNT=SSCNT+1
.S:$D(^ICD9(IEN,2)) $P(^ICD9(IEN,2,0),U,3)=-$O(^ICD9(IEN,2,"")),$P(^ICD9(IEN,2,0),U,4)=$G(SSCNT)
.S SIEN=0 F S SIEN=$O(^ICD9("ACC",IEN,SIEN)) Q:'SIEN D ; codes not CC with
..S NIEN="",NIEN=$G(^XCSV("ICD9","MAP","B",SIEN)) I 'NIEN K ^ICD9("ACC",IEN,SIEN)
..I SIEN=NIEN Q
..K ^ICD9("ACC",IEN,SIEN)
..I NIEN S ^ICD9("ACC",IEN,NIEN)=""
.S SIEN=0 F S SIEN=$O(^ICD9(IEN,66,SIEN)) Q:'SIEN D ; Now handle field 66 - Effective Date multiple
..F I=1:1:5 D
...S VAL=$P($G(^ICD9(IEN,66,SIEN,"DRG")),U,I) Q:VAL=""
...S NVAL=$G(^XCSV("ICD","MAP","B",VAL))
...S $P(^ICD9(IEN,66,SIEN,"DRG"),U,I)=NVAL
.S SIEN=0 F S SIEN=$O(^ICD9(IEN,3,SIEN)) Q:'SIEN D ; Next we do the DRG GROUPER multiple #71
..S ZNODE=$G(^ICD9(IEN,3,SIEN,0))
..S SIEN2=0 F S SIEN2=$O(^ICD9(IEN,3,SIEN,1,SIEN2)) Q:'SIEN2 D
...S OPTR=$G(^ICD9(IEN,3,SIEN,1,SIEN2,0)) Q:'OPTR
...S NPTR=$G(^XCSV("ICD","MAP","B",OPTR))
...I OPTR=NPTR Q
...I 'NPTR K ^ICD9(IEN,3,SIEN,1,"B",OPTR,SIEN2) Q
...S ^ICD9(IEN,3,SIEN,1,SIEN2,0)=NPTR
...K ^ICD9(IEN,3,SIEN,1,"B",OPTR,SIEN2)
...S ^ICD9(IEN,3,SIEN,1,"B",NPTR,SIEN2)=""
.S SIEN=0 F S SIEN=$O(^ICD9(IEN,4,SIEN)) Q:'SIEN ; Now do the DRG GROUPER multiple #72
..S ODAT=$G(^ICD9(IEN,4,SIEN,0))
..S OPTR=$P(ODAT,U,2)
..S NPTR=$G(^XCSV("ICM","MAP","B",OPTR))
..S $P(^ICD9(IEN,4,SIEN,0),U,2)=NPTR
Q
BCSVUT ;IHS/MSC/BWF - CSV Utility ;20-Mar-2008 13:34;AA
+1 ;;1.0;BCSV;;APR 23, 2010
+2 ;=================================================================
+3 ; Utility Routine
+4 QUIT
LCKFILES ;
+1 NEW DD
+2 FOR DD=80.3,80.2,81.11,80.1,80,81,81.3,9999999.88
Begin DoDot:1
+3 SET $PIECE(^DD(DD,0,"DI"),"^",2)="Y"
End DoDot:1
+4 QUIT
UNLCKFLS ;
+1 NEW DD
+2 FOR DD=80.3,80.2,81.11,80.1,80,81,81.3,9999999.88
Begin DoDot:1
+3 SET $PIECE(^DD(DD,0,"DI"),"^",2)="N"
End DoDot:1
+4 QUIT
UPDFWT ; Update IENS for Fiscal Weights and Trims on file 80.2
+1 NEW ICDIEN,FYIEN,NEWFYIEN,LASTITEM
+2 SET ICDIEN=0
+3 FOR
SET ICDIEN=$ORDER(^ICD(ICDIEN))
IF 'ICDIEN
QUIT
Begin DoDot:1
+4 SET FYIEN=0
FOR
SET FYIEN=$ORDER(^ICD(ICDIEN,"FY",FYIEN))
IF 'FYIEN
QUIT
Begin DoDot:2
+5 SET NEWFYIEN=$$CONVERT(FYIEN)
+6 IF NEWFYIEN'?7N
QUIT
+7 MERGE ^ICD(ICDIEN,"FY",NEWFYIEN)=^ICD(ICDIEN,"FY",FYIEN)
+8 KILL ^ICD(ICDIEN,"FY",FYIEN)
+9 SET LASTITEM=$ORDER(^ICD(ICDIEN,"FY",9999999),-1)
+10 SET $PIECE(^ICD(ICDIEN,"FY",0),U,2)=LASTITEM
End DoDot:2
End DoDot:1
+11 QUIT
CONVERT(IEN) ;
+1 ; Convert IEN from IHS format into VA format.
+2 IF IEN<100&(IEN>7)
SET IEN=2_IEN_0000
QUIT IEN
+3 IF (IEN=0)!((IEN>0)&(IEN<8))
SET IEN=3_IEN_0000
QUIT IEN
+4 QUIT
+5 ; Input
+6 ; AGE - Value passed in to be converted into days (passed in value is in years)
AGECON(AGE) ;
+1 IF 'AGE
QUIT ""
+2 QUIT (AGE*365)
+3 ; Input
+4 ; AGE - Value passed in to be converted into days (passed in value is in years)
+5 ; IEN - IEN of the entry being evaluated
+6 ; FLD - Field Number for file 80. This will be used to determine which IHS field the data should come from.
AGECON80(AGE,IEN,FLD) ;
+1 NEW IHSFLD,IHSAGE
+2 SET IHSFLD=$SELECT(FLD=14:9999999.01,FLD=15:9999999.02,1:0)
+3 IF 'IHSFLD
QUIT ""
+4 SET IHSAGE=$$GET1^DIQ(80,IEN,IHSFLD,"I")
+5 IF IHSAGE
QUIT IHSAGE
+6 IF 'AGE
QUIT ""
+7 SET IHSAGE=$$AGECON(AGE)
+8 QUIT IHSAGE
UPDBEFY ; Update Breakeven Fiscal Year/Quarter IEN'S in file 80.2
+1 NEW ICDIEN,BEFYIEN,NEWBEIEN,LASTITEM
+2 SET ICDIEN=0
+3 FOR
SET ICDIEN=$ORDER(^ICD(ICDIEN))
IF 'ICDIEN
QUIT
Begin DoDot:1
+4 SET BEFYIEN=0
FOR
SET BEFYIEN=$ORDER(^ICD(ICDIEN,"BE",BEFYIEN))
IF 'BEFYIEN
QUIT
Begin DoDot:2
+5 SET NEWBEIEN=$$NEWBEIEN(BEFYIEN)
+6 IF NEWBEIEN'?5N
QUIT
+7 MERGE ^ICD(ICDIEN,"BE",NEWBEIEN)=^ICD(ICDIEN,"BE",BEFYIEN)
+8 KILL ^ICD(ICDIEN,"BE",BEFYIEN)
+9 SET LASTITEM=$ORDER(^ICD(ICDIEN,"BE",9999999),-1)
+10 SET $PIECE(^ICD(ICDIEN,"BE",0),U,2)=LASTITEM
End DoDot:2
End DoDot:1
+11 QUIT
NEWBEIEN(BEIEN) ;
+1 NEW NEWBEIEN,NEWFYIEN,NEWIEN
+2 IF BEIEN>799
SET NEWIEN=19_BEIEN
+3 IF BEIEN<800
SET NEWIEN=10_BEIEN
+4 QUIT BEIEN
+5 ;
+6 ; Input FILE - File number for moving data into the versioning multiple
+7 ; DAT - Data indicating which fields need to be pulled, and where they will be placed.
+8 ; INACT - Inactivate this entry?
+9 ; 0 or "" - Inactivate
+10 ; 1 - Skip inactivation
+11 ;
VERSION(IEN,FUNC,INACT) ; Place information into versioning mutiples for unmapped entries.
+1 ; Entries that are not mapped will be inactivated.
+2 IF FUNC=""
QUIT
+3 SET INACT=+$GET(INACT)
+4 SET FUNC=FUNC_"("_IEN_","_INACT_")"
+5 DO @FUNC
+6 QUIT
+7 ; INPUT IEN - IEN to entry in target file
+8 ; INACT - Inactive this entry?
+9 ; 0 or "" - Inactive
+10 ; 1 - skip inactivation
VER801(IEN,INACT) ;
+1 NEW PROC,DESC,ACTDT,FDA,NEWIEN
+2 ; Get procedure name and activation date for versioned information.
+3 SET PROC=$$GET1^DIQ(80.1,IEN,4,"E")
+4 SET DESC=$$GET1^DIQ(80.1,IEN,10,"E")
+5 SET ACTDT=$$GET1^DIQ(80.1,IEN,12,"I")
+6 IF 'ACTDT
SET ACTDT=DT
+7 SET FDA(80.167,"+1,"_IEN_",",.01)=ACTDT
+8 DO UPDATE^DIE(,"FDA","NEWIEN")
KILL FDA
+9 IF $DATA(NEWIEN)
Begin DoDot:1
+10 SET FDA(80.167,NEWIEN(1)_IEN_",",1)=PROC
+11 DO FILE^DIE(,"FDA")
End DoDot:1
+12 KILL FDA,NEWIEN
+13 SET FDA(80.168,"+1,"_IEN_",",.01)=ACTDT
+14 DO UPDATE^DIE(,"FDA","NEWIEN")
+15 IF $DATA(NEWIEN)
Begin DoDot:1
+16 SET FDA(80.168,NEWIEN(1)_","_IEN_",",1)=DESC
+17 DO UPDATE^DIE(,"FDA")
End DoDot:1
+18 KILL FDA,NEWIEN
+19 IF $GET(INACT)!($DATA(^XCSV("ICD0","MAP","Z",IEN)))
DO FILE^DIE(,"FDA")
QUIT
+20 SET FDA(80.1,IEN_",",100)=1
+21 IF '$$GET1^DIQ(80.1,IEN,102,"I")
SET FDA(80.1,IEN_",",102)=DT
+22 DO FILE^DIE(,"FDA")
+23 QUIT
+24 ; INPUT IEN - IEN to entry in target file
+25 ; INACT - Inactive this entry?
+26 ; 0 or "" - Inactive
+27 ; 1 - skip inactivation
VER80(IEN,INACT) ;
+1 NEW DIAG,DESC,ACTDT,FDA,NEWIEN,EFFDT
+2 SET DIAG=$$GET1^DIQ(80,IEN,3,"E")
+3 SET DESC=$$GET1^DIQ(80,IEN,10,"E")
+4 SET (ACTDT,EFFDT)=$$GET1^DIQ(80,IEN,16,"I")
+5 IF 'ACTDT
SET ACTDT=DT
SET EFFDT=2700101
+6 SET FDA(80.066,"+1,"_IEN_",",.01)=EFFDT
+7 DO UPDATE^DIE(,"FDA","NEWIEN")
KILL FDA
+8 IF $DATA(NEWIEN)
Begin DoDot:1
+9 SET FDA(80.066,NEWIEN(1)_","_IEN_",",.02)=$SELECT(INACT=1:1,1:0)
End DoDot:1
+10 SET FDA(80.067,"+1,"_IEN_",",.01)=ACTDT
+11 DO UPDATE^DIE(,"FDA","NEWIEN")
KILL FDA
+12 IF $DATA(NEWIEN)
Begin DoDot:1
+13 SET FDA(80.067,NEWIEN(1)_","_IEN_",",1)=DIAG
+14 DO FILE^DIE(,"FDA")
End DoDot:1
+15 KILL FDA,NEWIEN
+16 SET FDA(80.068,"+1,"_IEN_",",.01)=ACTDT
+17 DO UPDATE^DIE(,"FDA","NEWIEN")
KILL FDA
+18 IF $DATA(NEWIEN)
Begin DoDot:1
+19 SET FDA(80.068,NEWIEN(1)_","_IEN_",",1)=DESC
+20 DO UPDATE^DIE(,"FDA")
End DoDot:1
+21 KILL FDA,NEWIEN
+22 IF $GET(INACT)!($DATA(^XCSV("ICD9","MAP","Z",IEN)))
DO FILE^DIE(,"FDA")
QUIT
+23 SET FDA(80,IEN_",",100)=1
+24 IF '$$GET1^DIQ(80,IEN,102,"I")
SET FDA(80,IEN_",",102)=DT
+25 DO FILE^DIE(,"FDA")
+26 QUIT
+27 ; INPUT IEN (required) - IEN to entry in target file
+28 ; INACT (optional) - Inactive this entry?
+29 ; 0 or "" - Inactive
+30 ; 1 - skip inactivation
VER802(IEN,INACT) ;
+1 NEW DESC,FDA,ACTDT,NEWIEN,DNODE,LOOP
+2 SET DNODE=0
FOR
SET DNODE=$ORDER(^ICD(IEN,1,DNODE))
IF 'DNODE
QUIT
Begin DoDot:1
+3 SET DESCARY(DNODE)=$GET(^ICD(IEN,1,DNODE,0))
End DoDot:1
+4 SET ACTDT=$$GET1^DIQ(80.2,IEN,14,"I")
+5 IF 'ACTDT
SET ACTDT=DT
+6 SET FDA(80.268,"+1,"_IEN_",",.01)=ACTDT
+7 DO UPDATE^DIE(,"FDA","NEWIEN")
+8 IF $DATA(NEWIEN)
Begin DoDot:1
+9 SET LOOP=0
+10 FOR
SET LOOP=$ORDER(DESCARY(LOOP))
IF 'LOOP
QUIT
Begin DoDot:2
+11 SET FDA(80.2681,"+"_LOOP_","_NEWIEN(1)_","_IEN_",",.01)=$GET(DESCARY(LOOP))
End DoDot:2
+12 DO UPDATE^DIE(,"FDA")
End DoDot:1
+13 KILL FDA,NEWIEN
+14 IF $GET(INACT)!($DATA(^XCSV("ICD","MAP","Z",IEN)))
DO FILE^DIE(,"FDA")
QUIT
+15 SET FDA(80.2,IEN_",",15)=1
+16 IF '$$GET1^DIQ(80.2,IEN,16,"I")
SET FDA(80.2,IEN_",",16)=DT
+17 DO FILE^DIE(,"FDA")
+18 QUIT
VER803(IEN,INACT) ;
+1 ; Nothing to do here.
+2 QUIT
+3 ; INPUT IEN (required) - IEN to entry in target file
+4 ; INACT (optional) - Inactive this entry?
+5 ; 0 or "" - Inactive
+6 ; 1 - skip inactivation
VER81(IEN,INACT) ;
+1 NEW SHNAME,DESCARY,ACTDT,FDA,NEWIEN,LOOP,DNODE,NEWIEN
+2 SET SHNAME=$$GET1^DIQ(81,IEN,2,"E")
+3 SET DNODE=0
FOR
SET DNODE=$ORDER(^ICPT(IEN,"D",DNODE))
IF 'DNODE
QUIT
Begin DoDot:1
+4 SET DESCARY(DNODE)=$GET(^ICPT(IEN,"D",DNODE,0))
End DoDot:1
+5 SET ACTDT=$$GET1^DIQ(81,IEN,8,"I")
+6 IF 'ACTDT
SET ACTDT=DT
+7 SET FDA(81.061,"+1,"_IEN_",",.01)=ACTDT
+8 DO UPDATE^DIE(,"FDA","NEWIEN")
+9 IF $DATA(NEWIEN)
Begin DoDot:1
+10 SET FDA(81.061,NEWIEN(1)_IEN_",",1)=SHNAME
+11 DO FILE^DIE(,"FDA")
End DoDot:1
+12 KILL FDA,NEWIEN
+13 SET FDA(81.062,"+1,"_IEN_",",.01)=ACTDT
+14 DO UPDATE^DIE(,"FDA","NEWIEN")
KILL FDA
+15 IF $DATA(NEWIEN)
Begin DoDot:1
+16 SET LOOP=0
+17 FOR
SET LOOP=$ORDER(DESCARY(LOOP))
IF 'LOOP
QUIT
Begin DoDot:2
+18 SET FDA(81.621,"+"_LOOP_","_NEWIEN(1)_","_IEN_",",.01)=$GET(DESCARY(LOOP))
End DoDot:2
End DoDot:1
+19 DO UPDATE^DIE(,"FDA")
KILL FDA
+20 IF $GET(INACT)!($DATA(^XCSV("ICPT","MAP","Z",IEN)))
DO FILE^DIE(,"FDA")
QUIT
+21 SET FDA(81,IEN_",",5)=1
+22 IF '$$GET1^DIQ(81,IEN,7,"I")
SET FDA(81,IEN_",",7)=DT
+23 DO FILE^DIE(,"FDA")
+24 QUIT
VER811(IEN,INACT) ;
+1 ; Nothing to do.
+2 QUIT
+3 ; INPUT IEN (required) - IEN to entry in target file
+4 ; INACT (optional) - Inactive this entry?
+5 ; 0 or "" - Inactive
+6 ; 1 - skip inactivation
VER813(IEN,INACT) ;
+1 NEW NAME,DESC,ACTDT,FDA,NEWIEN
+2 SET NAME=$$GET1^DIQ(81.3,IEN,.02,"E")
+3 SET DNODE=0
FOR
SET DNODE=$ORDER(^DIC(81.3,IEN,"D",DNODE))
IF 'DNODE
QUIT
Begin DoDot:1
+4 SET ^TMP($JOB,DNODE,0)=$GET(^DIC(81.3,IEN,"D",DNODE,0))
End DoDot:1
+5 SET ACTDT=$$GET1^DIQ(81.3,IEN,8,"I")
+6 IF 'ACTDT
SET ACTDT=DT
+7 SET FDA(81.361,"+1,"_IEN_",",.01)=ACTDT
+8 DO UPDATE^DIE(,"FDA","NEWIEN")
+9 IF $DATA(NEWIEN)
Begin DoDot:1
+10 SET FDA(81.361,NEWIEN(1)_IEN_",",1)=NAME
+11 DO FILE^DIE(,"FDA",)
End DoDot:1
+12 KILL FDA,NEWIEN
+13 SET FDA(81.362,"+1,"_IEN_",",.01)=ACTDT
+14 DO UPDATE^DIE(,"FDA","NEWIEN")
KILL FDA
+15 ; set up wp field using WP^DIE
+16 IF '$DATA(NEWIEN)
QUIT
+17 DO WP^DIE(81.362,NEWIEN(1)_","_IEN_",",1,"","^TMP($J)")
+18 QUIT
+19 ;
UPDCODES ;
+1 NEW FIL,QUIT,LINE,DAT,FILDAT,VADAT,VAXLOC,FDA,VAXFIL,NEWIEN,J,VAIEN,DA,DIK,FLD
+2 NEW GLOBPATH,AGELOW,AGEHI
+3 SET QUIT=0
+4 FOR J=1:1
Begin DoDot:1
+5 SET LINE=$TEXT(FILES+J^BCSVMP)
+6 SET DAT=$PIECE(LINE,";;",2)
+7 IF DAT=""
SET QUIT=1
QUIT
+8 SET FILDAT=$PIECE(DAT,"||")
SET VADAT=$PIECE(FILDAT,"/",2)
+9 SET VAXLOC=$PIECE(VADAT,";")
SET VAXFIL=$PIECE(VADAT,";",2)
+10 IF VAXLOC["|"
SET GLOBPATH="^"_$TRANSLATE(VAXLOC,"|","(")_")"
+11 IF '$TEST
SET GLOBPATH="^"_VAXLOC
+12 SET VAIEN=0
+13 FOR
SET VAIEN=$ORDER(^XCSV(VAXLOC,"DATA",VAIEN))
IF 'VAIEN
QUIT
Begin DoDot:2
+14 ; If the VAIEN has an entry that has been mapped to it (i.e, the "B" x-ref exists), quit.
+15 KILL NEWIEN
+16 SET FLD=$PIECE($GET(^XCSV(VAXLOC,"DATA",VAIEN,0)),"^")
+17 IF $DATA(^XCSV(VAXLOC,"MAP","B",VAIEN))
QUIT
+18 ; Add the new entry
+19 SET FDA(VAXFIL,"+1,",.01)=FLD
+20 IF VAXFIL=80
SET FDA(VAXFIL,"+1,",3)="HOLD TEXT"
+21 IF VAXFIL=81.3
SET FDA(VAXFIL,"+1,",.02)="HOLD TEXT"
+22 IF VAXFIL=80.2
SET NEWIEN(1)=$PIECE(FLD,"DRG",2)
+23 IF VAXFIL=81
Begin DoDot:3
+24 SET NEWIEN(1)=$SELECT(FLD?5N:+FLD,FLD?1U4N:$ASCII($EXTRACT(FLD))_$EXTRACT(FLD,2,5),1:1000000)
+25 IF $GET(NEWIEN(1))=1000000
NEW I
SET I=999999
FOR
SET I=$ORDER(^ICPT(I))
IF I<999999
QUIT
SET NEWIEN(1)=I+1
End DoDot:3
+26 DO UPDATE^DIE(,"FDA","NEWIEN")
KILL FDA
+27 ; Use the new IEN value to merge data
+28 IF '$GET(NEWIEN(1))
QUIT
+29 MERGE @GLOBPATH@(NEWIEN(1))=^XCSV(VAXLOC,"DATA",VAIEN)
+30 SET ^XCSV(VAXLOC,"MAP","B",VAIEN)=NEWIEN(1)
SET ^XCSV(VAXLOC,"NEW",NEWIEN(1))=""
+31 ; Set the "Z" x-ref to hold a list of entries that are new.
+32 ; Used to resolve pointers in the next step.
+33 SET ^XCSV(VAXLOC,"MAP","Z",NEWIEN(1))=""
+34 ; Reset the ptr value for fld 3 in 81.1
+35 SET (AGELOW,AGEHI)=0
+36 IF VAXFIL=80
Begin DoDot:3
+37 SET AGELOW=$PIECE($GET(^ICD9(NEWIEN(1),0)),U,14)
IF AGELOW
SET $PIECE(^ICD9(NEWIEN(1),0),U,14)=$$AGECON(AGELOW)
+38 SET AGEHI=$PIECE($GET(^ICD9(NEWIEN(1),0)),U,15)
IF AGEHI
SET $PIECE(^ICD9(NEWIEN(1),0),U,15)=$$AGECON(AGEHI)
End DoDot:3
+39 IF VAXFIL=81
Begin DoDot:3
+40 SET AGELOW=$PIECE($GET(^ICPT(NEWIEN(1),10)),U)
IF AGELOW
SET $PIECE(^ICPT(NEWIEN(1),10),U)=$$AGECON(AGELOW)
+41 SET AGEHI=$PIECE($GET(^ICPT(NEWIEN(1),10)),U,2)
IF AGEHI
SET $PIECE(^ICPT(NEWIEN(1),10),U,2)=$$AGECON(AGEHI)
End DoDot:3
+42 IF VAXFIL=81.1
Begin DoDot:3
+43 SET CURPTR=$$GET1^DIQ(81.1,NEWIEN(1),.01,"I")
+44 SET FDA(VAXFIL,NEWIEN(1),3)=$GET(^XCSV(VAXLOC,"MAP",CURPTR))
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:3
+45 IF GLOBPATH[")"
SET DIK=$PIECE(GLOBPATH,")")_","
+46 IF '$TEST
SET DIK=GLOBPATH_"("
+47 SET DA=NEWIEN(1)
DO IX1^DIK
+48 KILL NEWIEN,DA,DIK
End DoDot:2
End DoDot:1
IF QUIT
QUIT
+49 QUIT
RPALL ;
+1 DO RP802
DO RP801
DO RP80
+2 QUIT
RP802 ;
+1 NEW IEN,SUBIEN,OVAL,NVAL
+2 SET IEN=0
FOR
SET IEN=$ORDER(^ICD(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+3 SET SUBIEN=0
FOR
SET SUBIEN=$ORDER(^ICD(IEN,66,SUBIEN))
IF 'SUBIEN
QUIT
Begin DoDot:2
+4 SET OVAL=$$GET1^DIQ(80.266,SUBIEN_","_IEN,.05,"I")
+5 IF 'OVAL
QUIT
+6 SET NVAL=$GET(^XCSV("ICD","MAP","B",OVAL))
+7 SET FDA(80.266,SUBIEN_","_IEN_",",.05)=NVAL
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
End DoDot:1
+8 QUIT
RP801 ;
+1 NEW IEN,DATA,LOOP,MDCPTR,NEWPTR,NEWDAT,VAL,NVAL,SIEN1,SIEN2,SIEN3,SIEN2PTR,SIEN3PTR,NIEN2PTR,NIEN3PTR,CNT
+2 SET IEN=0
FOR
SET IEN=$ORDER(^ICD0(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+3 ; Correct pointers in field 7 multiple
+4 KILL DATA,DATA71,NEWDAT
+5 MERGE DATA71=^ICD0(IEN,2)
+6 MERGE DATA=^ICD0(IEN,"MDC")
+7 SET LOOP=0
FOR
SET LOOP=$ORDER(DATA(LOOP))
IF 'LOOP
QUIT
Begin DoDot:2
+8 SET MDCPTR=$GET(DATA(LOOP,0))
SET NEWPTR=$GET(^XCSV("ICM","MAP","B",LOOP))
+9 SET NEWDAT(0)=DATA(0)
+10 IF 'NEWPTR
QUIT
+11 SET NEWDAT(NEWPTR,0)=NEWPTR
+12 FOR I=1:1:6
Begin DoDot:3
+13 IF '$DATA(DATA(LOOP,"DRG"))
QUIT
+14 SET VAL=$PIECE(DATA(LOOP,"DRG"),U,I)
IF VAL=""
QUIT
+15 SET NVAL=$GET(^XCSV("ICD","MAP","B",VAL))
+16 IF NVAL=""
QUIT
+17 SET $PIECE(NEWDAT(NEWPTR,"DRG"),U,I)=NVAL
End DoDot:3
End DoDot:2
+18 SET Z2=$ORDER(^ICD0(IEN,"MDC",""),-1)
+19 SET CNT=0
+20 SET CNTLP=0
FOR
SET CNTLP=$ORDER(^ICD0(IEN,"MDC",CNTLP))
IF 'CNTLP
QUIT
Begin DoDot:2
+21 SET CNT=CNT+1
End DoDot:2
+22 IF $DATA(^ICD0(IEN,"MDC"))
SET $PIECE(NEWDAT(0),U,4)=CNT
+23 ; Now handle field 66
+24 SET SIEN=0
FOR
SET SIEN=$ORDER(^ICD0(IEN,66,SIEN))
IF 'SIEN
QUIT
Begin DoDot:2
+25 FOR I=1:1:5
Begin DoDot:3
+26 IF '$DATA(^ICD0(IEN,66,SIEN,"DRG"))
QUIT
+27 SET VAL=$PIECE(^ICD0(IEN,66,SIEN,"DRG"),U,I)
IF VAL=""
QUIT
+28 SET NVAL=$GET(^XCSV("ICD","MAP","B",VAL))
+29 SET $PIECE(^ICD0(IEN,66,SIEN,"DRG"),U,I)=NVAL
End DoDot:3
+30 ; Now handle field 71 and all subfiles
End DoDot:2
+31 SET SIEN1=0
FOR
SET SIEN1=$ORDER(DATA71(SIEN1))
IF 'SIEN1
QUIT
Begin DoDot:2
+32 SET SIEN2=0
FOR
SET SIEN2=$ORDER(DATA71(SIEN1,1,SIEN2))
IF 'SIEN2
QUIT
Begin DoDot:3
+33 SET SIEN2PTR=$GET(DATA71(SIEN1,1,SIEN2,0))
+34 SET NIEN2PTR=$GET(^XCSV("ICM","MAP","B",SIEN2PTR))
+35 ; If the pointer values are the same, do not change anything.
+36 ;Q:NIEN2PTR=SIEN2PTR
+37 KILL DATA71(SIEN1,1,"B",SIEN2PTR,SIEN2)
+38 IF 'NIEN2PTR
KILL DATA71(SIEN1,1,SIEN2)
QUIT
+39 SET DATA71(SIEN1,1,SIEN2,0)=NIEN2PTR
+40 SET DATA71(SIEN1,1,"B",NIEN2PTR,SIEN2)=""
+41 SET SIEN3=0
FOR
SET SIEN3=$ORDER(DATA71(SIEN1,1,SIEN2,1,SIEN3))
IF 'SIEN3
QUIT
Begin DoDot:4
+42 SET SIEN3PTR=$GET(DATA71(SIEN1,1,SIEN2,1,SIEN3,0))
+43 SET NIEN3PTR=$GET(^XCSV("ICD","MAP","B",SIEN3PTR))
+44 IF 'NIEN3PTR
KILL DATA71(SIEN1,1,SIEN2,1,SIEN3)
QUIT
+45 IF SIEN3PTR=NIEN3PTR
QUIT
+46 SET DATA71(SIEN1,1,SIEN2,1,SIEN3,0)=NIEN3PTR
+47 KILL DATA71(SIEN1,1,SIEN2,1,"B",SIEN3PTR,SIEN3)
+48 SET DATA71(SIEN1,1,SIEN2,1,"B",NIEN3PTR,SIEN3)=""
End DoDot:4
End DoDot:3
End DoDot:2
+49 IF $DATA(^ICD0(IEN,"MDC"))
SET ($PIECE(NEWDAT(0),U,2),$PIECE(NEWDAT(0),U,3))=$ORDER(NEWDAT(""),-1)
+50 ; Merge updated array back into multiple.
+51 KILL ^ICD0(IEN,"MDC")
MERGE ^ICD0(IEN,"MDC")=NEWDAT
+52 KILL ^ICD0(IEN,2)
MERGE ^ICD0(IEN,2)=DATA71
End DoDot:1
+53 QUIT
RP80 ;
+1 NEW IEN,ZNODE,CNT,NPTR,P3,I,J,SIEN,NIEN,DATA,ODAT,NPTR,OPTR,SIEN2,VAL,NVAL,SSCNT
+2 SET IEN=0
FOR
SET IEN=$ORDER(^ICD9(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+3 FOR J="N","R"
Begin DoDot:2
+4 IF '$DATA(^ICD9(IEN,J))
QUIT
+5 IF '$ORDER(^ICD9(IEN,J,0))
QUIT
+6 SET ZNODE=$GET(^ICD9(IEN,J,0))
+7 SET ^TMP("BCSVUT",$JOB,0)=ZNODE
+8 SET (SIEN,CNT)=0
FOR
SET SIEN=$ORDER(^ICD9(IEN,J,SIEN))
IF 'SIEN
QUIT
Begin DoDot:3
+9 SET NPTR=$GET(^XCSV("ICD9","MAP","B",SIEN))
IF 'NPTR
QUIT
+10 SET CNT=CNT+1
+11 SET ^TMP("BCSVUT",$JOB,NPTR,0)=NPTR
SET ^TMP("BCSVUT",$JOB,"B",NPTR,NPTR)=""
End DoDot:3
+12 SET P3=$ORDER(^TMP("BCSVUT",$JOB,"B"),-1)
+13 IF $DATA(^ICD9(IEN,J))
SET $PIECE(^TMP("BCSVUT",$JOB,0),U,3)=P3
SET $PIECE(^TMP("BCSVUT",$JOB,0),U,4)=CNT
+14 KILL ^ICD9(IEN,J)
+15 MERGE ^ICD9(IEN,J)=^TMP("BCSVUT",$JOB)
+16 KILL ^TMP("BCSVUT",$JOB)
End DoDot:2
+17 SET SIEN=0
FOR
SET SIEN=$ORDER(^ICD9(IEN,2,SIEN))
IF 'SIEN
QUIT
Begin DoDot:2
+18 SET OPTR=$GET(^ICD9(IEN,2,SIEN,0))
+19 SET NPTR=$GET(^XCSV("ICD9","MAP","B",OPTR))
+20 IF NPTR=OPTR
QUIT
+21 IF NPTR=""
KILL ^ICD9(IEN,2,SIEN),^ICD9("ACC",IEN,OPTR)
QUIT
+22 SET ^ICD9(IEN,2,SIEN,0)=NPTR
+23 KILL ^ICD9("ACC",IEN,OPTR)
SET ^ICD9("ACC",IEN,NPTR)=""
End DoDot:2
+24 SET SSCNT=0
+25 SET SIEN=0
FOR
SET SIEN=$ORDER(^ICD9(IEN,2,SIEN))
IF 'SIEN
QUIT
Begin DoDot:2
+26 SET SSCNT=SSCNT+1
End DoDot:2
+27 IF $DATA(^ICD9(IEN,2))
SET $PIECE(^ICD9(IEN,2,0),U,3)=-$ORDER(^ICD9(IEN,2,""))
SET $PIECE(^ICD9(IEN,2,0),U,4)=$GET(SSCNT)
+28 ; codes not CC with
SET SIEN=0
FOR
SET SIEN=$ORDER(^ICD9("ACC",IEN,SIEN))
IF 'SIEN
QUIT
Begin DoDot:2
+29 SET NIEN=""
SET NIEN=$GET(^XCSV("ICD9","MAP","B",SIEN))
IF 'NIEN
KILL ^ICD9("ACC",IEN,SIEN)
+30 IF SIEN=NIEN
QUIT
+31 KILL ^ICD9("ACC",IEN,SIEN)
+32 IF NIEN
SET ^ICD9("ACC",IEN,NIEN)=""
End DoDot:2
+33 ; Now handle field 66 - Effective Date multiple
SET SIEN=0
FOR
SET SIEN=$ORDER(^ICD9(IEN,66,SIEN))
IF 'SIEN
QUIT
Begin DoDot:2
+34 FOR I=1:1:5
Begin DoDot:3
+35 SET VAL=$PIECE($GET(^ICD9(IEN,66,SIEN,"DRG")),U,I)
IF VAL=""
QUIT
+36 SET NVAL=$GET(^XCSV("ICD","MAP","B",VAL))
+37 SET $PIECE(^ICD9(IEN,66,SIEN,"DRG"),U,I)=NVAL
End DoDot:3
End DoDot:2
+38 ; Next we do the DRG GROUPER multiple #71
SET SIEN=0
FOR
SET SIEN=$ORDER(^ICD9(IEN,3,SIEN))
IF 'SIEN
QUIT
Begin DoDot:2
+39 SET ZNODE=$GET(^ICD9(IEN,3,SIEN,0))
+40 SET SIEN2=0
FOR
SET SIEN2=$ORDER(^ICD9(IEN,3,SIEN,1,SIEN2))
IF 'SIEN2
QUIT
Begin DoDot:3
+41 SET OPTR=$GET(^ICD9(IEN,3,SIEN,1,SIEN2,0))
IF 'OPTR
QUIT
+42 SET NPTR=$GET(^XCSV("ICD","MAP","B",OPTR))
+43 IF OPTR=NPTR
QUIT
+44 IF 'NPTR
KILL ^ICD9(IEN,3,SIEN,1,"B",OPTR,SIEN2)
QUIT
+45 SET ^ICD9(IEN,3,SIEN,1,SIEN2,0)=NPTR
+46 KILL ^ICD9(IEN,3,SIEN,1,"B",OPTR,SIEN2)
+47 SET ^ICD9(IEN,3,SIEN,1,"B",NPTR,SIEN2)=""
End DoDot:3
End DoDot:2
+48 ; Now do the DRG GROUPER multiple #72
SET SIEN=0
FOR
SET SIEN=$ORDER(^ICD9(IEN,4,SIEN))
IF 'SIEN
QUIT
+49 SET ODAT=$GET(^ICD9(IEN,4,SIEN,0))
+50 SET OPTR=$PIECE(ODAT,U,2)
+51 SET NPTR=$GET(^XCSV("ICM","MAP","B",OPTR))
+52 SET $PIECE(^ICD9(IEN,4,SIEN,0),U,2)=NPTR
End DoDot:1
+53 QUIT
