source: WorldVistAEHR/trunk/r/ONCOLOGY-ONC/ONCOUK.m@ 1806

Last change on this file since 1806 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.8 KB
Line 
1ONCOUK ;WISC/MLH - ONCOLOGY UTILITY - CROSS REFERENCES ;7/1/93 17:44
2 ;;2.11;ONCOLOGY;**5**;Mar 07, 1995
3 ;
4RX ;Reindex data files
5 ;Called by routine ONCOPOS
6 ;Called by option ONCO #SITE-REINDEX DATA FILES
7 W !!,"This option will reindex the ONCOLOGY PATIENT, ONCOLOGY PRIMARY and ONCOLOGY"
8 W !,"CONTACT files.",!
9 S DIR("A")="Are you sure you want to do this",DIR("B")="No",DIR(0)="Y"
10 D ^DIR Q:(Y=0)!(Y["^")!(Y="")
11 D RX1
12 I 'EX D RX2,RX3,RX4
13 QUIT
14 ;
15RX1 S EX=0 D XRF1 Q
16RX2 S ONCORX=1 D XRF2 Q ; Reindex 165.5 - inhibit writing
17RX3 D XRF3 Q ; Reindex 165
18RX4 D XRF4 Q ; Reindex 160.1
19 ;
20XRF1 ;REINDEX 160
21 I '$D(NW) W !!!,?15,"Re-indexing ONCOLOGY PATIENT File (#160)..."
22 F I="APC","ACP","AD","AS","ADX","AFS","ASM","B","C","CN","D" K ^ONCO(160,I)
23 F I="APC","ACP" K ^ONCO(165,I)
24 ;"F" CROSS REFERENCE
25 S XD0=0 F S XD0=$O(^ONCO(160,XD0)) Q:XD0'>0 F I="AA","B" K ^ONCO(160,XD0,"F",I)
26XRF ;CROSS REF MULTIPLE & UPDATE
27 I '$D(NW) W !!?10,"Reindexing Follow-up Multiple",!
28 L +^ONCO(160):1 I '$T S DIR("A")="Can't LOCK file #160...TRY AGAIN",DIR(0)="Y",DIR("B")="Yes" D ^DIR S EX=$S('Y:1,Y="^":1,1:0) Q:EX G XRF
29 S J=0,XD0=0 F S XD0=$O(^ONCO(160,XD0)) Q:XD0'>0 S J=J+1 W:'(J#10) "." D XD0
30 ;Reindex main
31MF L -^ONCO(160) S DIK="^ONCO(160," D IXALL^DIK
32 W !?10,"DONE re-indexing file #160" Q
33 ;
34XD0 ;ENTER WITH D0=XD0
35 S X=0 F S X=$O(^ONCO(160,XD0,"F",X)) Q:X'>0 S LC=$P(^(X,0),U),^ONCO(160,XD0,"F","AA",(9999999-LC),X)="",^ONCO(160,XD0,"F","B",LC,X)=""
36 ;last date contact
37 S FLC=$O(^ONCO(160,XD0,"F","B",0))
38LD S LLC=$O(^ONCO(160,XD0,"F","AA",0)) Q:LLC="" S I=$O(^(LLC,0)),LD=$G(^ONCO(160,XD0,"F",I,0)) Q:LD=""
39 S LC=$P(LD,U),VS=$P(LD,U,2),CS=$P(LD,U,3),FM=$P(LD,U,4),QS=$P(LD,U,5),NM=$P(LD,U,6) I VS="" S VS=1,$P(^ONCO(160,XD0,"F",I,0),U,2)=VS
40 I CS="" S CS=9,$P(^ONCO(160,XD0,"F",I,0),U,3)=CS
41 I FM="",FLC'=LLC S $P(^ONCO(160,XD0,"F",I,0),U,4)=0
42 I QS="" S $P(^ONCO(160,XD0,"F",I,0),U,5)=$S(VS=0:8,1:9)
43 S NM=$S(VS=0:9,NM="":0,1:NM),$P(^ONCO(160,XD0,"F",I,0),U,6)=NM
44 S FS=$S(NM<8:1,VS=0:0,1:0) I FS S X1=DT,X2=LC D ^%DTC I X>456.25 S FS=8
45 S $P(^ONCO(160,XD0,1),U)=VS,$P(^(1),U,7)=FS,$P(^(1),U,4)=$S(VS=0:9,1:0),$P(^(1),U,8)=$S(VS=0:LC,1:"") I 'FS S $P(^ONCO(160,XD0,1),U,2)="" Q
46NF S NF=$E(LC,1,3)+1_$E(LC,4,5)_"00",$P(^ONCO(160,XD0,1),U,2)=NF W:'(XD0#100) "*"
47 Q
48 ;
49XRF2 ;RE-INDEX FILE 165.5
50 W !!!?15,"Re-indexing ONCOLOGY PRIMARY File (#165.5)..." F I="APC","ACP" K ^ONCO(165,I)
51 F I="AA","AAY","AAY1","AC","ACAY","ACF","ACS","AD","ADX","AE","AF","AG","AG1","AGC","AH","AS","AS1","ASG1","ASG","ATB","ATC","ATH","ATO","ATP","ATS","ATX","AY","B","C","D","D1" K ^ONCO(165.5,I)
52 S DIK="^ONCO(165.5," D IXALL^DIK W !?10,"DONE Re-indexing file #165.5"
53 Q
54 ;
55XRF3 ;RE-INDEX FILE 165
56 W !!!?15,"Re-indexing ONCOLOGY CONTACT File (#165)..." F I="B","C","B1","B2","B3","B4" K ^ONCO(165,I) S DIK="^ONCO(165," D IXALL^DIK
57 W !?10,"DONE Re-indexing file #165"
58 Q
59 ;
60XRF4 ;160.1
61 W !!!?15,"Re-indexing ONCOLOGY SITE PARAMETERS File (#160.1)..."
62 S DIK="^ONCO(160.1," D IXALL^DIK
63 W !?10,"DONE Re-indexing file #160.1"
64 Q
65 ;
66KEY55 ; Assign new .01 fields to ONCOLOGY PRIMARY File (#165.5)
67 ; (based on topographies not histologies)
68 N ONCOPI S ONCOPI=0 ; primary file index
69 FOR S ONCOPI=$O(^ONCO(165.5,ONCOPI)) Q:ONCOPI'=+ONCOPI D
70 . N ONCOTOP S ONCOTOP=$P($G(^ONCO(165.5,ONCOPI,2)),U) ; ICDO topography
71 . IF ONCOTOP,$E(ONCOTOP,1,2)=67 D ; a valid topography code exists
72 .. N ONCOSITE S ONCOSITE=$P(^ONCO(164,ONCOTOP,0),U,13) ; new site group
73 .. IF $P(^ONCO(165.5,ONCOPI,0),U)'=ONCOSITE D ; change it
74 ... N DIE S DIE="^ONCO(165.5," ; file to change
75 ... N DR S DR=".01///^S X=+ONCOSITE" ; field to change
76 ... N DA S DA=ONCOPI ; entry # to edit
77 ... D ^DIE ; change the entry
78 ... W:$D(WRTFLG) "." ;DA,?10,ONCOTOP,?20,ONCOSITE,!
79 ... Q
80 .. ;END IF
81 .. ;
82 .. Q
83 . ;END IF
84 . ;
85 . Q
86 ;END FOR
87 ;
88 QUIT
Note: See TracBrowser for help on using the repository browser.