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