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

ONCP36 ;HINES OIFO/GWB-POST-INSTALL ROUTINE FOR PATCH ONC*2.11*36
 ;;2.11;ONCOLOGY;**36**;Mar 07, 1995
 ;
 ;ROADS to FORDS conversion routine
 ;
 ;SEQUENCE NUMBER               (165.5,.06)
 ;
 ;STATE AT DX                   (165.5,16)
 ;
 ;PRIMARY PAYER AT DX           (165.5,18)
 ;
 ;STAGED BY (CLINICAL STAGE)    (165.5,19)
 ;STAGED BY (PATHOLOGIC STAGE)  (165.5,89)
 ;
 ;SURGIGAL DX/STAGING PROC      (165.5,58.1)
 ;SURGICAL DX/STAGING @FAC      (165.5,58.4)
 ;
 ;SURGERY OF PRIMARY SITE (R)   (165.5,58.2)
 ;SURGERY OF PRIMARY @FAC (R)   (165.5,50.2)
 ;SURGERY OF PRIMARY SITE       (165.51,.04)
 ;
 ;SURGICAL MARGINS              (165.5,59)
 ;
 ;SCOPE OF LYMPH NODE SURGERY   (165.5,138)
 ;SCOPE OF LN SURGERY @FAC (R)  (165.5,138.1)
 ;SCOPE OF LYMPH NODE SURGERY   (165.51,35)
 ;
 ;SURGICAL PROC/OTHER SITE      (165.5,139)
 ;SURGICAL PROC/OTHER SITE @FAC (165.5,139.1)
 ;SURGICAL PROC/OTHER SITE      (165.51,36)
 ;
 ;REASON FOR NO SURGERY         (165.5,58)
 ;
 ;REGIONAL TREATMENT MODALITY   (165.5,363)
 ;
 ;CHEMOTHERAPY                  (165.5,53.2)
 ;CHEMOTHERAPY @FAC             (165.5,53.3)
 ;
 ;HORMONE THERAPY               (165.5,54.2)
 ;HORMONE THERAPY @FAC          (165.5,54.3)
 ;
 ;IMMUNOTHERAPY                 (165.5,55.2)
 ;IMMUNOTHERAPY @FAC            (165.5,55.3)
 ;
 ;TYPE OF FIRST RECURRENCE      (165.5,71)
 ;
 ;Create ROADS TO FORDS in CONVERSION FLAGS (165.55) file
 I '$D(^ONCO(165.55,"B","ROADS TO FORDS")) D
 .K DD,DO
 .S DIC="^ONCO(165.55,",DIC(0)="L"
 .S X="ROADS TO FORDS"
 .D FILE^DICN
 ;
 I $P(^ONCO(165.55,1,0),U,2)="Y" Q  ;ROADS TO FORDS CONVERSION FLAG
 S DIE="^ONCO(165.5,"
 S DR=".06///^S X=NEWNUM"
 S IEN=0
 F CNT=1:1 S IEN=$O(^ONCO(165.5,IEN)) Q:IEN'>0  D  W:CNT#100=0 "."
 .S PAT=$P($G(^ONCO(165.5,IEN,0)),U,2) Q:PAT=""
 .S PRI=0,RBACNT=0
 .F  S PRI=$O(^ONCO(165.5,"C",PAT,PRI)) Q:PRI'>0  D
 ..S SEQNUM=$P($G(^ONCO(165.5,PRI,0)),U,6)
 ..I (SEQNUM?2A)!((SEQNUM>59)&(SEQNUM<84)) S RBACNT=RBACNT+1
 .S SEQNUM=$P($G(^ONCO(165.5,IEN,0)),U,6) D
 ..S ACCNUM=$P(^ONCO(165.5,IEN,0),U,5) I ACCNUM="" Q
 ..I (SEQNUM="00")!(+SEQNUM>0) Q
 ..I SEQNUM="AA" S NEWNUM=$S(RBACNT>1:61,1:60) S DA=IEN D ^DIE Q
 ..I SEQNUM="BB" S NEWNUM=62 S DA=IEN D ^DIE Q
 ..I SEQNUM="CC" S NEWNUM=63 S DA=IEN D ^DIE Q
 ..I SEQNUM="DD" S NEWNUM=64 S DA=IEN D ^DIE Q
 ..I SEQNUM="EE" S NEWNUM=65 S DA=IEN D ^DIE Q
 ..I SEQNUM="FF" S NEWNUM=66 S DA=IEN D ^DIE Q
 ..I SEQNUM="GG" S NEWNUM=67 S DA=IEN D ^DIE Q
 ..I SEQNUM="HH" S NEWNUM=68 S DA=IEN D ^DIE Q
 ..I SEQNUM="II" S NEWNUM=69 S DA=IEN D ^DIE Q
 ..I SEQNUM="JJ" S NEWNUM=70 S DA=IEN D ^DIE Q
 ..I SEQNUM="KK" S NEWNUM=71 S DA=IEN D ^DIE Q
 ..I SEQNUM="LL" S NEWNUM=72 S DA=IEN D ^DIE Q
 ..I SEQNUM="MM" S NEWNUM=73 S DA=IEN D ^DIE Q
 ..I SEQNUM="NN" S NEWNUM=74 S DA=IEN D ^DIE Q
 ..I SEQNUM="OO" S NEWNUM=75 S DA=IEN D ^DIE Q
 ..I SEQNUM="PP" S NEWNUM=76 S DA=IEN D ^DIE Q
 ..I SEQNUM="QQ" S NEWNUM=77 S DA=IEN D ^DIE Q
 ..I SEQNUM="RR" S NEWNUM=78 S DA=IEN D ^DIE Q
 ..I SEQNUM="SS" S NEWNUM=79 S DA=IEN D ^DIE Q
 ..I SEQNUM="TT" S NEWNUM=80 S DA=IEN D ^DIE Q
 ..I SEQNUM="UU" S NEWNUM=81 S DA=IEN D ^DIE Q
 ..I SEQNUM="VV" S NEWNUM=81 S DA=IEN D ^DIE Q
 ..I SEQNUM="WW" S NEWNUM=83 S DA=IEN D ^DIE Q
 ..S NEWNUM=88 S DA=IEN D ^DIE Q
 .
 .S SAD=$$GET1^DIQ(165.5,IEN,16,"I") D
 ..I SAD=56 S $P(^ONCO(165.5,IEN,1),U,4)=59
 .
 .S PPD=$$GET1^DIQ(165.5,IEN,18,"I") D
 ..I PPD=1 S $P(^ONCO(165.5,IEN,1),U,11)=2 Q
 ..I PPD=19 S $P(^ONCO(165.5,IEN,1),U,11)=4 Q
 ..I PPD=6 S $P(^ONCO(165.5,IEN,1),U,11)=5 Q
 ..I PPD=7 S $P(^ONCO(165.5,IEN,1),U,11)=5 Q
 ..I PPD=8 S $P(^ONCO(165.5,IEN,1),U,11)=9 Q
 ..I PPD=10 S $P(^ONCO(165.5,IEN,1),U,11)=20 Q
 ..I PPD=11 S $P(^ONCO(165.5,IEN,1),U,11)=23 Q
 ..I PPD=12 S $P(^ONCO(165.5,IEN,1),U,11)=23 Q
 ..I PPD=13 S $P(^ONCO(165.5,IEN,1),U,11)=24 Q
 ..I PPD=14 S $P(^ONCO(165.5,IEN,1),U,11)=26 Q
 ..I PPD=15 S $P(^ONCO(165.5,IEN,1),U,11)=27 Q
 ..I PPD=16 S $P(^ONCO(165.5,IEN,1),U,11)=28 Q
 ..I PPD=17 S $P(^ONCO(165.5,IEN,1),U,11)=29 Q
 ..I PPD=18 S $P(^ONCO(165.5,IEN,1),U,11)=29 Q
 .
 .S SBCS=$P($G(^ONCO(165.5,IEN,3)),U,32)
 .S SBPS=$P($G(^ONCO(165.5,IEN,2.1)),U,5)
 .D  S $P(^ONCO(165.5,IEN,27),U,5)="Y"
 ..I $P($G(^ONCO(165.5,IEN,27)),U,5)="Y" Q
 ..I SBCS=7 S $P(^ONCO(165.5,IEN,3),U,32)=0
 ..I SBCS=8 S $P(^ONCO(165.5,IEN,3),U,32)=9
 ..I SBCS=3 S $P(^ONCO(165.5,IEN,3),U,32)=4
 ..I SBCS=4 S $P(^ONCO(165.5,IEN,3),U,32)=3
 ..I SBPS=7 S $P(^ONCO(165.5,IEN,2.1),U,5)=0
 ..I SBPS=8 S $P(^ONCO(165.5,IEN,2.1),U,5)=9
 ..I SBPS=3 S $P(^ONCO(165.5,IEN,2.1),U,5)=4
 ..I SBPS=4 S $P(^ONCO(165.5,IEN,2.1),U,5)=3
 .
 .S SDSP=$$GET1^DIQ(165.5,IEN,58.1,"I") D
 ..I $L(SDSP)=1 S SDSP="0"_SDSP,$P(^ONCO(165.5,IEN,3),U,27)=SDSP
 ..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
 ..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
 ..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
 .S SDSPAF=$$GET1^DIQ(165.5,IEN,58.4,"I") D
 ..I $L(SDSPAF)=1 S SDSPAF="0"_SDSPAF,$P(^ONCO(165.5,IEN,3.1),U,5)=SDSPAF
 ..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
 ..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
 ..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
 .D ^ONCP36A
 .D ^ONCP36B
 .D ^ONCP36C
 .D ^ONCP36D
 .D ^ONCP36E
 .D ^ONCP36F
 ;
KILL S $P(^ONCO(165.55,1,0),U,2)="Y"
 K CNT,DATEDX,DIE,DA,DR,FORDS,FORDSAF,IEN,PAT,PRI,RBACNT,TOP
 K SEQNUM,ACCNUM,NEWNUM,PPD,SBCS,SBPS,SDSP,SDSPAF
 K SPP,SPPAF,RR,SLN,SLNAF,NNE,NNEAF,SM,SCP,SCPAF,SPO,SPOAF,RFNS,RTM
 K SUB,SUBTX,SUBRR,SUBSLN,SUBNNE,SUBCT,SUBHT,SUBIT
 K CMX,CMXAF,RFNC,HT,HTAF,RFNHT,IT,ITAF,HTEP,H,HIST,HIST2,HIST3
 Q