Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ONCOAI

ONCOAI.m

Go to the documentation of this file.
  1. ONCOAI ;HINES OIFO/GWB [AI Complete Abstract] ;07/22/11
  1. ;;2.2;ONCOLOGY;**1,17**;Jul 31, 2013;Build 6
  1. ;
  1. BEG D EX
  1. W @IOF,!!!
  1. S DIC("A")=" Enter patient name: ",DLAYGO=160,DIC="^ONCO(160,"
  1. S DIC(0)="AELMQZ" D ^DIC K DIC,DLAYGO G EX:Y<0
  1. S (D0,ONCOD0)=+Y,ONCOVP=$P(Y,U,2)
  1. S ONCONM=Y(0,0),ONCONAM=$P(ONCONM,",",2)_" "_$P(ONCONM,",",1)
  1. S PT0=Y(0),SEX=$P(PT0,U,8) G:SEX'="" PD
  1. ;
  1. DEM ;Display demographic data
  1. D ^ONCOAID
  1. PD K DXS,DIOT S D0=ONCOD0 D PRT^ONCPDI
  1. S SX=$S(SEX=1:"M",SEX=2:"F",1:"")
  1. S ONCOSX=$S(SX="M":"Male",SX="F":"Female",1:"")
  1. A1 K DIR W ! S DIR("A")=" Edit patient data",DIR("B")="YES",DIR(0)="Y"
  1. D ^DIR G CONT:Y[U,EX:Y="",HIS:'Y
  1. ;
  1. PAT ;Edit ONCOLOGY PATIENT (160) data
  1. N RACE,R1 S RACE="" D RACE^ONCOES
  1. I X'="" D
  1. .S R1=X
  1. .S RACE=$S(R1["BLACK":"Black",R1["WHITE":"White",R1["AMERICAN INDIAN OR ALASKA NATIVE":"American Indian, Aleutian, Eskimo",1:"")
  1. D ENVIRON^ONCOES
  1. S ONCOL=0,DA=ONCOD0
  1. L +^ONCO(160,DA):0 I $T D ^ONCPAT L -^ONCO(160,DA) S ONCOL=1
  1. I 'ONCOL W !,"Another user is editing this patient."
  1. K ONCOL
  1. ;
  1. HIS ;Patient History
  1. K DIR W !
  1. S DIR("A")=" Continue with Patient History",DIR(0)="Y",DIR("B")="Yes"
  1. D ^DIR G CONT:Y[U,EX:Y="",CK:Y=0
  1. S D0=ONCOD0 D PH^ONCPDI
  1. S ONCOL=0,DA=ONCOD0
  1. L +^ONCO(160,DA):0 I $T D ^ONCPTHST L -^ONCO(160,DA) S ONCOL=1
  1. I 'ONCOL W !,"Another user is editing this patient"
  1. K ONCOL
  1. ;
  1. CK ;Check for existing primaries
  1. ;S ONCOP0=$O(^ONCO(165.5,"C",ONCOD0,0)) I ONCOP0'="" S ONCOP=$S($D(^ONCO(165.5,ONCOP0,0)):^(0),1:"") I ONCOP'="" G PRIM2 ;old code before division check
  1. D NEWCHECK
  1. S ONCOP0=$O(^TMP($J,"MDV",DUZ(2),0)) I ONCOP0'="" S ONCOP=$S($D(^ONCO(165.5,ONCOP0,0)):^(0),1:"") I ONCOP'="" G PRIM2
  1. ;
  1. PRIM1 ;Register a primary for this patient
  1. REG D KIL S DIR("B")="Yes",DIR(0)="Y",DIR("A")=" Register a Primary for this patient" W !! D ^DIR G AIP:Y,EX:Y="",CONT
  1. ;
  1. PRIM2 ;patient in PRIMARY FILE
  1. D SDD^ONCOCOM
  1. W !," Date Last Contact: ",$$GET1^DIQ(160,ONCOD0,16,"E")
  1. W !," Status: ",$$GET1^DIQ(160,ONCOD0,15,"E")
  1. W !," Follow-up Status: ",$$GET1^DIQ(160,ONCOD0,15.2,"E")
  1. ASK K DIR,Y S DIR(0)="S^E:EDIT existing Primary;A:ADD another Primary;F:Follow-Up;Q:Quit Patient",DIR("A")=" EDIT/ADD primary for this patient",DIR("B")="Edit" D ^DIR G EDT:Y="E",AIP:Y="A",FOL:Y="F",CONT:Y="Q",CONT:U,EX
  1. ;
  1. EDT ;Select primary to edit
  1. S D="C",DIC(0)="EZ",DIC="^ONCO(165.5,",X=ONCONM D IX^DIC K D,DIC,X W ! G BEG:Y<0 I Y=" " W ?40,"Space bar not allowed!" G EDT
  1. S ONCOD0P=+Y D EN^ONCOAIP G EX
  1. ;
  1. AIP ;Abstract all Primary Data;Return with (D0,ONCOD0P)=Primary Record Number
  1. D @($S(ONCOP0="":"EN^ONCOAIC",ONCOP'="":"EN^ONCOAIM",1:"ER")) G SET:Y,EX:Y="",CONT
  1. ;
  1. SET S (SR,XD,MO,CS)=""
  1. N SSPIEN
  1. S SSPIEN=$O(^ONCO(160,ONCOD0,"SUS","C",DUZ(2),"")) I SSPIEN'="" D
  1. .S XD=$P(^ONCO(160,ONCOD0,"SUS",SSPIEN,0),U,1)
  1. .S SR=$P(^ONCO(160,ONCOD0,"SUS",SSPIEN,0),U,3)
  1. .S CS=$S(SR="LS":20,SR="LC":20,SR="LE":20,SR="PT":21,SR="RA":26,1:"")
  1. .S MO=$P(^ONCO(160,ONCOD0,"SUS",SSPIEN,0),U,11)
  1. .S DA(1)=ONCOD0,DA=SSPIEN,DIK="^ONCO(160,"_DA(1)_",""SUS""," D ^DIK
  1. S ONCOL=0
  1. S DIE="^ONCO(165.5,"
  1. S (D0,DA)=ONCOD0P
  1. ;S DR="3///^S X=XD;91///0;95///2;21///^S X=CS"
  1. S DR="91///0;95///2"
  1. L +^ONCO(165.5,DA):0 I $T D ^DIE L -^ONCO(165.5,DA) S ONCOL=1
  1. I MO="" G SET1
  1. I ((XD<3010000)&('$D(^ONCO(164.1,MO,0))))!((XD>3001231)&('$D(^ONCO(169.3,MO,0)))) D W ! K DIR S DIR(0)="E" D ^DIR G:Y=0 EX G SET1
  1. .W !!,"WARNING:"
  1. .W !,"The morphology code ",$E(MO,1,4)_"/"_$E(MO,5,6)," found by lab casefinding is not a valid ICD-O code."
  1. .W !,"Enter the correct morphology code at the appropriate HISTOLOGY (ICD-O) prompt."
  1. S:XD<3010000 $P(^ONCO(165.5,D0,2),U,3)=MO,$P(^ONCO(165.5,D0,2.2),U,3)=MO
  1. S:XD>3001231 $P(^ONCO(165.5,D0,2.2),U,3)=MO
  1. SET1 D MS^ONCOCOM,EN^ONCOAIP
  1. I 'ONCOL W !,"Another user is editing this patient data."
  1. K CS,ONCOL,MO,SR,XD
  1. ;
  1. CONT ;Continue another patient
  1. K DIR W !! S DIR("A")=" Abstract another patient",DIR(0)="Y",DIR("B")="Yes" D ^DIR G BEG:Y,EX
  1. Q
  1. FOL ;Follow-Up
  1. S ONCOAI=1 D EN^ONCOAIF
  1. Q
  1. ;
  1. KILL ;Kill variables
  1. K ONCOACN,ONCO,ONCOD0,ONCOD0P,ONCOMR,ONCONM,ONCOOUT,ONCOP,ONCOP0,ONCOSN
  1. K ONCOSX,ONCOEDIT,ONCOPB,ONCOSIT,ONCONAM,ONCOPN,ONCOVP,ONCOVS,ONCOX
  1. K ONCOAI,ONCOANS,ONCOT,ONCOYR,IIN,SSN,TAB,SITTAB,TOPCOD,SITEGP
  1. K TOPNAM,TOPTAB
  1. KIL K D1,DI,DN,DIR,DIC,DIE,COB,COC,D,DA,D0,DIR,DR,NM,R,RC,RCC,SEX,SX,POB,SN,TL,X
  1. K A,AG,ABS,AN,ANS,C,CC,CT,CTY,DEF,DIK,DLAYGO,I2,I9,PT0,PTR,ST,SDD,VP0
  1. K VPR,XN,DXS,FIL,G,I,J,K,L,M,N,N2,NM,O2,VAERR,D0P,ICD,OT,R1,R2,RIPD0
  1. K XDT,XS,XTS,ZP,ZIP,RY,FG,P,MC,MO,KK,OD,ONCOAD,ONCODD,ONCOICD,OS,PR,Q,S
  1. K SC,SR,T,TS,UF,XDA,XLC,XY,%ZISOS
  1. Q
  1. ER ;Error
  1. W !!?5,"Something is wrong with database!! - See Site Manager" S Y="" Q
  1. EX D KILL
  1. K ONCOANS,D0,DA,DIC,DIE,DIR,DQ,DR,MS,PR,R1,R2,RS,RIP,SR,ST,SY,T,S,Z,ER,TM,CS,XD0,XD1
  1. K A,AG,D0,D1,DA,DXS,FIL,G,I,J,K,L,M,N,NM,O2,TD,TX,OT,DOP,ICD,C,XX,ONCOYR
  1. K ONCOAD,ONCODD,VAERR,ONCO,ONCOD0P,ONCONM,OP,ONCOD0,%W,%X,%Y,%ZISOS
  1. K STAT
  1. Q
  1. ;
  1. WRTSDC ;CALLED BY [ONCO XDEATH INFO] PRINT TEMPLATE
  1. N DI,DIC,DA
  1. K DIQ S DIC="^ONCO(160,",DR="19.1",DA=D0,DIQ="ONCSDC" D EN^DIQ1
  1. W !?4,"State Death Cert: ",ONCSDC(160,D0,19.1)
  1. K ONCSDC
  1. Q
  1. ;
  1. CON ;ADD CONTACTS
  1. ;G BEG:$P($G(^ONCO(160,ONCOD0,1)),U)=0,BEG:$D(^ONCO(160,"APC",ONCOD0)) S,EX:Y="" DIR("A")=" ADD CONTACTS at this time",DIR(0)="Y" W !! D ^DIR G BEG:'Y,CONT:Y[U D DCL^ONCOFUL
  1. Q
  1. ;
  1. NEWCHECK ;CODE FOR MULTIDIVISION CHECK - PATCH 17
  1. K ^TMP($J,"MDV")
  1. K RTKARY S PRI=0 F S PRI=$O(^ONCO(165.5,"C",ONCOD0,PRI)) Q:PRI'>0 D
  1. .S PRIDIV=$$DIV^ONCFUNC(PRI) S ^TMP($J,"MDV",PRIDIV,PRI)=PRI
  1. .I PRIDIV=DUZ(2) S RTKARY(PRI)=PRI
  1. .Q
  1. K PRI,PRIDIV Q