source: FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCP36.m@ 1722

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

initial load of FOIAVistA 6/30/08 version
File size: 5.8 KB
Line 
1ONCP36 ;HINES OIFO/GWB-POST-INSTALL ROUTINE FOR PATCH ONC*2.11*36
2 ;;2.11;ONCOLOGY;**36**;Mar 07, 1995
3 ;
4 ;ROADS to FORDS conversion routine
5 ;
6 ;SEQUENCE NUMBER (165.5,.06)
7 ;
8 ;STATE AT DX (165.5,16)
9 ;
10 ;PRIMARY PAYER AT DX (165.5,18)
11 ;
12 ;STAGED BY (CLINICAL STAGE) (165.5,19)
13 ;STAGED BY (PATHOLOGIC STAGE) (165.5,89)
14 ;
15 ;SURGIGAL DX/STAGING PROC (165.5,58.1)
16 ;SURGICAL DX/STAGING @FAC (165.5,58.4)
17 ;
18 ;SURGERY OF PRIMARY SITE (R) (165.5,58.2)
19 ;SURGERY OF PRIMARY @FAC (R) (165.5,50.2)
20 ;SURGERY OF PRIMARY SITE (165.51,.04)
21 ;
22 ;SURGICAL MARGINS (165.5,59)
23 ;
24 ;SCOPE OF LYMPH NODE SURGERY (165.5,138)
25 ;SCOPE OF LN SURGERY @FAC (R) (165.5,138.1)
26 ;SCOPE OF LYMPH NODE SURGERY (165.51,35)
27 ;
28 ;SURGICAL PROC/OTHER SITE (165.5,139)
29 ;SURGICAL PROC/OTHER SITE @FAC (165.5,139.1)
30 ;SURGICAL PROC/OTHER SITE (165.51,36)
31 ;
32 ;REASON FOR NO SURGERY (165.5,58)
33 ;
34 ;REGIONAL TREATMENT MODALITY (165.5,363)
35 ;
36 ;CHEMOTHERAPY (165.5,53.2)
37 ;CHEMOTHERAPY @FAC (165.5,53.3)
38 ;
39 ;HORMONE THERAPY (165.5,54.2)
40 ;HORMONE THERAPY @FAC (165.5,54.3)
41 ;
42 ;IMMUNOTHERAPY (165.5,55.2)
43 ;IMMUNOTHERAPY @FAC (165.5,55.3)
44 ;
45 ;TYPE OF FIRST RECURRENCE (165.5,71)
46 ;
47 ;Create ROADS TO FORDS in CONVERSION FLAGS (165.55) file
48 I '$D(^ONCO(165.55,"B","ROADS TO FORDS")) D
49 .K DD,DO
50 .S DIC="^ONCO(165.55,",DIC(0)="L"
51 .S X="ROADS TO FORDS"
52 .D FILE^DICN
53 ;
54 I $P(^ONCO(165.55,1,0),U,2)="Y" Q ;ROADS TO FORDS CONVERSION FLAG
55 S DIE="^ONCO(165.5,"
56 S DR=".06///^S X=NEWNUM"
57 S IEN=0
58 F CNT=1:1 S IEN=$O(^ONCO(165.5,IEN)) Q:IEN'>0 D W:CNT#100=0 "."
59 .S PAT=$P($G(^ONCO(165.5,IEN,0)),U,2) Q:PAT=""
60 .S PRI=0,RBACNT=0
61 .F S PRI=$O(^ONCO(165.5,"C",PAT,PRI)) Q:PRI'>0 D
62 ..S SEQNUM=$P($G(^ONCO(165.5,PRI,0)),U,6)
63 ..I (SEQNUM?2A)!((SEQNUM>59)&(SEQNUM<84)) S RBACNT=RBACNT+1
64 .S SEQNUM=$P($G(^ONCO(165.5,IEN,0)),U,6) D
65 ..S ACCNUM=$P(^ONCO(165.5,IEN,0),U,5) I ACCNUM="" Q
66 ..I (SEQNUM="00")!(+SEQNUM>0) Q
67 ..I SEQNUM="AA" S NEWNUM=$S(RBACNT>1:61,1:60) S DA=IEN D ^DIE Q
68 ..I SEQNUM="BB" S NEWNUM=62 S DA=IEN D ^DIE Q
69 ..I SEQNUM="CC" S NEWNUM=63 S DA=IEN D ^DIE Q
70 ..I SEQNUM="DD" S NEWNUM=64 S DA=IEN D ^DIE Q
71 ..I SEQNUM="EE" S NEWNUM=65 S DA=IEN D ^DIE Q
72 ..I SEQNUM="FF" S NEWNUM=66 S DA=IEN D ^DIE Q
73 ..I SEQNUM="GG" S NEWNUM=67 S DA=IEN D ^DIE Q
74 ..I SEQNUM="HH" S NEWNUM=68 S DA=IEN D ^DIE Q
75 ..I SEQNUM="II" S NEWNUM=69 S DA=IEN D ^DIE Q
76 ..I SEQNUM="JJ" S NEWNUM=70 S DA=IEN D ^DIE Q
77 ..I SEQNUM="KK" S NEWNUM=71 S DA=IEN D ^DIE Q
78 ..I SEQNUM="LL" S NEWNUM=72 S DA=IEN D ^DIE Q
79 ..I SEQNUM="MM" S NEWNUM=73 S DA=IEN D ^DIE Q
80 ..I SEQNUM="NN" S NEWNUM=74 S DA=IEN D ^DIE Q
81 ..I SEQNUM="OO" S NEWNUM=75 S DA=IEN D ^DIE Q
82 ..I SEQNUM="PP" S NEWNUM=76 S DA=IEN D ^DIE Q
83 ..I SEQNUM="QQ" S NEWNUM=77 S DA=IEN D ^DIE Q
84 ..I SEQNUM="RR" S NEWNUM=78 S DA=IEN D ^DIE Q
85 ..I SEQNUM="SS" S NEWNUM=79 S DA=IEN D ^DIE Q
86 ..I SEQNUM="TT" S NEWNUM=80 S DA=IEN D ^DIE Q
87 ..I SEQNUM="UU" S NEWNUM=81 S DA=IEN D ^DIE Q
88 ..I SEQNUM="VV" S NEWNUM=81 S DA=IEN D ^DIE Q
89 ..I SEQNUM="WW" S NEWNUM=83 S DA=IEN D ^DIE Q
90 ..S NEWNUM=88 S DA=IEN D ^DIE Q
91 .
92 .S SAD=$$GET1^DIQ(165.5,IEN,16,"I") D
93 ..I SAD=56 S $P(^ONCO(165.5,IEN,1),U,4)=59
94 .
95 .S PPD=$$GET1^DIQ(165.5,IEN,18,"I") D
96 ..I PPD=1 S $P(^ONCO(165.5,IEN,1),U,11)=2 Q
97 ..I PPD=19 S $P(^ONCO(165.5,IEN,1),U,11)=4 Q
98 ..I PPD=6 S $P(^ONCO(165.5,IEN,1),U,11)=5 Q
99 ..I PPD=7 S $P(^ONCO(165.5,IEN,1),U,11)=5 Q
100 ..I PPD=8 S $P(^ONCO(165.5,IEN,1),U,11)=9 Q
101 ..I PPD=10 S $P(^ONCO(165.5,IEN,1),U,11)=20 Q
102 ..I PPD=11 S $P(^ONCO(165.5,IEN,1),U,11)=23 Q
103 ..I PPD=12 S $P(^ONCO(165.5,IEN,1),U,11)=23 Q
104 ..I PPD=13 S $P(^ONCO(165.5,IEN,1),U,11)=24 Q
105 ..I PPD=14 S $P(^ONCO(165.5,IEN,1),U,11)=26 Q
106 ..I PPD=15 S $P(^ONCO(165.5,IEN,1),U,11)=27 Q
107 ..I PPD=16 S $P(^ONCO(165.5,IEN,1),U,11)=28 Q
108 ..I PPD=17 S $P(^ONCO(165.5,IEN,1),U,11)=29 Q
109 ..I PPD=18 S $P(^ONCO(165.5,IEN,1),U,11)=29 Q
110 .
111 .S SBCS=$P($G(^ONCO(165.5,IEN,3)),U,32)
112 .S SBPS=$P($G(^ONCO(165.5,IEN,2.1)),U,5)
113 .D S $P(^ONCO(165.5,IEN,27),U,5)="Y"
114 ..I $P($G(^ONCO(165.5,IEN,27)),U,5)="Y" Q
115 ..I SBCS=7 S $P(^ONCO(165.5,IEN,3),U,32)=0
116 ..I SBCS=8 S $P(^ONCO(165.5,IEN,3),U,32)=9
117 ..I SBCS=3 S $P(^ONCO(165.5,IEN,3),U,32)=4
118 ..I SBCS=4 S $P(^ONCO(165.5,IEN,3),U,32)=3
119 ..I SBPS=7 S $P(^ONCO(165.5,IEN,2.1),U,5)=0
120 ..I SBPS=8 S $P(^ONCO(165.5,IEN,2.1),U,5)=9
121 ..I SBPS=3 S $P(^ONCO(165.5,IEN,2.1),U,5)=4
122 ..I SBPS=4 S $P(^ONCO(165.5,IEN,2.1),U,5)=3
123 .
124 .S SDSP=$$GET1^DIQ(165.5,IEN,58.1,"I") D
125 ..I $L(SDSP)=1 S SDSP="0"_SDSP,$P(^ONCO(165.5,IEN,3),U,27)=SDSP
126 ..I (SDSP="00")!(SDSP="01")!(SDSP="02")!(SDSP="03")!(SDSP="05")!(SDSP="06") S $P(^ONCO(165.5,IEN,3.1),U,26)=0 Q
127 ..I SDSP="04" S $P(^ONCO(165.5,IEN,3),U,27)="00",$P(^ONCO(165.5,IEN,3),U,31)="0000000",$P(^ONCO(165.5,IEN,3.1),U,26)=1 Q
128 ..I (SDSP="07")!(SDSP="08")!(SDSP="09") S $P(^ONCO(165.5,IEN,3),U,27)="09",$P(^ONCO(165.5,IEN,3),U,31)=9999999,$P(^ONCO(165.5,IEN,3.1),U,26)=9 Q
129 .S SDSPAF=$$GET1^DIQ(165.5,IEN,58.4,"I") D
130 ..I $L(SDSPAF)=1 S SDSPAF="0"_SDSPAF,$P(^ONCO(165.5,IEN,3.1),U,5)=SDSPAF
131 ..I (SDSPAF="00")!(SDSPAF="01")!(SDSPAF="02")!(SDSPAF="03")!(SDSPAF="05")!(SDSPAF="06") S $P(^ONCO(165.5,IEN,3.1),U,27)=0 Q
132 ..I SDSPAF="04" S $P(^ONCO(165.5,IEN,3.1),U,5)="00",$P(^ONCO(165.5,IEN,3.1),U,6)="0000000",$P(^ONCO(165.5,IEN,3.1),U,27)=1 Q
133 ..I (SDSPAF="07")!(SDSPAF="08")!(SDSPAF="09") S $P(^ONCO(165.5,IEN,3.1),U,5)="09",$P(^ONCO(165.5,IEN,3.1),U,6)=9999999,$P(^ONCO(165.5,IEN,3.1),U,27)=9 Q
134 .D ^ONCP36A
135 .D ^ONCP36B
136 .D ^ONCP36C
137 .D ^ONCP36D
138 .D ^ONCP36E
139 .D ^ONCP36F
140 ;
141KILL S $P(^ONCO(165.55,1,0),U,2)="Y"
142 K CNT,DATEDX,DIE,DA,DR,FORDS,FORDSAF,IEN,PAT,PRI,RBACNT,TOP
143 K SEQNUM,ACCNUM,NEWNUM,PPD,SBCS,SBPS,SDSP,SDSPAF
144 K SPP,SPPAF,RR,SLN,SLNAF,NNE,NNEAF,SM,SCP,SCPAF,SPO,SPOAF,RFNS,RTM
145 K SUB,SUBTX,SUBRR,SUBSLN,SUBNNE,SUBCT,SUBHT,SUBIT
146 K CMX,CMXAF,RFNC,HT,HTAF,RFNHT,IT,ITAF,HTEP,H,HIST,HIST2,HIST3
147 Q
Note: See TracBrowser for help on using the repository browser.