- 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 Feb 18, 2025@23:50:37 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