- 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 Jan 18, 2025@03:25:42 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