ONCOCFP ;HINES OIFO/GWB - [PT Automatic Casefinding-PTF Search] ;05/03/12
;;2.2;ONCOLOGY;**1,7,5,13**;Jul 31, 2013;Build 7
;
; rvd - 0403/12 p56. Use ICD API (#3990) instead of direct global call
; P2.2*7 - icd10 CASEFINDING
W @IOF
W !!!?10,"****************** PTF CASEFINDING ******************",!
W !?10,"This option will search the PRINCIPLE DIAGNOSIS and"
W !?10,"SECONDARY DIAGNOSIS fields of the PTF file for ICD"
W !?10,"codes which identify cases to be added to the Suspense"
W !?10,"list."
;
T ;Start Date/End Date
N SDDEF
W !
S OSP=$O(^ONCO(160.1,"C",DUZ(2),0))
I OSP="" D Q
.W !?10,"Casefinding requires an ONCOLOGY SITE PARAMETER"
.W !?10,"entry which matches the user's login DIVISION."
.W !?10,"There is no ONCOLOGY SITE PARAMETER for DIVISION:"
.W !?10,$P($G(^DIC(4,DUZ(2),0)),U,1)
S SDDEF=$P(^ONCO(160.1,OSP,0),U,7)
I SDDEF="" S SDDEF=DT
S SDDEF=$E(SDDEF,4,5)_"-"_$E(SDDEF,6,7)_"-"_($E(SDDEF,1,3)+1700)
SD K DIR
S DIR(0)="D"
S DIR("A")=" Start Date"
S DIR("B")=SDDEF
D ^DIR
G EX:(Y="")!(Y[U)
I (Y>DT) W " Future dates not allowed" G SD
S (SD,X)=Y D DD^%DT W " ",Y
ED K DIR
S DIR(0)="D"
S DIR("A")=" End Date"
D ^DIR
G EX:(Y="")!(Y[U)
I (Y<SD) W " Invalid date sequence" G T
I (Y>DT) W " Future dates not allowed" G ED
S $P(^ONCO(160.1,OSP,0),U,7)=Y
S (ED,X)=Y D DD^%DT W " ",Y
W !
K DIR
S DIR(0)="Y"
S DIR("A")=" Dates OK"
S DIR("B")="Y"
D ^DIR
G EX:(Y="")!(Y[U)
G T:'Y
S ONCO("SD")=SD,ONCO("ED")=ED
;
;Include Squamous and Basal cell neoplasms (Y/N?)
W !
;S SBCIND="NO"
;K DIR
;S DIR(0)="Y"
;S DIR("A")=" Include Squamous and Basal cell neoplasms"
;S DIR("B")="Yes"
;S DIR("?")=" "
;S DIR("?",1)=" Answer 'YES' if you want to include squamous and basal cell neoplasms."
;S DIR("?",2)=" Answer 'NO' if you want to exclude these neoplasms."
;D ^DIR
;G EX:(Y="")!(Y[U)
;S:Y=1 SBCIND="YES"
;K DIR
;
W !!?3,"The following ICD codes will be searched for:"
W !
W !?3,"140-239 NEOPLASMS"
W !?3," (excluding benign neoplasms 210-229 unless listed below)"
W !?3,"042.2 HIV WITH SPECIFIED MALIGNANT NEOPLASMS"
W !?3,"225.0-225.9 BENIGN NEOPLASMS OF BRAIN AND OTHER PARTS OF NERVOUS SYSTEM"
W !?3,"227.3 BENIGN NEOPLASM OF PITUITARY GLAND AND CRANIOPHARYNGEAL DUCT"
W !?3,"227.4 BENIGN NEOPLASM OF PINEAL GLAND"
W !?3,"228.02 HEMANGIOMA INTRACRANIAL"
W !?3,"259.2 CARCINOID SYNDROME"
W !?3,"273.1-273.9 DISORDERS OF PLASMA PROTEIN METABOLISM"
W !?3,"284.9 ANAPLASTIC ANEMIA, UNSPECIFIED"
W !?3,"285.0 SIDEROBLASTIC ANEMIA"
W !?3,"288.3 EOSINOPHILIA"
W !?3,"288.4 HEMOPHAGOCYTIC SYNDROMES"
W !?3,"289.6 FAMILIAL POLYCYTHEMIA"
W !?3,"289.8 OTHER SPECIFIED DISEASES OF BLOOD AND BLOOD-FORMING ORGANS"
W !?3,"289.83 MYELOFIBROSIS"
W !?3,"795.06 PAPANICOLAOU SMEAR OF CERVIX WITH CYTOLOGIC EVIDENCE OF"
W !?3," MALIGNANCY"
W !?3,"795.16 PAP SMR VAG-CYTOL MALIG"
W !?3,"796.76 PAP SMR ANUS-CYTOL MALIG"
;
;NOTE: Code 795.76 is incorrect in the ICD DIAGNOSIS (80) file.
; It is appears as 796.76. PTF casefinding will look for both
; 795.76 and 796.76.
;
W !?3,"V07.3 NEED FOR OTHER PROPHYLACTIC CHEMOTHERAPY"
W !?3,"V07.8 NEED FOR OTHER SPECIFIED PROPHYLACTIC MEASURE"
W !?3,"V10.00-V10.09 GASTROINTESINAL TRACT"
W !?3,"V12.41 PERS HX BENIGN NEOPL OF BRAIN"
W !?3,"V58.0 ENCOUNTER FOR RADIOTHERAPY"
W !?3,"V58.1 ENCOUNTER FOR CHEMOTHERAPY"
W !?3,"V58.11 ANTINEOPLASTIC CHEMO ENC"
W !?3,"V58.12 IMMUNOTHERAPY ENCOUNTER"
W !?3,"V66.1-V66.2 CONVALESCENCE FOLLOWING RADIOTHERAPY/CHEMOTHERAPY"
W !?3,"V67.1-V67.2 FOLLOW-UP EXAMINATION FOLLOWING RADIOTHERAPY/CHEMOTHERAPY"
W !?3,"V71.1 OBSV-SUSPCT MAL NEOPLASM"
W !?3,"V76.0-V76.9 SPECIAL SCREENING FOR MALIGNANT NEOPLASMS"
W !
;List of ICD10
D L10^ONCOCFP1
W !
;
S %ZIS="Q" D ^%ZIS I POP G EX
I '$D(IO("Q")) D SER^ONCOCFP G EX
S ZTRTN="SER^ONCOCFP",ZTSAVE("ONCO*")="",ZTSAVE("SBCIND")="",ZTDESC="ONCOLOGY PTF SEARCH"
D ^%ZTLOAD
G EX
;
SER ;Search PTF file (#45) file
;Supported by IA #418
S AFFDIV=$G(DUZ(2)),ONCDIVSP=$O(^ONCO(160.1,"C",AFFDIV,""))
I ONCDIVSP="" W !!,"User does not have an associated DIVISION",!! G EX
F Z=0:0 S Z=$O(^ONCO(160.1,ONCDIVSP,6,Z)) Q:Z'>0 S AFFDIV=AFFDIV_U_$G(^ONCO(160.1,ONCDIVSP,6,Z,0))
K ^TMP("ONCO",$J)
S XDT=ONCO("SD")-.1111111
S XED=ONCO("ED")+.9999999
S ^TMP("ONCO",$J,0)=0
F S XDT=$O(^DGPT("ADS",XDT)) Q:(XDT>XED)!(XDT="") S D0=$O(^(XDT,0)),X70=$G(^DGPT(D0,70)),X71=$G(^DGPT(D0,71)) I X70'="" D IC
I $G(^TMP("ONCO",$J,0))=0 G WP
E D
.S DIC="^ONCO(160,"
.S BY="@75,INTERNAL(#3),75,.01"
.S FR=DUZ(2)_","_ONCO("SD"),TO=DUZ(2)_","_ONCO("ED")
.S FLDS="[ONCO PTF-CASEFINDING RPT]"
S L=0,IOP=ION,DIOEND="D WP^ONCOCFP"
D EN1^DIP Q
;
WP ;Wrap-up report
W !?3,$G(^TMP("ONCO",$J,0))_" PTF cases added to Suspense"
Q
;
IC ;Search for ICD codes
K HT,IC9,IC,ICD,ICP,CI10
S P="",CI=0,CI10=0
F F=10,16:1:24 S ICP=+$P(X70,U,F) I ICP>0 S IC9=$$GET1^DIQ(80,ICP,.01,"I") D FD Q:(CI=1)!(CI10=1)
I (X71'=""),(CI=0),(CI10=0) F F=1:1:15 S ICP=+$P(X71,U,F) I ICP>0 S IC9=$$GET1^DIQ(80,ICP,.01,"I") D FD Q:(CI=1)!(CI10=1)
;I CI=0 D IC10^ONCOCFP1
I (CI=0),(CI10=0) Q
G CK
;
FD I ((IC9>139.9)&(IC9<210)) S CI=1 Q
I ((IC9>224.9)&(IC9<226)) S CI=1 Q
I (IC9=227.3)!(IC9=227.4)!(IC9=228.02) S CI=1 Q
I ((IC9>229.9)&(IC9<240)) S CI=1 Q
I (IC9=259.2)!(IC9=273.1)!(IC9=273.2)!(IC9=273.3)!(IC9=273.9)!(IC9=284.9)!(IC9=288.3)!(IC9=288.4)!(IC9=289.6)!(IC9=289.8)!(IC9=289.83)!(IC9=795.06)!(IC9=795.16)!(IC9=795.76)!(IC9=796.76)!(IC9="042.2")!(IC9="285.0") S CI=1 Q
I $E(IC9)="V" S CD=$E(IC9,2,5) I ((CD>9)&(CD<11))!(CD=12.41)!(CD="58.0")!(CD=58.1)!(CD=66.1)!(CD=66.2)!(CD=67.1)!(CD=67.2)!(CD=71.1)!(CD="07.3")!(CD="07.8")!($E(CD,1,2)=76) S CI=1 Q
S IC10=IC9 D FD10^ONCOCFP1
Q
;
CK ;Check ONCOLOGY PATIENT (160) file
;Supported by IA #418
I ($G(IC9)=""),($G(IC10)="") Q
D DIV Q:DVMTCH=0
S X=^DGPT(D0,0),ADT=$P($P(X,U,2),"."),X=$P(X,U)_";DPT("
S XD0=$O(^ONCO(160,"B",X,0)),ONCIEN=XD0 I XD0="" G MR
I XD0'="" S ONCDIVS="",ONCS="" F S ONCS=$O(^ONCO(160,XD0,"SUS","C",ONCS)) Q:ONCS'>0 S ONCDIVS=ONCDIVS_U_ONCS
I ONCDIVS[DUZ(2) Q
S DA=XD0 I '$D(^ONCO(165.5,"C",XD0)) G N2
;
CKP ;Check ONCOLOGY PRIMARY (165.5) file
S XD1=0 F S XD1=$O(^ONCO(165.5,"C",XD0,XD1)) Q:XD1'>0 I $$DIV^ONCFUNC(XD1)=DUZ(2) D
.S XDX=$P($G(^ONCO(165.5,XD1,0)),U,16) I XDT>(ADT-1)&(XDX<($P(XDT,".")+1)) S HT=1 Q
.S XDX=$P($G(^ONCO(165.5,XD1,1)),U,10) I XDX=XDT S HT=1 Q
Q
;
MR ;Create ONCOLOGY PATIENT (160) record
Q:$D(HT)
K DO S DIC="^ONCO(160,",DIC(0)="Z" D FILE^DICN K DO
S (ONCIEN,XD0,DA)=+Y
;
N2 ;Create SUSPENSE (160.075) record
N DD,PTFDT,X1,X2
S X1=ADT,X2=1 D C^%DTC S SDT=X
S X1=ONCO("SD"),X2=1 D C^%DTC S WSD=X
S DA(1)=ONCIEN,DIC="^ONCO(160,"_DA(1)_",""SUS"","
K DO S DIC(0)="L",DIC("P")=$P(^DD(160,75,0),U,2),X=$S(SDT<WSD:WSD,1:SDT)
D FILE^DICN K DO
K DIE S DA(1)=ONCIEN,DIE="^ONCO(160,"_DA(1)_",""SUS"","
S (ONCSUB,DA)=+Y,PTFDT=$P(XDT,".")
S DR="1///^S X=DT;2///^S X=""PT"";3////^S X=DUZ(2);7///^S X=PTFDT;8////^S X=ICP"
D ^DIE
S ^TMP("ONCO",$J,0)=^TMP("ONCO",$J,0)+1
Q
;
DIV ;DIVISION match
;Supported by IAs #417 and #1378
N PTFD0,PTMV,WL
S DVMTCH=1,INST=""
S PTFD0=D0,PTMV=$O(^DGPM("APTF",PTFD0,"")) I PTMV="" Q
S WL=$P($G(^DGPM(PTMV,0)),U,6) I WL="" Q
S MCDV=$P($G(^DIC(42,WL,0)),U,11) I MCDV="" Q
S INST=$P($G(^DG(40.8,MCDV,0)),U,7) I INST="" Q
I AFFDIV'[INST S DVMTCH=0 Q
Q
;
EX ;KILL variables
K %DT,%T,%ZIS,ADT,AFFDIV,BY,CD,CI,D0,DA,DD,DIC,DIE,DIOEND,DIR,DO,DR
K DVMTCH,ED,F,FLDS,FR,GLO,HT,IC,IC9,ICD,ICP,INST,IOP,L,MCDV,NM,O2,CI10,IC10,SBCIND
K ONCDIVS,ONCDIVSP,ONCIEN,ONCO,ONCS,ONCSUB,OSP,P,POP,PTFD0,PTFDT,PTMV
K SD,SDDEF,SDT,TO,WED,WSD,X,X1,X2,X70,X71,XD0,XD1,XDT,XDX,XED,Y,Z
K ZTDESC,ZTRTN,ZTSAVE
K ^TMP("ONCO",$J)
D ^%ZISC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOCFP 8185 printed Sep 23, 2025@20:00:37 Page 2
ONCOCFP ;HINES OIFO/GWB - [PT Automatic Casefinding-PTF Search] ;05/03/12
+1 ;;2.2;ONCOLOGY;**1,7,5,13**;Jul 31, 2013;Build 7
+2 ;
+3 ; rvd - 0403/12 p56. Use ICD API (#3990) instead of direct global call
+4 ; P2.2*7 - icd10 CASEFINDING
+5 WRITE @IOF
+6 WRITE !!!?10,"****************** PTF CASEFINDING ******************",!
+7 WRITE !?10,"This option will search the PRINCIPLE DIAGNOSIS and"
+8 WRITE !?10,"SECONDARY DIAGNOSIS fields of the PTF file for ICD"
+9 WRITE !?10,"codes which identify cases to be added to the Suspense"
+10 WRITE !?10,"list."
+11 ;
T ;Start Date/End Date
+1 NEW SDDEF
+2 WRITE !
+3 SET OSP=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+4 IF OSP=""
Begin DoDot:1
+5 WRITE !?10,"Casefinding requires an ONCOLOGY SITE PARAMETER"
+6 WRITE !?10,"entry which matches the user's login DIVISION."
+7 WRITE !?10,"There is no ONCOLOGY SITE PARAMETER for DIVISION:"
+8 WRITE !?10,$PIECE($GET(^DIC(4,DUZ(2),0)),U,1)
End DoDot:1
QUIT
+9 SET SDDEF=$PIECE(^ONCO(160.1,OSP,0),U,7)
+10 IF SDDEF=""
SET SDDEF=DT
+11 SET SDDEF=$EXTRACT(SDDEF,4,5)_"-"_$EXTRACT(SDDEF,6,7)_"-"_($EXTRACT(SDDEF,1,3)+1700)
SD KILL DIR
+1 SET DIR(0)="D"
+2 SET DIR("A")=" Start Date"
+3 SET DIR("B")=SDDEF
+4 DO ^DIR
+5 if (Y="")!(Y[U)
GOTO EX
+6 IF (Y>DT)
WRITE " Future dates not allowed"
GOTO SD
+7 SET (SD,X)=Y
DO DD^%DT
WRITE " ",Y
ED KILL DIR
+1 SET DIR(0)="D"
+2 SET DIR("A")=" End Date"
+3 DO ^DIR
+4 if (Y="")!(Y[U)
GOTO EX
+5 IF (Y<SD)
WRITE " Invalid date sequence"
GOTO T
+6 IF (Y>DT)
WRITE " Future dates not allowed"
GOTO ED
+7 SET $PIECE(^ONCO(160.1,OSP,0),U,7)=Y
+8 SET (ED,X)=Y
DO DD^%DT
WRITE " ",Y
+9 WRITE !
+10 KILL DIR
+11 SET DIR(0)="Y"
+12 SET DIR("A")=" Dates OK"
+13 SET DIR("B")="Y"
+14 DO ^DIR
+15 if (Y="")!(Y[U)
GOTO EX
+16 if 'Y
GOTO T
+17 SET ONCO("SD")=SD
SET ONCO("ED")=ED
+18 ;
+19 ;Include Squamous and Basal cell neoplasms (Y/N?)
+20 WRITE !
+21 ;S SBCIND="NO"
+22 ;K DIR
+23 ;S DIR(0)="Y"
+24 ;S DIR("A")=" Include Squamous and Basal cell neoplasms"
+25 ;S DIR("B")="Yes"
+26 ;S DIR("?")=" "
+27 ;S DIR("?",1)=" Answer 'YES' if you want to include squamous and basal cell neoplasms."
+28 ;S DIR("?",2)=" Answer 'NO' if you want to exclude these neoplasms."
+29 ;D ^DIR
+30 ;G EX:(Y="")!(Y[U)
+31 ;S:Y=1 SBCIND="YES"
+32 ;K DIR
+33 ;
+34 WRITE !!?3,"The following ICD codes will be searched for:"
+35 WRITE !
+36 WRITE !?3,"140-239 NEOPLASMS"
+37 WRITE !?3," (excluding benign neoplasms 210-229 unless listed below)"
+38 WRITE !?3,"042.2 HIV WITH SPECIFIED MALIGNANT NEOPLASMS"
+39 WRITE !?3,"225.0-225.9 BENIGN NEOPLASMS OF BRAIN AND OTHER PARTS OF NERVOUS SYSTEM"
+40 WRITE !?3,"227.3 BENIGN NEOPLASM OF PITUITARY GLAND AND CRANIOPHARYNGEAL DUCT"
+41 WRITE !?3,"227.4 BENIGN NEOPLASM OF PINEAL GLAND"
+42 WRITE !?3,"228.02 HEMANGIOMA INTRACRANIAL"
+43 WRITE !?3,"259.2 CARCINOID SYNDROME"
+44 WRITE !?3,"273.1-273.9 DISORDERS OF PLASMA PROTEIN METABOLISM"
+45 WRITE !?3,"284.9 ANAPLASTIC ANEMIA, UNSPECIFIED"
+46 WRITE !?3,"285.0 SIDEROBLASTIC ANEMIA"
+47 WRITE !?3,"288.3 EOSINOPHILIA"
+48 WRITE !?3,"288.4 HEMOPHAGOCYTIC SYNDROMES"
+49 WRITE !?3,"289.6 FAMILIAL POLYCYTHEMIA"
+50 WRITE !?3,"289.8 OTHER SPECIFIED DISEASES OF BLOOD AND BLOOD-FORMING ORGANS"
+51 WRITE !?3,"289.83 MYELOFIBROSIS"
+52 WRITE !?3,"795.06 PAPANICOLAOU SMEAR OF CERVIX WITH CYTOLOGIC EVIDENCE OF"
+53 WRITE !?3," MALIGNANCY"
+54 WRITE !?3,"795.16 PAP SMR VAG-CYTOL MALIG"
+55 WRITE !?3,"796.76 PAP SMR ANUS-CYTOL MALIG"
+56 ;
+57 ;NOTE: Code 795.76 is incorrect in the ICD DIAGNOSIS (80) file.
+58 ; It is appears as 796.76. PTF casefinding will look for both
+59 ; 795.76 and 796.76.
+60 ;
+61 WRITE !?3,"V07.3 NEED FOR OTHER PROPHYLACTIC CHEMOTHERAPY"
+62 WRITE !?3,"V07.8 NEED FOR OTHER SPECIFIED PROPHYLACTIC MEASURE"
+63 WRITE !?3,"V10.00-V10.09 GASTROINTESINAL TRACT"
+64 WRITE !?3,"V12.41 PERS HX BENIGN NEOPL OF BRAIN"
+65 WRITE !?3,"V58.0 ENCOUNTER FOR RADIOTHERAPY"
+66 WRITE !?3,"V58.1 ENCOUNTER FOR CHEMOTHERAPY"
+67 WRITE !?3,"V58.11 ANTINEOPLASTIC CHEMO ENC"
+68 WRITE !?3,"V58.12 IMMUNOTHERAPY ENCOUNTER"
+69 WRITE !?3,"V66.1-V66.2 CONVALESCENCE FOLLOWING RADIOTHERAPY/CHEMOTHERAPY"
+70 WRITE !?3,"V67.1-V67.2 FOLLOW-UP EXAMINATION FOLLOWING RADIOTHERAPY/CHEMOTHERAPY"
+71 WRITE !?3,"V71.1 OBSV-SUSPCT MAL NEOPLASM"
+72 WRITE !?3,"V76.0-V76.9 SPECIAL SCREENING FOR MALIGNANT NEOPLASMS"
+73 WRITE !
+74 ;List of ICD10
+75 DO L10^ONCOCFP1
+76 WRITE !
+77 ;
+78 SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO EX
+79 IF '$DATA(IO("Q"))
DO SER^ONCOCFP
GOTO EX
+80 SET ZTRTN="SER^ONCOCFP"
SET ZTSAVE("ONCO*")=""
SET ZTSAVE("SBCIND")=""
SET ZTDESC="ONCOLOGY PTF SEARCH"
+81 DO ^%ZTLOAD
+82 GOTO EX
+83 ;
SER ;Search PTF file (#45) file
+1 ;Supported by IA #418
+2 SET AFFDIV=$GET(DUZ(2))
SET ONCDIVSP=$ORDER(^ONCO(160.1,"C",AFFDIV,""))
+3 IF ONCDIVSP=""
WRITE !!,"User does not have an associated DIVISION",!!
GOTO EX
+4 FOR Z=0:0
SET Z=$ORDER(^ONCO(160.1,ONCDIVSP,6,Z))
if Z'>0
QUIT
SET AFFDIV=AFFDIV_U_$GET(^ONCO(160.1,ONCDIVSP,6,Z,0))
+5 KILL ^TMP("ONCO",$JOB)
+6 SET XDT=ONCO("SD")-.1111111
+7 SET XED=ONCO("ED")+.9999999
+8 SET ^TMP("ONCO",$JOB,0)=0
+9 FOR
SET XDT=$ORDER(^DGPT("ADS",XDT))
if (XDT>XED)!(XDT="")
QUIT
SET D0=$ORDER(^(XDT,0))
SET X70=$GET(^DGPT(D0,70))
SET X71=$GET(^DGPT(D0,71))
IF X70'=""
DO IC
+10 IF $GET(^TMP("ONCO",$JOB,0))=0
GOTO WP
+11 IF '$TEST
Begin DoDot:1
+12 SET DIC="^ONCO(160,"
+13 SET BY="@75,INTERNAL(#3),75,.01"
+14 SET FR=DUZ(2)_","_ONCO("SD")
SET TO=DUZ(2)_","_ONCO("ED")
+15 SET FLDS="[ONCO PTF-CASEFINDING RPT]"
End DoDot:1
+16 SET L=0
SET IOP=ION
SET DIOEND="D WP^ONCOCFP"
+17 DO EN1^DIP
QUIT
+18 ;
WP ;Wrap-up report
+1 WRITE !?3,$GET(^TMP("ONCO",$JOB,0))_" PTF cases added to Suspense"
+2 QUIT
+3 ;
IC ;Search for ICD codes
+1 KILL HT,IC9,IC,ICD,ICP,CI10
+2 SET P=""
SET CI=0
SET CI10=0
+3 FOR F=10,16:1:24
SET ICP=+$PIECE(X70,U,F)
IF ICP>0
SET IC9=$$GET1^DIQ(80,ICP,.01,"I")
DO FD
if (CI=1)!(CI10=1)
QUIT
+4 IF (X71'="")
IF (CI=0)
IF (CI10=0)
FOR F=1:1:15
SET ICP=+$PIECE(X71,U,F)
IF ICP>0
SET IC9=$$GET1^DIQ(80,ICP,.01,"I")
DO FD
if (CI=1)!(CI10=1)
QUIT
+5 ;I CI=0 D IC10^ONCOCFP1
+6 IF (CI=0)
IF (CI10=0)
QUIT
+7 GOTO CK
+8 ;
FD IF ((IC9>139.9)&(IC9<210))
SET CI=1
QUIT
+1 IF ((IC9>224.9)&(IC9<226))
SET CI=1
QUIT
+2 IF (IC9=227.3)!(IC9=227.4)!(IC9=228.02)
SET CI=1
QUIT
+3 IF ((IC9>229.9)&(IC9<240))
SET CI=1
QUIT
+4 IF (IC9=259.2)!(IC9=273.1)!(IC9=273.2)!(IC9=273.3)!(IC9=273.9)!(IC9=284.9)!(IC9=288.3)!(IC9=288.4)!(IC9=289.6)!(IC9=289.8)!(IC9=289.83)!(IC9=795.06)!(IC9=795.16)!(IC9=795.76)!(IC9=796.76)!(IC9="042.2")!(IC9="285.0")
SET CI=1
QUIT
+5 IF $EXTRACT(IC9)="V"
SET CD=$EXTRACT(IC9,2,5)
IF ((CD>9)&(CD<11))!(CD=12.41)!(CD="58.0")!(CD=58.1)!(CD=66.1)!(CD=66.2)!(CD=67.1)!(CD=67.2)!(CD=71.1)!(CD="07.3")!(CD="07.8")!($EXTRACT(CD,1,2)=76)
SET CI=1
QUIT
+6 SET IC10=IC9
DO FD10^ONCOCFP1
+7 QUIT
+8 ;
CK ;Check ONCOLOGY PATIENT (160) file
+1 ;Supported by IA #418
+2 IF ($GET(IC9)="")
IF ($GET(IC10)="")
QUIT
+3 DO DIV
if DVMTCH=0
QUIT
+4 SET X=^DGPT(D0,0)
SET ADT=$PIECE($PIECE(X,U,2),".")
SET X=$PIECE(X,U)_";DPT("
+5 SET XD0=$ORDER(^ONCO(160,"B",X,0))
SET ONCIEN=XD0
IF XD0=""
GOTO MR
+6 IF XD0'=""
SET ONCDIVS=""
SET ONCS=""
FOR
SET ONCS=$ORDER(^ONCO(160,XD0,"SUS","C",ONCS))
if ONCS'>0
QUIT
SET ONCDIVS=ONCDIVS_U_ONCS
+7 IF ONCDIVS[DUZ(2)
QUIT
+8 SET DA=XD0
IF '$DATA(^ONCO(165.5,"C",XD0))
GOTO N2
+9 ;
CKP ;Check ONCOLOGY PRIMARY (165.5) file
+1 SET XD1=0
FOR
SET XD1=$ORDER(^ONCO(165.5,"C",XD0,XD1))
if XD1'>0
QUIT
IF $$DIV^ONCFUNC(XD1)=DUZ(2)
Begin DoDot:1
+2 SET XDX=$PIECE($GET(^ONCO(165.5,XD1,0)),U,16)
IF XDT>(ADT-1)&(XDX<($PIECE(XDT,".")+1))
SET HT=1
QUIT
+3 SET XDX=$PIECE($GET(^ONCO(165.5,XD1,1)),U,10)
IF XDX=XDT
SET HT=1
QUIT
End DoDot:1
+4 QUIT
+5 ;
MR ;Create ONCOLOGY PATIENT (160) record
+1 if $DATA(HT)
QUIT
+2 KILL DO
SET DIC="^ONCO(160,"
SET DIC(0)="Z"
DO FILE^DICN
KILL DO
+3 SET (ONCIEN,XD0,DA)=+Y
+4 ;
N2 ;Create SUSPENSE (160.075) record
+1 NEW DD,PTFDT,X1,X2
+2 SET X1=ADT
SET X2=1
DO C^%DTC
SET SDT=X
+3 SET X1=ONCO("SD")
SET X2=1
DO C^%DTC
SET WSD=X
+4 SET DA(1)=ONCIEN
SET DIC="^ONCO(160,"_DA(1)_",""SUS"","
+5 KILL DO
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(160,75,0),U,2)
SET X=$SELECT(SDT<WSD:WSD,1:SDT)
+6 DO FILE^DICN
KILL DO
+7 KILL DIE
SET DA(1)=ONCIEN
SET DIE="^ONCO(160,"_DA(1)_",""SUS"","
+8 SET (ONCSUB,DA)=+Y
SET PTFDT=$PIECE(XDT,".")
+9 SET DR="1///^S X=DT;2///^S X=""PT"";3////^S X=DUZ(2);7///^S X=PTFDT;8////^S X=ICP"
+10 DO ^DIE
+11 SET ^TMP("ONCO",$JOB,0)=^TMP("ONCO",$JOB,0)+1
+12 QUIT
+13 ;
DIV ;DIVISION match
+1 ;Supported by IAs #417 and #1378
+2 NEW PTFD0,PTMV,WL
+3 SET DVMTCH=1
SET INST=""
+4 SET PTFD0=D0
SET PTMV=$ORDER(^DGPM("APTF",PTFD0,""))
IF PTMV=""
QUIT
+5 SET WL=$PIECE($GET(^DGPM(PTMV,0)),U,6)
IF WL=""
QUIT
+6 SET MCDV=$PIECE($GET(^DIC(42,WL,0)),U,11)
IF MCDV=""
QUIT
+7 SET INST=$PIECE($GET(^DG(40.8,MCDV,0)),U,7)
IF INST=""
QUIT
+8 IF AFFDIV'[INST
SET DVMTCH=0
QUIT
+9 QUIT
+10 ;
EX ;KILL variables
+1 KILL %DT,%T,%ZIS,ADT,AFFDIV,BY,CD,CI,D0,DA,DD,DIC,DIE,DIOEND,DIR,DO,DR
+2 KILL DVMTCH,ED,F,FLDS,FR,GLO,HT,IC,IC9,ICD,ICP,INST,IOP,L,MCDV,NM,O2,CI10,IC10,SBCIND
+3 KILL ONCDIVS,ONCDIVSP,ONCIEN,ONCO,ONCS,ONCSUB,OSP,P,POP,PTFD0,PTFDT,PTMV
+4 KILL SD,SDDEF,SDT,TO,WED,WSD,X,X1,X2,X70,X71,XD0,XD1,XDT,XDX,XED,Y,Z
+5 KILL ZTDESC,ZTRTN,ZTSAVE
+6 KILL ^TMP("ONCO",$JOB)
+7 DO ^%ZISC
+8 QUIT
