BCSVMD ;IHS/CIA/BWF - CSV Phase One Management of Data ;16-Apr-2010 09:58;JSH
;;1.0;BCSV;;APR 23, 2010;Build 44
;=================================================================
Q
INIT ;
S DLM="|",DDLM=";;"
Q
GET ;EP
; Gather data from fields that are to be moved and store for later use.\
; Variable XREFS is used for multiple fields that have a file level xref that needs to be re-indexed.
; Single fields with x-refs will be handled by file manager upon calling FILE^DIE
N QUIT,I,LINE,DATA,IHSFILE,IHSFLD,IHSROOT,VAFILE,VAFLD,AUMCSV,AUMDATA,DATAROOT,DEL,GLOBNODE,IHSDATA,MULT,NIHSFILE,DLM,DDLM
D INIT
S QUIT=0
F I=1:1 D Q:QUIT
.S MULT=0
.S LINE=$T(FLDLST+I)
.S DATA=$P(LINE,DDLM,2)
.I DATA="Q"!(DATA="") S QUIT=1 Q
.S IHSFILE=$P(DATA,DLM),OIHSFLD=$P(DATA,DLM,2),NIHSFLD=$P(DATA,DLM,3),NIHSFILE=$P(DATA,DLM,4),DEL=$P(DATA,DLM,5),XREFS=$P(DATA,DLM,6)
.I IHSFILE=""!(OIHSFLD="") S QUIT=1 Q
.; Quit if the field does not exist. This is done so filemanger will not look for fields that do not exist in site.
.I '$D(^DD(IHSFILE,OIHSFLD)) Q
.I NIHSFLD="",DEL'="D" Q
.D FIELD^DID(IHSFILE,OIHSFLD,"N","GLOBAL SUBSCRIPT LOCATION;MULTIPLE-VALUED","AUMDATA")
.I $G(AUMDATA("MULTIPLE-VALUED"))=1 S MULT=1
.S IHSROOT=$$ROOT^DILFD(IHSFILE)
.S LOOPSTR=IHSROOT_"AUMCSV)"
.S AUMCSV=0
.F S AUMCSV=$O(@LOOPSTR) Q:'AUMCSV D
..I MULT D Q
...S GLOBNODE=$P(AUMDATA("GLOBAL SUBSCRIPT LOCATION"),";")
...I 'GLOBNODE S GLOBNODE=""""_GLOBNODE_""""
...S DATAROOT=IHSROOT_AUMCSV_","_GLOBNODE_")"
...I DEL="D" K @DATAROOT Q
...S ^XTMP("AUMCSVMD","I",IHSFILE,NIHSFLD,AUMCSV,"MULT")=""
...S ^XTMP("AUMCSVMD","I",IHSFILE,NIHSFLD,AUMCSV,"XREFS")=XREFS
...M ^XTMP("AUMCSVMD",IHSFILE,NIHSFLD,AUMCSV)=@DATAROOT
...I DEL'="SD" K @DATAROOT
..I DEL="D" S FDA(IHSFILE,AUMCSV,OIHSFLD)="" D FILE^DIE(,"FDA") K FDA Q
..S IHSDATA=$$GET1^DIQ(IHSFILE,AUMCSV,OIHSFLD,"I")
..S FDA(IHSFILE,AUMCSV_",",OIHSFLD)="" D FILE^DIE(,"FDA") K FDA
..I NIHSFILE'="" S ^XTMP("AUMCSVMD",NIHSFILE,NIHSFLD,AUMCSV)=IHSDATA Q
..S ^XTMP("AUMCSVMD",IHSFILE,NIHSFLD,AUMCSV)=IHSDATA
..I DEL'="SD" S FDA(IHSFILE,AUMCSV,OIHSFLD)="" D FILE^DIE(,"FDA") K FDA
D DELDUM,ICDSET,CALDELDD
K QUIT,I,LINE,DATA,IHSFILE,NIHSFLD,OIHSFLD,IHSROOT
Q
PUT ;
; Put the data back into the correct field(s)
N IHSFILE,NEWFLD,IEN,CNT,SUBSCRPT,ROOT,FLDDATA,FL,XREF,NEWLOC
M ^DIC(81.3)=^AUTTCMOD
S IHSFILE=0
F S IHSFILE=$O(^XTMP("AUMCSVMD",IHSFILE)) Q:'IHSFILE D
.S NEWFLD=0
.F S NEWFLD=$O(^XTMP("AUMCSVMD",IHSFILE,NEWFLD)) Q:'NEWFLD D
..S IEN=0,CNT=0
..F S IEN=$O(^XTMP("AUMCSVMD",IHSFILE,NEWFLD,IEN)) Q:'IEN D
...I $D(^XTMP("AUMCSVMD","I",IHSFILE,NEWFLD,IEN,"MULT")) D Q
....S QUIT=0
....S XREFS=$G(^XTMP("AUMCSVMD","I",IHSFILE,NEWFLD,IEN,"XREFS"))
....D FIELD^DID(IHSFILE,NEWFLD,"N","GLOBAL SUBSCRIPT LOCATION","NEWLOC")
....S SUBSCRPT=$G(NEWLOC("GLOBAL SUBSCRIPT LOCATION")) Q:SUBSCRPT=""
....S SUBSCRPT=$P(SUBSCRPT,";"),SUBSCRPT=$C(34)_SUBSCRPT_$C(34)
....S ROOT=$$ROOT^DILFD(IHSFILE)_IEN_","_SUBSCRPT_")"
....M @ROOT=^XTMP("AUMCSVMD",IHSFILE,NEWFLD,IEN)
....Q:XREFS=""
....S DIK=$P(ROOT,")")_","
....F J=1:1 D Q:QUIT
.....S XREF=$P(XREFS,",",J)
.....I XREF="" S QUIT=1 Q
.....S DIK(1)=NEWFLD_"^"_XREF D ENALL^DIK
...S FLDDATA=$G(^XTMP("AUMCSVMD",IHSFILE,NEWFLD,IEN))
...S ROOT=$$ROOT^DILFD(IHSFILE)_IEN_")"
...S FDA(IHSFILE,IEN_",",NEWFLD)=$G(FLDDATA) D FILE^DIE(,"FDA") K FDA
I $D(FDA) D FILE^DIE(,"FDA") K FDA
F FL=80,80.1,80.2,80.3,81,81.1,81.3 D
.S ^DD(FL,.01,"DEL",.01,0)="I 1"
Q
SNCFLDS ;
; Synchronization of data for new fields added to IHS dictionaries
N QUIT,I,LINE,FILE,FLDLST,TRGT,XREFS,FILE,FIELD,ROOT,LOOPSTR,IEN,JQUIT,FIELD,MULT,DLM,DDLM
N VERINFO
D INIT
D UPDCODES^BCSVUT ; Moved to insure all data items are brought in before attempting to update the data
S QUIT=0
F I=1:1 D Q:QUIT
.S LINE=$$READ("IMPORT",I)
.I LINE="Q"!(LINE="") S QUIT=1 Q
.S FILE=$P(LINE,DLM)
.S FLDLST=$P(LINE,DLM,2)
.S TRGT=$P(LINE,DLM,3) I TRGT["(" S TRGT=$TR(TRGT,"(","|")
.S XREFS=$P(LINE,DLM,4)
.I FILE=""!(FLDLST="") S QUIT=1 Q
.I XREFS'="" D XREFS(XREFS)
.S ROOT=$$ROOT^DILFD(FILE)
.S LOOPSTR=ROOT_"IEN)"
.S IEN=0
.F S IEN=$O(@LOOPSTR) Q:'IEN D
..I $D(^XCSV(TRGT,"MAP","Z",IEN)) Q
..I FILE=80,$$GET1^DIQ(80,IEN,.01,"E")=.9999 S FUNC="VER"_$TR(FILE,".",""),INACT=1 D VERSION^BCSVUT(IEN,FUNC,INACT) Q
..I FILE=80.1,$$GET1^DIQ(80.1,IEN,.01,"E")=333333 S FUNC="VER"_$TR(FILE,".","") D VERSION^BCSVUT(IEN,FUNC) Q
..I '$D(^XCSV(TRGT,"MAP",IEN)) Q
..S MAPIEN=$P(^XCSV(TRGT,"MAP",IEN),"^",1)
..S JQUIT=0
..F J=1:1 D Q:JQUIT
...S FIELD=$P(FLDLST,";",J) I FIELD="" S JQUIT=1 Q
...; If the field is in a subfile, use the appropriate logic to get the data from ^XCSV and set into IHS files
...D FIELD^DID(FILE,FIELD,"N","MULTIPLE-VALUED","MULT")
...I $G(MULT("MULTIPLE-VALUED"))=1 D MULT(FILE,FIELD,TRGT,IEN,XREFS,MAPIEN) Q
...; If the field is not in a subfile, use the single field logic.
...D SINGLE(FILE,FIELD,TRGT,IEN,MAPIEN)
Q
SNCFLDS2 ;
; Synchronization of data for new fields added to IHS dictionaries
N QUIT,I,LINE,FILE,FLDLST,TRGT,XREFS,FILE,FIELD,ROOT,LOOPSTR,IEN,JQUIT,FIELD,DLM,DDLM,FUNC,J
D INIT
S QUIT=0
F I=1:1 D Q:QUIT
.S LINE=$$READ("UPDATE",I)
.I LINE="Q"!(LINE="") S QUIT=1 Q
.S FILE=$P(LINE,DLM)
.S FLDLST=$P(LINE,DLM,2)
.S TRGT=$P(LINE,DLM,3) I TRGT["(" S TRGT=$TR(TRGT,"(","|")
.I '$D(^XCSV("ICD9","REVMAP")) D INDEX
.S XREFS=$P(LINE,DLM,4)
.S FUNC=$P(LINE,DLM,5)
.I FILE=""!(FLDLST="") S QUIT=1 Q
.I XREFS'="" D XREFS(XREFS)
.S ROOT=$$ROOT^DILFD(FILE)
.S LOOPSTR=ROOT_"IEN)"
.S IEN=0
.F S IEN=$O(@LOOPSTR) Q:'IEN D
..I $D(^XCSV(TRGT,"MAP","Z",IEN)) Q
..I FILE=80,$$GET1^DIQ(80,IEN,.01,"E")=.9999 Q
..I $D(^XCSV(TRGT,"MAP",IEN)) D
...S MAPIEN=$P(^XCSV(TRGT,"MAP",IEN),"^",1)
...S JQUIT=0
...F J=1:1 D Q:JQUIT
....S FIELD=$P(FLDLST,";",J) I FIELD="" S JQUIT=1 Q
....; If the field is in a subfile, use the appropriate logic to get the data from ^XCSV and set into IHS files
....D FIELD^DID(FILE,FIELD,"N","MULTIPLE-VALUED","MULT")
....I $G(MULT("MULTIPLE-VALUED"))=1 D MULT(FILE,FIELD,TRGT,IEN,XREFS,MAPIEN) Q
....; If the field is not in a subfile, use the single field logic.
....D SINGLE(FILE,FIELD,TRGT,IEN,MAPIEN)
..E D VERSION^BCSVUT(IEN,FUNC)
D XREFUPD
;D UPDCODES^BCSVUT
D RPALL^BCSVUT
D FIX^BCSVP1
Q
BLDLST(FIL) ;
; Build a list of all files that are located in a subfile (these are the multiples)
N SUBFIL,FLD
S SUBFIL=0
F S SUBFIL=$O(^DD(FIL,"SB",SUBFIL)) Q:'SUBFIL D
.S FLD=0
.F S FLD=$O(^DD(FIL,"SB",SUBFIL,FLD)) Q:'FLD D
..S ^XTMP("AUMCSVMD","SB",FIL,FLD,SUBFIL)=""
Q
INDEX ;
N IHSIEN,VAIEN
S IHSIEN=0
F S IHSIEN=$O(^XCSV("ICD9","MAP",IHSIEN)) Q:'IHSIEN D
.S VAIEN=$P($G(^XCSV("ICD9","MAP",IHSIEN)),"^")
.S ^XCSV("ICD9","REVMAP",VAIEN)=IHSIEN
Q
READ(TAG,INCR) ;
N LINE
S LINE=$T(@TAG+INCR)
S DATA=$P(LINE,DDLM,2)
Q DATA
;
SINGLE(FILE,FLD,TRGT,IEN,MAPIEN) ;
; Input - FILE - IHS File Number
; FLD - IHS Field Number
;
N ROOT,DATA,VAIEN,DATALOC,NODE,NEWDAT,DATAPC,CSVDAT,IHSDAT,PIECE,FLDZERO,FLDTYP,TARGET
S ROOT=$$ROOT^DILFD(FILE)
S DATA=$G(^XCSV(TRGT,"MAP",MAPIEN))
S VAIEN=$P(DATA,"^")
D FIELD^DID(FILE,FLD,"N","GLOBAL SUBSCRIPT LOCATION","CSVDAT")
I '$D(CSVDAT) Q
S DATALOC=$G(CSVDAT("GLOBAL SUBSCRIPT LOCATION"))
S NODE=$P(DATALOC,";",1),PIECE=$P(DATALOC,";",2)
I NODE=""!(PIECE="") Q
S NEWDAT=$G(^XCSV(TRGT,"DATA",MAPIEN,NODE))
S DATAPC=$P(NEWDAT,"^",PIECE)
S IHSDAT=$$GET1^DIQ(FILE,IEN_",",FLD)
I IHSDAT="",NEWDAT="" Q
S FLDZERO=$G(^DD(FILE,FLD,0))
S FLDTYP=$P(FLDZERO,U,2)
I FLDTYP["P" D
.S TARGET=$P(FLDZERO,U,3),TARGET=$TR($P(TARGET,","),"(","|")
.I $P(TARGET,"|",2)="" S TARGET=$P(TARGET,"|")
.Q:DATAPC=""
.I $D(^XCSV(TARGET,"MAP","B",DATAPC)) S DATAPC=$G(^XCSV(TARGET,"MAP","B",DATAPC)) Q
.E S DATAPC=""
I FILE=80,((FLD=14)!(FLD=15)) S DATAPC=$$AGECON80^BCSVUT(DATAPC,IEN,FLD)
I FILE=81,((FLD=10.01)!(FLD=10.02)) S DATAPC=$$AGECON^BCSVUT(DATAPC)
S FDA(FILE,IEN_",",FLD)=DATAPC D FILE^DIE(,"FDA") K FDA
Q
MULT(FILE,FLD,TRGT,IEN,XREFS,MAPIEN) ;
N ROOT,SUBLOC,MERGELOC,DIK,XREFFLD,XREFNM,SUBLOC2,TEMPSUB
S ROOT=$$ROOT^DILFD(FILE)
D FIELD^DID(FILE,FLD,"N","GLOBAL SUBSCRIPT LOCATION","SUBLOC")
I '$D(SUBLOC) Q
S SUBLOC=$P(SUBLOC("GLOBAL SUBSCRIPT LOCATION"),";")
S TEMPSUB=SUBLOC
I 'SUBLOC D
.I SUBLOC=0 Q
.S SUBLOC2=$C(34)_SUBLOC_$C(34)
.S MERGELOC=ROOT_IEN_","_SUBLOC2_")"
I '$D(MERGELOC) S MERGELOC=ROOT_IEN_","_SUBLOC_")"
S DIK=ROOT_IEN_","_SUBLOC_",",DA(1)=IEN
I $D(XREFDATA(SUBLOC)) D
.S XREFFLD=0
.F S XREFFLD=$O(XREFDATA(SUBLOC,XREFFLD)) Q:'XREFFLD D
..S XREFNM=0
..F S XREFNM=$O(XREFDATA(SUBLOC,XREFFLD,XREFNM)) Q:XREFNM="" D
...S DIK(1)=XREFFLD_"^"_XREFNM D ENALL2^DIK
K @MERGELOC
M @MERGELOC=^XCSV(TRGT,"DATA",MAPIEN,SUBLOC)
I $D(XREFDATA(SUBLOC)) D
.S XREFFLD=0
.F S XREFFLD=$O(XREFDATA(SUBLOC,XREFFLD)) Q:'XREFFLD D
..S XREFNM=0
..F S XREFNM=$O(XREFDATA(SUBLOC,XREFFLD,XREFNM)) Q:XREFNM="" D
...S DIK(1)=XREFFLD_"^"_XREFNM D ENALL^DIK
Q
CLEAN(TRGT,IEN,XREFDATA,FIELD,MERGELOC,ROOT,SUBLOC) ;
N SUBIEN,CLOOPSTR,TEST,DATANODE,ROOTCHK,IHSPTR,VAPTR,XREFNM,XREFFLD
S SUBIEN=0
S CLOOPSTR=$P(MERGELOC,")"),CLOOPSTR=CLOOPSTR_",SUBIEN)"
I 'SUBLOC D
.I SUBLOC=0 Q
.S SUBLOC=$C(34)_SUBLOC_$C(34)
S TEST=ROOT_IEN_","_SUBLOC_")"
I '$D(@TEST) Q
F S SUBIEN=$O(@CLOOPSTR) Q:'SUBIEN D
.S DIK=ROOT_IEN_","_SUBLOC_",",DA(1)=SUBIEN
.S DATANODE=$P(CLOOPSTR,")"),DATANODE=DATANODE_",0)"
.S VAPTR=$G(@DATANODE)
.S ROOTCHK=ROOT_VAPTR_")"
.I '$D(^XCSV(TRGT,"REVMAP",VAPTR)) Q
.I '$D(@ROOTCHK)!('$D(^XCSV(TRGT,"REVMAP",VAPTR))) D
..I $D(XREFDATA(SUBLOC)) D
...S XREFFLD=0
...F S XREFFLD=$O(XREFDATA(SUBLOC,XREFFLD)) Q:'XREFFLD D
....K @CLOOPSTR
....S XREFNM=0
....F S XREFNM=$O(XREFDATA(SUBLOC,XREFFLD,XREFNM)) Q:XREFNM="" D
.....S DIK(1)=XREFFLD_"^"_XREFNM D EN2^DIK
.S IHSPTR=$G(^XCSV(TRGT,"REVMAP",VAPTR))
.I IHSPTR=VAPTR Q
.I IHSPTR'=VAPTR D Q
..I $D(XREFDATA(SUBLOC)) D
...S XREFFLD=0
...F S XREFFLD=$O(XREFDATA(SUBLOC,XREFFLD)) Q:'XREFFLD D
....S XREFNM=0
....F S XREFNM=$O(XREFDATA(SUBLOC,XREFFLD,XREFNM)) Q:XREFNM="" D
.....S DIK(1)=XREFFLD_"^"_XREFNM D EN2^DIK
..I FIELD=20 D Q
...K @DATANODE
...S ^ICD9(IEN,"N",IHSPTR,0)=IHSPTR
...I $D(XREFDATA(SUBLOC)) D
....S XREFFLD=0
....F S XREFFLD=$O(XREFDATA(SUBLOC,XREFFLD)) Q:'XREFFLD D
.....S XREFNM=0
.....F S XREFNM=$O(XREFDATA(SUBLOC,XREFFLD,XREFNM)) Q:XREFNM="" D
......S DIK(1)=XREFFLD_"^"_XREFNM D EN1^DIK
..S @DATANODE=IHSPTR
..I $D(XREFDATA(SUBLOC)) D
...S XREFFLD=0
...F S XREFFLD=$O(XREFDATA(SUBLOC,XREFFLD)) Q:'XREFFLD D
....S XREFNM=0
....F S XREFNM=$O(XREFDATA(SUBLOC,XREFFLD,XREFNM)) Q:XREFNM="" D
.....S DIK(1)=XREFFLD_"^"_XREFNM D EN1^DIK
Q
XREFS(XREFS) ;
N QUIT,DATA,I,LOC,FLD,JQUIT,J,FLDS,XREF
S QUIT=0
S ^XTMP("XREFS",XREFS)=""
F I=1:1 D Q:QUIT
.S DATA=$P(XREFS,";",I) I DATA="" S QUIT=1 Q
.S LOC=$P(DATA,","),FLDS=$P(DATA,",",2),XREF=$P(DATA,",",3)
.S JQUIT=0
.F J=1:1 D Q:JQUIT
..S FLD=$P(FLDS,"/",J) I FLD="" S JQUIT=1 Q
..S XREFDATA(LOC,FLD,XREF)=""
Q
DELDUM ;
N DA,DATA,NEWDAT
S DA(1)=0
F S DA(1)=$O(^ICD9(DA(1))) Q:'DA(1) D
.S DA=0
.F S DA=$O(^ICD9(DA(1),9999999.21,DA)) Q:'DA D
..I $P(^ICD9(DA(1),9999999.21,DA,0),"^",2)'="" S $P(^ICD9(DA(1),9999999.21,DA,0),"^",2)=""
Q
ICDSET ;
S ^ICD(541,0)="DRG541^20.041^1^99^17^1^^38.7"
S ^ICD(542,0)="DRG542^12.028^1^99^17^1^^27.5"
S ^ICD(543,0)="DRG543^4.457^1^99^1^1^^8.7"
S ^ICD("ADS","DRG541 ",3041001,541,1)=""
S ^ICD("ADS","DRG542 ",3041001,542,1)=""
S ^ICD("ADS","DRG543 ",3041001,543,1)=""
S ^ICD("B","DRG541",541)=""
S ^ICD("B","DRG542",542)=""
S ^ICD("B","DRG543",543)=""
Q
CALDELDD ;
M ^TMP("BCSVMD","DIC|81.1")=^DIC(81.1)
N FL F FL=80,80.1,80.2,80.3,81,81.1 D DELDD(FL)
M ^DIC(81.1)=^TMP("BCSVMD","DIC|81.1")
Q
DELDD(FILE) ;
N DIU
I '$G(FILE) Q
S DIU=FILE,DIU(0)="" D EN^DIU2
Q
XREFUPD ;
N DIK,IEN
K ^ICD9("AB")
S DIK="^ICD9(",DIK(1)=".01^AB" D ENALL^DIK
S DIK="^ICPT(",DIK(1)=".01^E^F^ACT" D ENALL^DIK
S DIK(1)=".01^M"
S IEN=0 F S IEN=$O(^DIC(81.3,IEN)) Q:'IEN D
.S DIK="^DIC(81.3,"_IEN_",10,",DA(1)=IEN
.D ENALL^DIK
Q
; Format for FLDLST - IHS FILE|OLD IHS FIELD|NEW IHS FIELD|NEW IHS FILE (optional)|DELETe (this is set to 'D' if we are only deleting the field, 'SD' to suppress deletion)
; Deletion is for fields that will only be deleted, suppressing deletion is reserved for file 9999999.88. This is to prevent the deletion of fields from this file,
; as they are being moved to 81.3, and should no longer be used. However, it is felt that the original file (9999999.88) should be left intact.
FLDLST ;
;;80|2100000|||D
;;80|2100002|||D
;;80.1|2100000|||D
;;80.1|2100002|||D
;;80.2|8|99999992|||D
;;81|6|9999999.05
;;81|7|9999999.06
;;81|8|9999999.07
;;81|4|9999999.1|||AI
;;81|66|||D
;;81|409.5|||D
;;81|9999999.03|||D
;;9999999.88|.03|9999999.01|81.3|SD
;;9999999.88|.04|9999999.02|81.3|SD
;;9999999.88|1|||D
;;Q
;
; List of fields being brought from the VA DD structure into IHS. This is the list of fields that will need
; to have their data moved from the VA files into the appropriate locations within the IHS files.
; FORMAT - IHSFILE|LIST OF FIELDS TO BE GATHERED FOR DATA INSERTION INTO IHS FILES FROM XCSV GLOBAL|XCSV ROOT|FIELDS ASSOC. WITH XREF (separated by /);XREF TO RE-INDEX|VERSIONED DATA LOCATION INFORMATION
IMPORT ;
;;80.1|12;20;66;67;68;71|ICD0|66,.01,B;66,.02,ACT;67,.01,AST;68,.01,ADS
;;80|14;15;16;66;67;68;71;72|ICD9|20,.01,B;30,.01,B;40,.01,ACC;66,.01,B;66,.02,ACT;67,.01,AST;68,.01,ADS
;;80.2|14;15;16;66;68;71;900|ICD|68,.01,ADS
;;81|6;7;8;10.01;10.02;10.03;50;61;62|ICPT|61,.01,AST;62,.01,ADS;50,.01,C
;;81.1|4;5;6|DIC(81.1|
;;81.3|.03;.04;5;7;8;10;50;60;61;62|DIC(81.3|61,.01,AST;62,.01,ASD
;;
;;Q
UPDATE ;
;;80.1|2;4;5;7;8;9.5;10;50;51;52;53;54;55;100|ICD0||VER801^BCSVUT
;;80|2;3;5;5.5;5.7;5.9;9.5;10;20;30;40;60;61;62;63;64;65;70;100;101;103|ICD9|"N",.01,B;"R",.01,B;2,.01,ACC|VER80^BCSVUT
;;80.2|.06;1;2;3;4;5;7;7.5;10;11;12;13;20;30|ICD||VER802^BCSVUT
;;81|2;3;5;60|ICPT||VER81^BCSVUT
;;81.1|2;3;100|DIC(81.1||VER811^BCSVUT
;;81.3|.02|DIC(81.3||VER813^BCSVUT
;;80.3|.001;1|ICM||VER803^BCSVUT
;;Q
Q
BCSVMD ;IHS/CIA/BWF - CSV Phase One Management of Data ;16-Apr-2010 09:58;JSH
+1 ;;1.0;BCSV;;APR 23, 2010;Build 44
+2 ;=================================================================
+3 QUIT
INIT ;
+1 SET DLM="|"
SET DDLM=";;"
+2 QUIT
GET ;EP
+1 ; Gather data from fields that are to be moved and store for later use.\
+2 ; Variable XREFS is used for multiple fields that have a file level xref that needs to be re-indexed.
+3 ; Single fields with x-refs will be handled by file manager upon calling FILE^DIE
+4 NEW QUIT,I,LINE,DATA,IHSFILE,IHSFLD,IHSROOT,VAFILE,VAFLD,AUMCSV,AUMDATA,DATAROOT,DEL,GLOBNODE,IHSDATA,MULT,NIHSFILE,DLM,DDLM
+5 DO INIT
+6 SET QUIT=0
+7 FOR I=1:1
Begin DoDot:1
+8 SET MULT=0
+9 SET LINE=$TEXT(FLDLST+I)
+10 SET DATA=$PIECE(LINE,DDLM,2)
+11 IF DATA="Q"!(DATA="")
SET QUIT=1
QUIT
+12 SET IHSFILE=$PIECE(DATA,DLM)
SET OIHSFLD=$PIECE(DATA,DLM,2)
SET NIHSFLD=$PIECE(DATA,DLM,3)
SET NIHSFILE=$PIECE(DATA,DLM,4)
SET DEL=$PIECE(DATA,DLM,5)
SET XREFS=$PIECE(DATA,DLM,6)
+13 IF IHSFILE=""!(OIHSFLD="")
SET QUIT=1
QUIT
+14 ; Quit if the field does not exist. This is done so filemanger will not look for fields that do not exist in site.
+15 IF '$DATA(^DD(IHSFILE,OIHSFLD))
QUIT
+16 IF NIHSFLD=""
IF DEL'="D"
QUIT
+17 DO FIELD^DID(IHSFILE,OIHSFLD,"N","GLOBAL SUBSCRIPT LOCATION;MULTIPLE-VALUED","AUMDATA")
+18 IF $GET(AUMDATA("MULTIPLE-VALUED"))=1
SET MULT=1
+19 SET IHSROOT=$$ROOT^DILFD(IHSFILE)
+20 SET LOOPSTR=IHSROOT_"AUMCSV)"
+21 SET AUMCSV=0
+22 FOR
SET AUMCSV=$ORDER(@LOOPSTR)
IF 'AUMCSV
QUIT
Begin DoDot:2
+23 IF MULT
Begin DoDot:3
+24 SET GLOBNODE=$PIECE(AUMDATA("GLOBAL SUBSCRIPT LOCATION"),";")
+25 IF 'GLOBNODE
SET GLOBNODE=""""_GLOBNODE_""""
+26 SET DATAROOT=IHSROOT_AUMCSV_","_GLOBNODE_")"
+27 IF DEL="D"
KILL @DATAROOT
QUIT
+28 SET ^XTMP("AUMCSVMD","I",IHSFILE,NIHSFLD,AUMCSV,"MULT")=""
+29 SET ^XTMP("AUMCSVMD","I",IHSFILE,NIHSFLD,AUMCSV,"XREFS")=XREFS
+30 MERGE ^XTMP("AUMCSVMD",IHSFILE,NIHSFLD,AUMCSV)=@DATAROOT
+31 IF DEL'="SD"
KILL @DATAROOT
End DoDot:3
QUIT
+32 IF DEL="D"
SET FDA(IHSFILE,AUMCSV,OIHSFLD)=""
DO FILE^DIE(,"FDA")
KILL FDA
QUIT
+33 SET IHSDATA=$$GET1^DIQ(IHSFILE,AUMCSV,OIHSFLD,"I")
+34 SET FDA(IHSFILE,AUMCSV_",",OIHSFLD)=""
DO FILE^DIE(,"FDA")
KILL FDA
+35 IF NIHSFILE'=""
SET ^XTMP("AUMCSVMD",NIHSFILE,NIHSFLD,AUMCSV)=IHSDATA
QUIT
+36 SET ^XTMP("AUMCSVMD",IHSFILE,NIHSFLD,AUMCSV)=IHSDATA
+37 IF DEL'="SD"
SET FDA(IHSFILE,AUMCSV,OIHSFLD)=""
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
End DoDot:1
IF QUIT
QUIT
+38 DO DELDUM
DO ICDSET
DO CALDELDD
+39 KILL QUIT,I,LINE,DATA,IHSFILE,NIHSFLD,OIHSFLD,IHSROOT
+40 QUIT
PUT ;
+1 ; Put the data back into the correct field(s)
+2 NEW IHSFILE,NEWFLD,IEN,CNT,SUBSCRPT,ROOT,FLDDATA,FL,XREF,NEWLOC
+3 MERGE ^DIC(81.3)=^AUTTCMOD
+4 SET IHSFILE=0
+5 FOR
SET IHSFILE=$ORDER(^XTMP("AUMCSVMD",IHSFILE))
IF 'IHSFILE
QUIT
Begin DoDot:1
+6 SET NEWFLD=0
+7 FOR
SET NEWFLD=$ORDER(^XTMP("AUMCSVMD",IHSFILE,NEWFLD))
IF 'NEWFLD
QUIT
Begin DoDot:2
+8 SET IEN=0
SET CNT=0
+9 FOR
SET IEN=$ORDER(^XTMP("AUMCSVMD",IHSFILE,NEWFLD,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+10 IF $DATA(^XTMP("AUMCSVMD","I",IHSFILE,NEWFLD,IEN,"MULT"))
Begin DoDot:4
+11 SET QUIT=0
+12 SET XREFS=$GET(^XTMP("AUMCSVMD","I",IHSFILE,NEWFLD,IEN,"XREFS"))
+13 DO FIELD^DID(IHSFILE,NEWFLD,"N","GLOBAL SUBSCRIPT LOCATION","NEWLOC")
+14 SET SUBSCRPT=$GET(NEWLOC("GLOBAL SUBSCRIPT LOCATION"))
IF SUBSCRPT=""
QUIT
+15 SET SUBSCRPT=$PIECE(SUBSCRPT,";")
SET SUBSCRPT=$CHAR(34)_SUBSCRPT_$CHAR(34)
+16 SET ROOT=$$ROOT^DILFD(IHSFILE)_IEN_","_SUBSCRPT_")"
+17 MERGE @ROOT=^XTMP("AUMCSVMD",IHSFILE,NEWFLD,IEN)
+18 IF XREFS=""
QUIT
+19 SET DIK=$PIECE(ROOT,")")_","
+20 FOR J=1:1
Begin DoDot:5
+21 SET XREF=$PIECE(XREFS,",",J)
+22 IF XREF=""
SET QUIT=1
QUIT
+23 SET DIK(1)=NEWFLD_"^"_XREF
DO ENALL^DIK
End DoDot:5
IF QUIT
QUIT
End DoDot:4
QUIT
+24 SET FLDDATA=$GET(^XTMP("AUMCSVMD",IHSFILE,NEWFLD,IEN))
+25 SET ROOT=$$ROOT^DILFD(IHSFILE)_IEN_")"
+26 SET FDA(IHSFILE,IEN_",",NEWFLD)=$GET(FLDDATA)
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:3
End DoDot:2
End DoDot:1
+27 IF $DATA(FDA)
DO FILE^DIE(,"FDA")
KILL FDA
+28 FOR FL=80,80.1,80.2,80.3,81,81.1,81.3
Begin DoDot:1
+29 SET ^DD(FL,.01,"DEL",.01,0)="I 1"
End DoDot:1
+30 QUIT
SNCFLDS ;
+1 ; Synchronization of data for new fields added to IHS dictionaries
+2 NEW QUIT,I,LINE,FILE,FLDLST,TRGT,XREFS,FILE,FIELD,ROOT,LOOPSTR,IEN,JQUIT,FIELD,MULT,DLM,DDLM
+3 NEW VERINFO
+4 DO INIT
+5 ; Moved to insure all data items are brought in before attempting to update the data
DO UPDCODES^BCSVUT
+6 SET QUIT=0
+7 FOR I=1:1
Begin DoDot:1
+8 SET LINE=$$READ("IMPORT",I)
+9 IF LINE="Q"!(LINE="")
SET QUIT=1
QUIT
+10 SET FILE=$PIECE(LINE,DLM)
+11 SET FLDLST=$PIECE(LINE,DLM,2)
+12 SET TRGT=$PIECE(LINE,DLM,3)
IF TRGT["("
SET TRGT=$TRANSLATE(TRGT,"(","|")
+13 SET XREFS=$PIECE(LINE,DLM,4)
+14 IF FILE=""!(FLDLST="")
SET QUIT=1
QUIT
+15 IF XREFS'=""
DO XREFS(XREFS)
+16 SET ROOT=$$ROOT^DILFD(FILE)
+17 SET LOOPSTR=ROOT_"IEN)"
+18 SET IEN=0
+19 FOR
SET IEN=$ORDER(@LOOPSTR)
IF 'IEN
QUIT
Begin DoDot:2
+20 IF $DATA(^XCSV(TRGT,"MAP","Z",IEN))
QUIT
+21 IF FILE=80
IF $$GET1^DIQ(80,IEN,.01,"E")=.9999
SET FUNC="VER"_$TRANSLATE(FILE,".","")
SET INACT=1
DO VERSION^BCSVUT(IEN,FUNC,INACT)
QUIT
+22 IF FILE=80.1
IF $$GET1^DIQ(80.1,IEN,.01,"E")=333333
SET FUNC="VER"_$TRANSLATE(FILE,".","")
DO VERSION^BCSVUT(IEN,FUNC)
QUIT
+23 IF '$DATA(^XCSV(TRGT,"MAP",IEN))
QUIT
+24 SET MAPIEN=$PIECE(^XCSV(TRGT,"MAP",IEN),"^",1)
+25 SET JQUIT=0
+26 FOR J=1:1
Begin DoDot:3
+27 SET FIELD=$PIECE(FLDLST,";",J)
IF FIELD=""
SET JQUIT=1
QUIT
+28 ; If the field is in a subfile, use the appropriate logic to get the data from ^XCSV and set into IHS files
+29 DO FIELD^DID(FILE,FIELD,"N","MULTIPLE-VALUED","MULT")
+30 IF $GET(MULT("MULTIPLE-VALUED"))=1
DO MULT(FILE,FIELD,TRGT,IEN,XREFS,MAPIEN)
QUIT
+31 ; If the field is not in a subfile, use the single field logic.
+32 DO SINGLE(FILE,FIELD,TRGT,IEN,MAPIEN)
End DoDot:3
IF JQUIT
QUIT
End DoDot:2
End DoDot:1
IF QUIT
QUIT
+33 QUIT
SNCFLDS2 ;
+1 ; Synchronization of data for new fields added to IHS dictionaries
+2 NEW QUIT,I,LINE,FILE,FLDLST,TRGT,XREFS,FILE,FIELD,ROOT,LOOPSTR,IEN,JQUIT,FIELD,DLM,DDLM,FUNC,J
+3 DO INIT
+4 SET QUIT=0
+5 FOR I=1:1
Begin DoDot:1
+6 SET LINE=$$READ("UPDATE",I)
+7 IF LINE="Q"!(LINE="")
SET QUIT=1
QUIT
+8 SET FILE=$PIECE(LINE,DLM)
+9 SET FLDLST=$PIECE(LINE,DLM,2)
+10 SET TRGT=$PIECE(LINE,DLM,3)
IF TRGT["("
SET TRGT=$TRANSLATE(TRGT,"(","|")
+11 IF '$DATA(^XCSV("ICD9","REVMAP"))
DO INDEX
+12 SET XREFS=$PIECE(LINE,DLM,4)
+13 SET FUNC=$PIECE(LINE,DLM,5)
+14 IF FILE=""!(FLDLST="")
SET QUIT=1
QUIT
+15 IF XREFS'=""
DO XREFS(XREFS)
+16 SET ROOT=$$ROOT^DILFD(FILE)
+17 SET LOOPSTR=ROOT_"IEN)"
+18 SET IEN=0
+19 FOR
SET IEN=$ORDER(@LOOPSTR)
IF 'IEN
QUIT
Begin DoDot:2
+20 IF $DATA(^XCSV(TRGT,"MAP","Z",IEN))
QUIT
+21 IF FILE=80
IF $$GET1^DIQ(80,IEN,.01,"E")=.9999
QUIT
+22 IF $DATA(^XCSV(TRGT,"MAP",IEN))
Begin DoDot:3
+23 SET MAPIEN=$PIECE(^XCSV(TRGT,"MAP",IEN),"^",1)
+24 SET JQUIT=0
+25 FOR J=1:1
Begin DoDot:4
+26 SET FIELD=$PIECE(FLDLST,";",J)
IF FIELD=""
SET JQUIT=1
QUIT
+27 ; If the field is in a subfile, use the appropriate logic to get the data from ^XCSV and set into IHS files
+28 DO FIELD^DID(FILE,FIELD,"N","MULTIPLE-VALUED","MULT")
+29 IF $GET(MULT("MULTIPLE-VALUED"))=1
DO MULT(FILE,FIELD,TRGT,IEN,XREFS,MAPIEN)
QUIT
+30 ; If the field is not in a subfile, use the single field logic.
+31 DO SINGLE(FILE,FIELD,TRGT,IEN,MAPIEN)
End DoDot:4
IF JQUIT
QUIT
End DoDot:3
+32 IF '$TEST
DO VERSION^BCSVUT(IEN,FUNC)
End DoDot:2
End DoDot:1
IF QUIT
QUIT
+33 DO XREFUPD
+34 ;D UPDCODES^BCSVUT
+35 DO RPALL^BCSVUT
+36 DO FIX^BCSVP1
+37 QUIT
BLDLST(FIL) ;
+1 ; Build a list of all files that are located in a subfile (these are the multiples)
+2 NEW SUBFIL,FLD
+3 SET SUBFIL=0
+4 FOR
SET SUBFIL=$ORDER(^DD(FIL,"SB",SUBFIL))
IF 'SUBFIL
QUIT
Begin DoDot:1
+5 SET FLD=0
+6 FOR
SET FLD=$ORDER(^DD(FIL,"SB",SUBFIL,FLD))
IF 'FLD
QUIT
Begin DoDot:2
+7 SET ^XTMP("AUMCSVMD","SB",FIL,FLD,SUBFIL)=""
End DoDot:2
End DoDot:1
+8 QUIT
INDEX ;
+1 NEW IHSIEN,VAIEN
+2 SET IHSIEN=0
+3 FOR
SET IHSIEN=$ORDER(^XCSV("ICD9","MAP",IHSIEN))
IF 'IHSIEN
QUIT
Begin DoDot:1
+4 SET VAIEN=$PIECE($GET(^XCSV("ICD9","MAP",IHSIEN)),"^")
+5 SET ^XCSV("ICD9","REVMAP",VAIEN)=IHSIEN
End DoDot:1
+6 QUIT
READ(TAG,INCR) ;
+1 NEW LINE
+2 SET LINE=$TEXT(@TAG+INCR)
+3 SET DATA=$PIECE(LINE,DDLM,2)
+4 QUIT DATA
+5 ;
SINGLE(FILE,FLD,TRGT,IEN,MAPIEN) ;
+1 ; Input - FILE - IHS File Number
+2 ; FLD - IHS Field Number
+3 ;
+4 NEW ROOT,DATA,VAIEN,DATALOC,NODE,NEWDAT,DATAPC,CSVDAT,IHSDAT,PIECE,FLDZERO,FLDTYP,TARGET
+5 SET ROOT=$$ROOT^DILFD(FILE)
+6 SET DATA=$GET(^XCSV(TRGT,"MAP",MAPIEN))
+7 SET VAIEN=$PIECE(DATA,"^")
+8 DO FIELD^DID(FILE,FLD,"N","GLOBAL SUBSCRIPT LOCATION","CSVDAT")
+9 IF '$DATA(CSVDAT)
QUIT
+10 SET DATALOC=$GET(CSVDAT("GLOBAL SUBSCRIPT LOCATION"))
+11 SET NODE=$PIECE(DATALOC,";",1)
SET PIECE=$PIECE(DATALOC,";",2)
+12 IF NODE=""!(PIECE="")
QUIT
+13 SET NEWDAT=$GET(^XCSV(TRGT,"DATA",MAPIEN,NODE))
+14 SET DATAPC=$PIECE(NEWDAT,"^",PIECE)
+15 SET IHSDAT=$$GET1^DIQ(FILE,IEN_",",FLD)
+16 IF IHSDAT=""
IF NEWDAT=""
QUIT
+17 SET FLDZERO=$GET(^DD(FILE,FLD,0))
+18 SET FLDTYP=$PIECE(FLDZERO,U,2)
+19 IF FLDTYP["P"
Begin DoDot:1
+20 SET TARGET=$PIECE(FLDZERO,U,3)
SET TARGET=$TRANSLATE($PIECE(TARGET,","),"(","|")
+21 IF $PIECE(TARGET,"|",2)=""
SET TARGET=$PIECE(TARGET,"|")
+22 IF DATAPC=""
QUIT
+23 IF $DATA(^XCSV(TARGET,"MAP","B",DATAPC))
SET DATAPC=$GET(^XCSV(TARGET,"MAP","B",DATAPC))
QUIT
+24 IF '$TEST
SET DATAPC=""
End DoDot:1
+25 IF FILE=80
IF ((FLD=14)!(FLD=15))
SET DATAPC=$$AGECON80^BCSVUT(DATAPC,IEN,FLD)
+26 IF FILE=81
IF ((FLD=10.01)!(FLD=10.02))
SET DATAPC=$$AGECON^BCSVUT(DATAPC)
+27 SET FDA(FILE,IEN_",",FLD)=DATAPC
DO FILE^DIE(,"FDA")
KILL FDA
+28 QUIT
MULT(FILE,FLD,TRGT,IEN,XREFS,MAPIEN) ;
+1 NEW ROOT,SUBLOC,MERGELOC,DIK,XREFFLD,XREFNM,SUBLOC2,TEMPSUB
+2 SET ROOT=$$ROOT^DILFD(FILE)
+3 DO FIELD^DID(FILE,FLD,"N","GLOBAL SUBSCRIPT LOCATION","SUBLOC")
+4 IF '$DATA(SUBLOC)
QUIT
+5 SET SUBLOC=$PIECE(SUBLOC("GLOBAL SUBSCRIPT LOCATION"),";")
+6 SET TEMPSUB=SUBLOC
+7 IF 'SUBLOC
Begin DoDot:1
+8 IF SUBLOC=0
QUIT
+9 SET SUBLOC2=$CHAR(34)_SUBLOC_$CHAR(34)
+10 SET MERGELOC=ROOT_IEN_","_SUBLOC2_")"
End DoDot:1
+11 IF '$DATA(MERGELOC)
SET MERGELOC=ROOT_IEN_","_SUBLOC_")"
+12 SET DIK=ROOT_IEN_","_SUBLOC_","
SET DA(1)=IEN
+13 IF $DATA(XREFDATA(SUBLOC))
Begin DoDot:1
+14 SET XREFFLD=0
+15 FOR
SET XREFFLD=$ORDER(XREFDATA(SUBLOC,XREFFLD))
IF 'XREFFLD
QUIT
Begin DoDot:2
+16 SET XREFNM=0
+17 FOR
SET XREFNM=$ORDER(XREFDATA(SUBLOC,XREFFLD,XREFNM))
IF XREFNM=""
QUIT
Begin DoDot:3
+18 SET DIK(1)=XREFFLD_"^"_XREFNM
DO ENALL2^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+19 KILL @MERGELOC
+20 MERGE @MERGELOC=^XCSV(TRGT,"DATA",MAPIEN,SUBLOC)
+21 IF $DATA(XREFDATA(SUBLOC))
Begin DoDot:1
+22 SET XREFFLD=0
+23 FOR
SET XREFFLD=$ORDER(XREFDATA(SUBLOC,XREFFLD))
IF 'XREFFLD
QUIT
Begin DoDot:2
+24 SET XREFNM=0
+25 FOR
SET XREFNM=$ORDER(XREFDATA(SUBLOC,XREFFLD,XREFNM))
IF XREFNM=""
QUIT
Begin DoDot:3
+26 SET DIK(1)=XREFFLD_"^"_XREFNM
DO ENALL^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
CLEAN(TRGT,IEN,XREFDATA,FIELD,MERGELOC,ROOT,SUBLOC) ;
+1 NEW SUBIEN,CLOOPSTR,TEST,DATANODE,ROOTCHK,IHSPTR,VAPTR,XREFNM,XREFFLD
+2 SET SUBIEN=0
+3 SET CLOOPSTR=$PIECE(MERGELOC,")")
SET CLOOPSTR=CLOOPSTR_",SUBIEN)"
+4 IF 'SUBLOC
Begin DoDot:1
+5 IF SUBLOC=0
QUIT
+6 SET SUBLOC=$CHAR(34)_SUBLOC_$CHAR(34)
End DoDot:1
+7 SET TEST=ROOT_IEN_","_SUBLOC_")"
+8 IF '$DATA(@TEST)
QUIT
+9 FOR
SET SUBIEN=$ORDER(@CLOOPSTR)
IF 'SUBIEN
QUIT
Begin DoDot:1
+10 SET DIK=ROOT_IEN_","_SUBLOC_","
SET DA(1)=SUBIEN
+11 SET DATANODE=$PIECE(CLOOPSTR,")")
SET DATANODE=DATANODE_",0)"
+12 SET VAPTR=$GET(@DATANODE)
+13 SET ROOTCHK=ROOT_VAPTR_")"
+14 IF '$DATA(^XCSV(TRGT,"REVMAP",VAPTR))
QUIT
+15 IF '$DATA(@ROOTCHK)!('$DATA(^XCSV(TRGT,"REVMAP",VAPTR)))
Begin DoDot:2
+16 IF $DATA(XREFDATA(SUBLOC))
Begin DoDot:3
+17 SET XREFFLD=0
+18 FOR
SET XREFFLD=$ORDER(XREFDATA(SUBLOC,XREFFLD))
IF 'XREFFLD
QUIT
Begin DoDot:4
+19 KILL @CLOOPSTR
+20 SET XREFNM=0
+21 FOR
SET XREFNM=$ORDER(XREFDATA(SUBLOC,XREFFLD,XREFNM))
IF XREFNM=""
QUIT
Begin DoDot:5
+22 SET DIK(1)=XREFFLD_"^"_XREFNM
DO EN2^DIK
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+23 SET IHSPTR=$GET(^XCSV(TRGT,"REVMAP",VAPTR))
+24 IF IHSPTR=VAPTR
QUIT
+25 IF IHSPTR'=VAPTR
Begin DoDot:2
+26 IF $DATA(XREFDATA(SUBLOC))
Begin DoDot:3
+27 SET XREFFLD=0
+28 FOR
SET XREFFLD=$ORDER(XREFDATA(SUBLOC,XREFFLD))
IF 'XREFFLD
QUIT
Begin DoDot:4
+29 SET XREFNM=0
+30 FOR
SET XREFNM=$ORDER(XREFDATA(SUBLOC,XREFFLD,XREFNM))
IF XREFNM=""
QUIT
Begin DoDot:5
+31 SET DIK(1)=XREFFLD_"^"_XREFNM
DO EN2^DIK
End DoDot:5
End DoDot:4
End DoDot:3
+32 IF FIELD=20
Begin DoDot:3
+33 KILL @DATANODE
+34 SET ^ICD9(IEN,"N",IHSPTR,0)=IHSPTR
+35 IF $DATA(XREFDATA(SUBLOC))
Begin DoDot:4
+36 SET XREFFLD=0
+37 FOR
SET XREFFLD=$ORDER(XREFDATA(SUBLOC,XREFFLD))
IF 'XREFFLD
QUIT
Begin DoDot:5
+38 SET XREFNM=0
+39 FOR
SET XREFNM=$ORDER(XREFDATA(SUBLOC,XREFFLD,XREFNM))
IF XREFNM=""
QUIT
Begin DoDot:6
+40 SET DIK(1)=XREFFLD_"^"_XREFNM
DO EN1^DIK
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
QUIT
+41 SET @DATANODE=IHSPTR
+42 IF $DATA(XREFDATA(SUBLOC))
Begin DoDot:3
+43 SET XREFFLD=0
+44 FOR
SET XREFFLD=$ORDER(XREFDATA(SUBLOC,XREFFLD))
IF 'XREFFLD
QUIT
Begin DoDot:4
+45 SET XREFNM=0
+46 FOR
SET XREFNM=$ORDER(XREFDATA(SUBLOC,XREFFLD,XREFNM))
IF XREFNM=""
QUIT
Begin DoDot:5
+47 SET DIK(1)=XREFFLD_"^"_XREFNM
DO EN1^DIK
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+48 QUIT
XREFS(XREFS) ;
+1 NEW QUIT,DATA,I,LOC,FLD,JQUIT,J,FLDS,XREF
+2 SET QUIT=0
+3 SET ^XTMP("XREFS",XREFS)=""
+4 FOR I=1:1
Begin DoDot:1
+5 SET DATA=$PIECE(XREFS,";",I)
IF DATA=""
SET QUIT=1
QUIT
+6 SET LOC=$PIECE(DATA,",")
SET FLDS=$PIECE(DATA,",",2)
SET XREF=$PIECE(DATA,",",3)
+7 SET JQUIT=0
+8 FOR J=1:1
Begin DoDot:2
+9 SET FLD=$PIECE(FLDS,"/",J)
IF FLD=""
SET JQUIT=1
QUIT
+10 SET XREFDATA(LOC,FLD,XREF)=""
End DoDot:2
IF JQUIT
QUIT
End DoDot:1
IF QUIT
QUIT
+11 QUIT
DELDUM ;
+1 NEW DA,DATA,NEWDAT
+2 SET DA(1)=0
+3 FOR
SET DA(1)=$ORDER(^ICD9(DA(1)))
IF 'DA(1)
QUIT
Begin DoDot:1
+4 SET DA=0
+5 FOR
SET DA=$ORDER(^ICD9(DA(1),9999999.21,DA))
IF 'DA
QUIT
Begin DoDot:2
+6 IF $PIECE(^ICD9(DA(1),9999999.21,DA,0),"^",2)'=""
SET $PIECE(^ICD9(DA(1),9999999.21,DA,0),"^",2)=""
End DoDot:2
End DoDot:1
+7 QUIT
ICDSET ;
+1 SET ^ICD(541,0)="DRG541^20.041^1^99^17^1^^38.7"
+2 SET ^ICD(542,0)="DRG542^12.028^1^99^17^1^^27.5"
+3 SET ^ICD(543,0)="DRG543^4.457^1^99^1^1^^8.7"
+4 SET ^ICD("ADS","DRG541 ",3041001,541,1)=""
+5 SET ^ICD("ADS","DRG542 ",3041001,542,1)=""
+6 SET ^ICD("ADS","DRG543 ",3041001,543,1)=""
+7 SET ^ICD("B","DRG541",541)=""
+8 SET ^ICD("B","DRG542",542)=""
+9 SET ^ICD("B","DRG543",543)=""
+10 QUIT
CALDELDD ;
+1 MERGE ^TMP("BCSVMD","DIC|81.1")=^DIC(81.1)
+2 NEW FL
FOR FL=80,80.1,80.2,80.3,81,81.1
DO DELDD(FL)
+3 MERGE ^DIC(81.1)=^TMP("BCSVMD","DIC|81.1")
+4 QUIT
DELDD(FILE) ;
+1 NEW DIU
+2 IF '$GET(FILE)
QUIT
+3 SET DIU=FILE
SET DIU(0)=""
DO EN^DIU2
+4 QUIT
XREFUPD ;
+1 NEW DIK,IEN
+2 KILL ^ICD9("AB")
+3 SET DIK="^ICD9("
SET DIK(1)=".01^AB"
DO ENALL^DIK
+4 SET DIK="^ICPT("
SET DIK(1)=".01^E^F^ACT"
DO ENALL^DIK
+5 SET DIK(1)=".01^M"
+6 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(81.3,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+7 SET DIK="^DIC(81.3,"_IEN_",10,"
SET DA(1)=IEN
+8 DO ENALL^DIK
End DoDot:1
+9 QUIT
+10 ; Format for FLDLST - IHS FILE|OLD IHS FIELD|NEW IHS FIELD|NEW IHS FILE (optional)|DELETe (this is set to 'D' if we are only deleting the field, 'SD' to suppress deletion)
+11 ; Deletion is for fields that will only be deleted, suppressing deletion is reserved for file 9999999.88. This is to prevent the deletion of fields from this file,
+12 ; as they are being moved to 81.3, and should no longer be used. However, it is felt that the original file (9999999.88) should be left intact.
FLDLST ;
+1 ;;80|2100000|||D
+2 ;;80|2100002|||D
+3 ;;80.1|2100000|||D
+4 ;;80.1|2100002|||D
+5 ;;80.2|8|99999992|||D
+6 ;;81|6|9999999.05
+7 ;;81|7|9999999.06
+8 ;;81|8|9999999.07
+9 ;;81|4|9999999.1|||AI
+10 ;;81|66|||D
+11 ;;81|409.5|||D
+12 ;;81|9999999.03|||D
+13 ;;9999999.88|.03|9999999.01|81.3|SD
+14 ;;9999999.88|.04|9999999.02|81.3|SD
+15 ;;9999999.88|1|||D
+16 ;;Q
+17 ;
+18 ; List of fields being brought from the VA DD structure into IHS. This is the list of fields that will need
+19 ; to have their data moved from the VA files into the appropriate locations within the IHS files.
+20 ; FORMAT - IHSFILE|LIST OF FIELDS TO BE GATHERED FOR DATA INSERTION INTO IHS FILES FROM XCSV GLOBAL|XCSV ROOT|FIELDS ASSOC. WITH XREF (separated by /);XREF TO RE-INDEX|VERSIONED DATA LOCATION INFORMATION
IMPORT ;
+1 ;;80.1|12;20;66;67;68;71|ICD0|66,.01,B;66,.02,ACT;67,.01,AST;68,.01,ADS
+2 ;;80|14;15;16;66;67;68;71;72|ICD9|20,.01,B;30,.01,B;40,.01,ACC;66,.01,B;66,.02,ACT;67,.01,AST;68,.01,ADS
+3 ;;80.2|14;15;16;66;68;71;900|ICD|68,.01,ADS
+4 ;;81|6;7;8;10.01;10.02;10.03;50;61;62|ICPT|61,.01,AST;62,.01,ADS;50,.01,C
+5 ;;81.1|4;5;6|DIC(81.1|
+6 ;;81.3|.03;.04;5;7;8;10;50;60;61;62|DIC(81.3|61,.01,AST;62,.01,ASD
+7 ;;
+8 ;;Q
UPDATE ;
+1 ;;80.1|2;4;5;7;8;9.5;10;50;51;52;53;54;55;100|ICD0||VER801^BCSVUT
+2 ;;80|2;3;5;5.5;5.7;5.9;9.5;10;20;30;40;60;61;62;63;64;65;70;100;101;103|ICD9|"N",.01,B;"R",.01,B;2,.01,ACC|VER80^BCSVUT
+3 ;;80.2|.06;1;2;3;4;5;7;7.5;10;11;12;13;20;30|ICD||VER802^BCSVUT
+4 ;;81|2;3;5;60|ICPT||VER81^BCSVUT
+5 ;;81.1|2;3;100|DIC(81.1||VER811^BCSVUT
+6 ;;81.3|.02|DIC(81.3||VER813^BCSVUT
+7 ;;80.3|.001;1|ICM||VER803^BCSVUT
+8 ;;Q
+9 QUIT
