source: FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCP36A.m@ 1635

ONCP36A ;HINES OIFO/GWB-POST-INSTALL ROUTINE FOR PATCH ONC*2.11*36
 ;;2.11;ONCOLOGY;**36**;Mar 07, 1995
 ;
 D  Q
 .S DATEDX=$P($G(^ONCO(165.5,IEN,0)),U,16)
 .S TOP=$P($G(^ONCO(165.5,IEN,2)),U,1)
 .S HIST2=$E($$GET1^DIQ(165.5,IEN,22,"I"),1,4) I HIST2="" S HIST2=2222
 .S HIST3=$E($$GET1^DIQ(165.5,IEN,22.1,"I"),1,4) I HIST3="" S HIST3=3333
 .S HIST(9720)=""
 .S HIST(9750)=""
 .F H=9760:1:9764 S HIST(H)=""
 .F H=9800:1:9820 S HIST(H)=""
 .S HIST(9826)=""
 .F H=9831:1:9897 S HIST(H)=""
 .F H=9910:1:9920 S HIST(H)=""
 .F H=9931:1:9964 S HIST(H)=""
 .F H=9980:1:9989 S HIST(H)=""
 .S SPP=$$RXPRI^ONCACDU2(IEN,58.2,"SPS")
 .S SPPAF=$$RXPRI^ONCACDU2(IEN,50.2,"SPS")
 .S SPPPNT=$P($G(^ONCO(165.5,IEN,3)),U,38)
 .S SPPAFPNT=$P($G(^ONCO(165.5,IEN,3.1)),U,7)
 .
 .K SUBTX
 .S SUB=0 F I=1:1 S SUB=$O(^ONCO(165.5,IEN,4,SUB)) Q:SUB'>0  D
 ..S SUBTX(SUB)=$$SUB^ONCACDU2(IEN,SUB+1,.04)
 ..S SUBRR=$$SUB^ONCACDU2(IEN,SUB+1,33)
 ..S $P(SUBTX(SUB),U,2)=SUBRR
 ..S $P(SUBTX(SUB),U,3)="X"
 ..S SUBSLN=$$SUB^ONCACDU2(IEN,SUB+1,35)
 ..S:SUBSLN'="" $P(SUBTX(SUB),U,3)=SUBSLN
 ..S SUBNNE=$$SUB^ONCACDU2(IEN,SUB+1,37)
 ..S $P(SUBTX(SUB),U,4)=SUBNNE
 ..S SUBSPO=$$SUB^ONCACDU2(IEN,SUB+1,36)
 ..S $P(SUBTX(SUB),U,5)=SUBSPO
 ..S SUBCT=$P(^ONCO(165.5,IEN,4,SUB,0),U,6)
 ..S $P(SUBTX(SUB),U,6)=SUBCT
 ..S SUBHT=$P(^ONCO(165.5,IEN,4,SUB,0),U,7)
 ..S $P(SUBTX(SUB),U,7)=SUBHT
 ..S SUBIT=$P(^ONCO(165.5,IEN,4,SUB,0),U,8)
 ..S $P(SUBTX(SUB),U,8)=SUBIT
 .
 .S SLN=$$RXPRI^ONCACDU2(IEN,138,"SC5")
 .S SLNAF=$$RXPRI^ONCACDU2(IEN,138.1,"SC5")
 .S NNE=$$GET1^DIQ(165.5,IEN,140,"I")
 .S NNEAF=$$GET1^DIQ(165.5,IEN,140.1,"I")
 .S RR=$$RXPRI^ONCACDU2(IEN,23,"RR5")
 .S SM=$$RXPRI^ONCACDU2(IEN,59,"SM5")
 .S SCP=$$RXPRI^ONCACDU2(IEN,138,"SC5")
 .S SCPAF=$$RXPRI^ONCACDU2(IEN,138.1,"SC5")
 .S SPO=$$RXPRI^ONCACDU2(IEN,139,"SO5")
 .S SPOAF=$$RXPRI^ONCACDU2(IEN,139.1,"SO5")
 .S RFNS=$$GET1^DIQ(165.5,IEN,58,"I")
 .S (FORDS,FORDSAF)=""
 .I DATEDX<2980000 D SPP Q
 .D
 ..I ($D(HIST(HIST2)))!($D(HIST(HIST3))) D  D SPP Q
 ...I SPP'="" S FORDS=1
 ...I SPPAF'="" S FORDSAF=1
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....I $P(SUBTX(SUB),U,1)'="" S FORDSUB=1
 ..
 ..I TOP>67078,TOP<67090 D  D SPP Q
 ...I SPP>49,SPP<53,RR>0,RR<4 S FORDS=33
 ...I SPPAF>49,SPPAF<53,RR>0,RR<4 S FORDSAF=33
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)>49,$P(SUBTX(SUB),U,1)<53,$P(SUBTX(SUB),U,2)>0,$P(SUBTX(SUB),U,2)<4 S FORDSUB=33
 ..
 ..I TOP>67149,TOP<67160 D  D SPP Q
 ...I (SPP=60)!(SPP=70) S FORDS=17
 ...I (SPPAF=60)!(SPPAF=70) S FORDSAF=17
 ...I SPP=61 S FORDS=18
 ...I SPPAF=61 S FORDSAF=18
 ...I SPP=62 S FORDS=19
 ...I SPPAF=62 S FORDSAF=19
 ...I SPP=63 S FORDS=20
 ...I SPPAF=63 S FORDSAF=20
 ...I SPP=64 S FORDS=21
 ...I SPPAF=64 S FORDSAF=21
 ...I SPP=65 S FORDS=22
 ...I SPPAF=65 S FORDSAF=22
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)=60 S FORDSUB=17 Q
 ....I $P(SUBTX(SUB),U,1)=70 S FORDSUB=17 Q
 ....I $P(SUBTX(SUB),U,1)=61 S FORDSUB=18 Q
 ....I $P(SUBTX(SUB),U,1)=62 S FORDSUB=19 Q
 ....I $P(SUBTX(SUB),U,1)=63 S FORDSUB=20 Q
 ....I $P(SUBTX(SUB),U,1)=64 S FORDSUB=21 Q
 ....I $P(SUBTX(SUB),U,1)=65 S FORDSUB=22 Q
 ..
 ..I TOP>67179,TOP<67190 D  D SPP Q
 ...I SPP=31 S FORDS=15
 ...I SPPAF=31 S FORDSAF=15
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)=31 S FORDSUB=15
 ..
 ..I TOP=67199 D  D SPP Q
 ...I SPP=51,RR>1,RR<6 S FORDS=25
 ...I SPPAF=51,RR>1,RR<6 S FORDSAF=25
 ...I SPP=60,RR>1,RR<6 S FORDS=28
 ...I SPPAF=60,RR>1,RR<6 S FORDSAF=28
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)=51,$P(SUBTX(SUB),U,2)>1,$P(SUBTX(SUB),U,2)<6 S FORDSUB=25 Q
 ....I $P(SUBTX(SUB),U,1)=60,$P(SUBTX(SUB),U,2)>1,$P(SUBTX(SUB),U,2)<6 S FORDSUB=28 Q
 ..
 ..I TOP>67209,TOP<67219 D  D SPP Q
 ...I $P($G(^ONCO(165.5,IEN,27)),U,3)="Y" Q
 ...I SPP=60,SLN>3,SLN<6 S FORDS=20
 ...I SPPAF=60,SLNAF>3,SLNAF<6 S FORDSAF=20
 ...I SPP=60,SLN=6 S FORDS=21
 ...I SPPAF=60,SLNAF=6 S FORDSAF=21
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)=60,$P(SUBTX(SUB),U,3)>3,$P(SUBTX(SUB),U,3)<6 S FORDSUB=20 Q
 ....I $P(SUBTX(SUB),U,1)=60,$P(SUBTX(SUB),U,3)=6 S FORDSUB=21 Q
 ..
 ..I TOP>67219,TOP<67222 D  D SPP Q
 ...I SPP=31 S FORDS=11
 ...I SPPAF=31 S FORDSAF=11
 ...I SPP=32 S FORDS=28
 ...I SPPAF=32 S FORDSAF=28
 ...I SPP=70 S FORDS=33
 ...I SPPAF=70 S FORDSAF=33
 ...I SPP=80 S FORDS=32
 ...I SPPAF=80 S FORDSAF=32
 ...I SPP=40 S FORDS=34
 ...I SPPAF=40 S FORDSAF=34
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)=31 S FORDSUB=11 Q
 ....I $P(SUBTX(SUB),U,1)=32 S FORDSUB=28 Q
 ....I $P(SUBTX(SUB),U,1)=70 S FORDSUB=33 Q
 ....I $P(SUBTX(SUB),U,1)=80 S FORDSUB=32 Q
 ....I $P(SUBTX(SUB),U,1)=40 S FORDSUB=34 Q
 ..
 ..I TOP>67249,TOP<67260 D  D SPP Q
 ...I SPP=10 S FORDS=13
 ...I SPPAF=10 S FORDSAF=13
 ...I SPP=20 S FORDS=14
 ...I SPPAF=20 S FORDSAF=14
 ...I SPP=50 S FORDS=15
 ...I SPPAF=50 S FORDSAF=15
 ...I SPP=51 S FORDS=16
 ...I SPPAF=51 S FORDSAF=16
 ...I SPP=52 S FORDS=17
 ...I SPPAF=52 S FORDSAF=17
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)=10 S FORDSUB=13 Q
 ....I $P(SUBTX(SUB),U,1)=20 S FORDSUB=14 Q
 ....I $P(SUBTX(SUB),U,1)=50 S FORDSUB=15 Q
 ....I $P(SUBTX(SUB),U,1)=51 S FORDSUB=16 Q
 ....I $P(SUBTX(SUB),U,1)=52 S FORDSUB=17 Q
 ..
 ..I TOP>67339,TOP<67350 D  D SPP Q
 ...I SPP>9,SPP<15 S FORDS=24
 ...I SPPAF>9,SPPAF<15 S FORDSAF=24
 ...I SPP>30,SPP<33 S FORDS=10
 ...I SPPAF>30,SPPAF<33 S FORDSAF=10
 ...I SPP=40 S FORDS=34
 ...I SPPAF=40 S FORDSAF=34
 ...I SPP>49,SPP<54 S FORDS=30
 ...I SPPAF>49,SPPAF<54 S FORDSAF=30
 ...I SPP=54 S FORDS=34
 ...I SPPAF=54 S FORDSAF=34
 ...I SPP=60 S FORDS=35
 ...I SPPAF=60 S FORDSAF=35
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)>9,$P(SUBTX(SUB),U,1)<15 S FORDSUB=24 Q
 ....I $P(SUBTX(SUB),U,1)>30,$P(SUBTX(SUB),U,1)<33 S FORDSUB=10 Q
 ....I $P(SUBTX(SUB),U,1)=40 S FORDSUB=34 Q
 ....I $P(SUBTX(SUB),U,1)>49,$P(SUBTX(SUB),U,1)<54 S FORDSUB=30 Q
 ....I $P(SUBTX(SUB),U,1)=54 S FORDSUB=34 Q
 ....I $P(SUBTX(SUB),U,1)=60 S FORDSUB=35 Q
 ..
 ..I TOP>67419,TOP<67422 D  D SPP Q
 ...I SPP'="" S FORDS=1
 ...I SPPAF'="" S FORDSAF=1
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....I $P(SUBTX(SUB),U,1)'="" S FORDSUB=1
 ..
 ..I TOP>67422,TOP<67425 D  D SPP Q
 ...I SPP'="" S FORDS=1
 ...I SPPAF'="" S FORDSAF=1
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....I $P(SUBTX(SUB),U,1)'="" S FORDSUB=1
 ..
 ..I ((TOP>67399)&(TOP<67420))!((TOP>67469)&(TOP<67480))!((TOP>67489)&(TOP<67500)) D  D SPP Q
 ...I SPP=20 S FORDS=12
 ...I SPPAF=20 S FORDSAF=12
 ...I SPP=10 S FORDS=14
 ...I SPPAF=10 S FORDSAF=14
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)=20 S FORDSUB=12 Q
 ....I $P(SUBTX(SUB),U,1)=10 S FORDSUB=14 Q
 ..
 ..I TOP=67422 D  D SPP Q
 ...I SPP=10 S FORDS=20
 ...I SPPAF=10 S FORDSAF=20
 ...I (SPP=20)!(SPP=40)!(SPP=41)!(SPP=42)!(SPP=60)!(SPP=61)!(SPP=62) S FORDS=21
 ...I (SPPAF=20)!(SPPAF=40)!(SPPAF=41)!(SPPAF=42)!(SPPAF=60)!(SPPAF=61)!(SPPAF=62) S FORDSAF=21
 ...I (SPP=30)!(SPP=31)!(SPP=32) S FORDS=18
 ...I (SPPAF=30)!(SPPAF=31)!(SPPAF=32) S FORDSAF=18
 ...I (SPP=50)!(SPP=51)!(SPP=52) S FORDS=19
 ...I (SPPAF=50)!(SPPAF=51)!(SPPAF=52) S FORDSAF=19
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I $P(SUBTX(SUB),U,1)=10 S FORDSUB=20 Q
 ....I ($P(SUBTX(SUB),U,1)=20)!($P(SUBTX(SUB),U,1)=40)!($P(SUBTX(SUB),U,1)=41)!($P(SUBTX(SUB),U,1)=42)!($P(SUBTX(SUB),U,1)=60)!($P(SUBTX(SUB),U,1)=61)!($P(SUBTX(SUB),U,1)=62) S FORDSUB=21 Q
 ....I ($P(SUBTX(SUB),U,1)=30)!($P(SUBTX(SUB),U,1)=31)!($P(SUBTX(SUB),U,1)=32) S FORDSUB=18 Q
 ....I ($P(SUBTX(SUB),U,1)=50)!($P(SUBTX(SUB),U,1)=51)!($P(SUBTX(SUB),U,1)=52) S FORDSUB=19 Q
 ..
 ..I TOP>67439,TOP<67450 D  D SPP Q
 ...I ((SPP=40)!(SPP=50)),SM=0 S FORDS=27
 ...I ((SPPAF=40)!(SPPAF=50)),SM=0 S FORDSAF=27
 ...I ((SPP=40)!(SPP=50)),SM'=0 S FORDS=7
 ...I ((SPPAF=40)!(SPPAF=50)),SM'=0 S FORDSAF=7
 ...S SUB=0 F  S SUB=$O(SUBTX(SUB)) Q:SUB'>0  D  D SUBTX
 ....S FORDSUB=""
 ....I ($P(SUBTX(SUB),U,1)=40)!($P(SUBTX(SUB),U,1)=50),SM=0 S FORDSUB=27 Q
 ....I ($P(SUBTX(SUB),U,1)=40)!($P(SUBTX(SUB),U,1)=50),SM'=0 S FORDSUB=7 Q
 ..
 ..D ^ONCP36A1 Q
 ;
SPP I FORDS'="" S $P(^ONCO(165.5,IEN,3.1),U,29)=FORDS
 E  S $P(^ONCO(165.5,IEN,3.1),U,29)=SPPPNT
 I FORDSAF'="" S $P(^ONCO(165.5,IEN,3.1),U,30)=FORDSAF
 E   S $P(^ONCO(165.5,IEN,3.1),U,30)=SPPAFPNT
 Q
 ;
SUBTX S:FORDSUB'="" $P(^ONCO(165.5,IEN,4,SUB,0),U,4)=FORDSUB
 Q