VistA-FOIAVistA/r/ONCOLOGY-ONC/ONCPREMR.m

102 lines
4.1 KiB
Mathematica

ONCPREMR ;HIRMFO/RTK-PRE-INSTALL ROUTINE CONTINUED ONC*2.11*13 09/10/97
;;2.11;ONCOLOGY;**13**;Mar 07, 1995
;
; Loop thru ICDO MORPHOLOGY (#164.1) file and find any duplicate entries
; of 9710/2 & 9710/3. Convert any pointers that point to these entries
; and then delete the duplicates entries.
;
W !!,"Checking for any duplicates in ICDO MORHOLOGY (#164.1) file..."
S MRBAD=""
F MR=0:0 S MR=$O(^ONCO(164.1,"B","MARGINAL ZONE LYMPHOMA, NOS IN",MR)) Q:MR'>0 I MR'=97102 S MRBAD=MRBAD_MR_"^"
F MR=0:0 S MR=$O(^ONCO(164.1,"B","MARGINAL ZONE LYMPHOMA, NOS",MR)) Q:MR'>0 I MR'=97103 S MRBAD=MRBAD_MR_"^"
I MRBAD="" G CHANGE ;if theres no duplicates, skip the conversion stuff
;
; Convert field #22 of file #165.5
;
S CT=0
W !?4,"Converting file #165.5 pointers..."
F PRIEN=0:0 S PRIEN=$O(^ONCO(165.5,PRIEN)) Q:PRIEN'>0 D
.S CT=CT+1 I CT#100=0 W "."
.I '$D(^ONCO(165.5,PRIEN,2)) Q
.S HIST=$P($G(^ONCO(165.5,PRIEN,2)),"^",3) I HIST="" Q
.I MRBAD[HIST D
..I $P($G(^ONCO(164.1,HIST,0)),"^",2)="9710/2" S $P(^ONCO(165.5,PRIEN,2),"^",3)=97102 Q
..I $P($G(^ONCO(164.1,HIST,0)),"^",2)="9710/3" S $P(^ONCO(165.5,PRIEN,2),"^",3)=97103 Q
..W !,"CANNOT CONVERT POINTER IN ENTRY NUMBER: ",PRIEN Q
.Q
;
; Convert field #64 of file #160
;
S CT=0
W !?4,"Converting file #160 pointers..."
F PTIEN=0:0 S PTIEN=$O(^ONCO(160,PTIEN)) Q:PTIEN'>0 D
.S CT=CT+1 I CT#100=0 W "."
.I '$D(^ONCO(160,PTIEN,2)) Q
.S MORPH=$P($G(^ONCO(160,PTIEN,2)),"^",10) I MORPH="" Q
.I MRBAD[MORPH D
..I $P($G(^ONCO(164.1,MORPH,0)),"^",2)="9710/2" S $P(^ONCO(160,PTIEN,2),"^",10)=97102 Q
..I $P($G(^ONCO(164.1,MORPH,0)),"^",2)="9710/3" S $P(^ONCO(160,PTIEN,2),"^",10)=97103 Q
..W !,"CANNOT CONVERT POINTER IN ENTRY NUMBER: ",PTIEN Q
.Q
;
; Convert field #70 of file #169.1
;
S CT=0
W !?4,"Converting file #169.1 pointers..."
F ICDIEN=0:0 S ICDIEN=$O(^ONCO(169.1,ICDIEN)) Q:ICDIEN'>0 D
.S CT=CT+1 I CT#100=0 W "."
.I '$D(^ONCO(169.1,ICDIEN,0)) Q
.S MRPH1=$P($G(^ONCO(169.1,ICDIEN,0)),"^",5) I MRPH1="" Q
.I MRBAD[MRPH1 D
..I $P($G(^ONCO(164.1,MRPH1,0)),"^",2)="9710/2" S $P(^ONCO(169.1,ICDIEN,0),"^",5)=97102 Q
..I $P($G(^ONCO(164.1,MRPH1,0)),"^",2)="9710/3" S $P(^ONCO(169.1,ICDIEN,0),"^",5)=97103 Q
..W !,"CANNOT CONVERT POINTER IN ENTRY NUMBER: ",ICDIEN Q
.Q
;
; Convert field #30 of file #164.1 (points to itself)
;
S CT=0
W !?4,"Converting file #164.1 pointers..."
F MRIEN=0:0 S MRIEN=$O(^ONCO(164.1,MRIEN)) Q:MRIEN'>0 D
.S CT=CT+1 I CT#100=0 W "."
.I '$D(^ONCO(164.1,MRIEN,0)) Q
.S TNCODE=$P($G(^ONCO(164.1,MRIEN,0)),"^",4) I TNCODE="" Q
.I MRBAD[TNCODE D
..I $P($G(^ONCO(164.1,TNCODE,0)),"^",2)="9710/2" S $P(^ONCO(164.1,MRIEN,0),"^",4)=97102 Q
..I $P($G(^ONCO(164.1,TNCODE,0)),"^",2)="9710/3" S $P(^ONCO(164.1,MRIEN,0),"^",4)=97103 Q
..W !,"CANNOT CONVERT POINTER IN ENTRY NUMBER: ",MRIEN Q
.Q
;
; Convert sub-field #.01 of field #20 (multiple) of file #164.2
;
S CT=0
W !?4,"Converting file #164.2 pointers..."
F STIEN=0:0 S STIEN=$O(^ONCO(164.2,STIEN)) Q:STIEN'>0 D
.S CT=CT+1 I CT#100=0 W "."
.I '$D(^ONCO(164.2,STIEN,"M",0)) Q
.F STMULT=0:0 S STMULT=$O(^ONCO(164.2,STIEN,"M",STMULT)) Q:STMULT'>0 D
..S STMORP=$P($G(^ONCO(164.2,STIEN,"M",STMULT,0)),"^",1) I STMORP="" Q
..I MRBAD[STMORP D
...I $P($G(^ONCO(164.1,STMORP,0)),"^",2)="9710/2" S $P(^ONCO(164.2,STIEN,"M",STMULT,0),"^",1)=97102 Q
...I $P($G(^ONCO(164.1,STMORP,0)),"^",2)="9710/3" S $P(^ONCO(164.2,STIEN,"M",STMULT,0),"^",1)=97103 Q
...W !,"CANNOT CONVERT POINTER IN ENTRY NUMBER: ",STIEN," SUBFIELD ",STMULT Q
..Q
.Q
;
; Delete the duplicates of MARGINAL ZONE LYMPHOMA, NOS & NOS IN SITU
;
S NUM=0 F S NUM=NUM+1,MRDA=$P(MRBAD,"^",NUM) Q:MRDA="" D
.S DIK="^ONCO(164.1,",DA=MRDA D ^DIK
.Q
;
CHANGE ; Correct NAME (#.01) field of entries #97102,#97103 in 164.1 file
; and correct CODE (#1) field of entry #86221 in 164.1 file
;
S DR=".01///MARGINAL ZONE LYMPHOMA, NOS IN SITU",DIE="^ONCO(164.1,",DA=97102 D ^DIE
S DR=".01///MARGINAL ZONE LYMPHOMA, NOS",DIE="^ONCO(164.1,",DA=97103 D ^DIE
S DR="1////8622/1",DIE="^ONCO(164.1,",DA=86221 D ^DIE
;
K CT,HIST,ICDIEN,MORPH,MR,MRBAD,MRDA,MRIEN,MRPH1,NUM,PRIEN,PTIEN
K STIEN,STMORP,STMULT,TNCODE
Q