ONCOAIM ;HINES OIFO/GWB - Create additional primaries for a patient ;03/08/11
;;2.2;ONCOLOGY;**1,4,15,17**;Jul 31, 2013;Build 6
;
EN ;Add additional primaries for patient
D KILL
W @IOF
W !!?5,"******** ADD PRIMARY RECORD FOR THIS PATIENT********",!!
W:$D(ONCONM) ?5,"PATIENT: ",ONCONM
;
;Get next ACESSION NUMBER (165.5,.05)/SEQUENCE NUMBER (165.5,.06)
;Loop thru 165.5 "D" cross-reference
;Set up 2 ^TMP arrays: 1 for malignants, 1 for benigns
S (KKM,KKB)=0,AC=$P(ONCOP,U,5),ACN=$E(AC,1,4)_"-"_$E(AC,5,9),ACS=ACN
F KK=1:1 S ACSL=ACS,ACS=$O(^ONCO(165.5,"D",ACS)) S SQN=$P(ACS,"/",2) D Q:$P(ACS,"/")'=ACN
.Q:$P(ACS,"/")'=ACN
.S RECNUM=0
.F LL=1:1 S RECNUM=$O(^ONCO(165.5,"D",ACS,RECNUM)) Q:RECNUM="" D
..S PRIMIEN=$P(^ONCO(165.5,RECNUM,0),U)
..S PRIM=$P(^ONCO(164.2,PRIMIEN,0),U,1)
..S SEQDIV=$$DIV^ONCFUNC(RECNUM)
..I ((+SQN>0)&(+SQN<60))!(SQN="00")!(SQN=99) D
...I SEQDIV=DUZ(2) S KKM=KKM+1,^TMP($J,"MAL",KKM)=SQN_U_ACS_U_PRIM_U_RECNUM_U_SEQDIV
..E D
...I SEQDIV=DUZ(2) S KKB=KKB+1,^TMP($J,"BEN",KKB)=SQN_U_ACS_U_PRIM_U_RECNUM_U_SEQDIV
;Find last malignant/benign (if any) and determine SEQUENCE NUMBER
K LASTBEN,LASTMAL,NEXTBEN,NEXTMAL
S ALPHA=0 F S BEN=ALPHA,ALPHA=$O(^TMP($J,"BEN",ALPHA)) Q:ALPHA'>0
S NUM=0 F S MAL=NUM,NUM=$O(^TMP($J,"MAL",NUM)) Q:NUM'>0
S LASTBEN=$P($G(^TMP($J,"BEN",BEN)),U,1)
S LASTMAL=$P($G(^TMP($J,"MAL",MAL)),U,1)
S NEXTBEN=$S(LASTBEN=60:62,LASTBEN'="":LASTBEN+1,1:60)
S NEXTMAL=$S(LASTMAL'="":LASTMAL+1,1:"NULL")
S NEXTMAL=$S(NEXTMAL=1!(NEXTMAL>99):2,NEXTMAL="NULL":"00^99",1:NEXTMAL)
S NEXTMAL=$S($L(NEXTMAL)<2:"0"_NEXTMAL,1:NEXTMAL)
;
W !!?5,"ACCESSION NUMBER: ",ACN
;
PROMPT ;SEQUENCE NUMBER (165.5,.06) prompt
N DEF,DIEN
S DEF=$S(NEXTMAL["00":"00",1:NEXTMAL)
K DIR S DIR(0)="F^2:2",DIR("A")=" SEQUENCE NUMBER.",DIR("B")=DEF
S DIR("?")="Enter the next SEQUENCE NUMBER. Enter ?? for additional HELP"
S DIR("??")="^D HLP^ONCOAIM2" D ^DIR I "^^"[Y D KILL Q
I (Y'?2N)!((Y>88)&(Y<99)) W " Allowable Values: 00-88, 99" G PROMPT
S XXIEN=ACN_"/"_Y I $D(^ONCO(165.5,"D",XXIEN)) D G PROMPT
.W !?25,XXIEN," is already assigned.",!
.S XD0=ONCOD0 D CX^ONCOCOM K XXIEN Q
S DIEN=ACN_"/"_Y
S SN=Y,SEQ=SN,AY=$E(DT,1)+17,AY=AY_$E(DT,2,3)
I SN="02",$D(^TMP($J,"MAL",1)),$P(^TMP($J,"MAL",1),U,1)="00" D
.S ACS=$P(^TMP($J,"MAL",1),U,2)
.S REC00=$P(^TMP($J,"MAL",1),U,4)
.W !!?5,"You are adding the second malignant or in-situ primary for this patient"
.W !!?5,ACS," ","will be changed to ",ACN,"/01",!
I SN="02",$D(^TMP($J,"MAL",2)),$P(^TMP($J,"MAL",2),U,1)'="01" D
.S REC002=$P(^TMP($J,"MAL",2),U,4)
I SN>59,SN<88,SN'=NEXTBEN W ?32,"Next Non-Malignant SEQUENCE NUMBER is",NEXTBEN G PROMPT
I SN=62,$D(^TMP($J,"BEN",1)),$P(^TMP($J,"BEN",1),U)=60 D
.S ACS=$P(^TMP($J,"BEN",1),U,2)
.S REC00=$P(^TMP($J,"BEN",1),U,4)
.W !!?5,"You are adding the second Non-Malignant primary for this patient"
.W !!?5,ACS," ","will be changed to ",ACN,"/61",!
;
LOOK2 ;Select Primary Site
K DIC
S DIC="^ONCO(164.2,",DIC(0)="AEQM"
S DIC("A")=" Select Primary 'SITE/GP': "
S DIC("S")="I '$P(^(0),U,3)"
D ^DIC K DIC G EX:Y<0
S (XX,X,ONCOSIT)=+Y,ONCOPN=$P(Y,U,2),XD0=ONCOD0
D SEX^ONCOCKI G LOOK2:'$D(X)
K DIR
S DIR("A")=" Ok to add:",DIR("B")="Y",DIR(0)="Y" D ^DIR
G CR:Y,EN:Y=0 Q
;
CR ;Create Primary
K DIC,DO,DTOUT
W !,?5,"Creating another primary record for ",ONCONM_" "_ACN_"..."
S DIC="^ONCO(165.5,",X=ONCOSIT,DIC(0)="Z"
S DIC("DR")="2000////^S X=DUZ(2);236////^S X=DT;244////^S X=DUZ"
D FILE^DICN K DIC,X G EX:Y<0
S ONCOD0P=+Y
S $P(^ONCO(165.5,+Y,0),U,2)=ONCOD0,$P(^(7),U,2)=0
S ^ONCO(165.5,"C",ONCOD0,ONCOD0P)=""
S ACAY=$E(DT,1)+17_$E(DT,2,3)
;new code P17 set defaults DATE DX (3) and CASEFINDING SOURCE (21)
; mostly copied next 7 lines from ONCOAI
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":"Pathology Department Review",SR="LC":"Pathology Department Review",SR="LE":"Pathology Department Review",SR="PT":"Daily Discharge Review",SR="RA":"Diagnostic Imaging/Radiology",1:"")
.S MO=$P(^ONCO(160,ONCOD0,"SUS",SSPIEN,0),U,11)
;
L +^ONCO(165.5,ONCOD0P,0):0
S DIE="^ONCO(165.5,"
S DR="W !;.05////^S X=AC;.06////^S X=SEQ;.07//^S X=ACAY;.04;155;3//^S X=XD;20;21//^S X=CS"
S ACN=AC_"/"_SEQ,DA=ONCOD0P
D ^DIE
L -^ONCO(165.5,ONCOD0P,0)
G PID:$D(Y)=0 D KLN G EX
;
PID ;Continue defining Primary Record
I SN="02",$D(^TMP($J,"MAL",1)),$P(^TMP($J,"MAL",1),U,1)="00" S UPDATE="01" D UPDT
I SN=62,$D(^TMP($J,"BEN",1)),$P(^TMP($J,"BEN",1),U,1)=60 S UPDATE=61 D UPDT
S ONCOACN=AC_"/"_SEQ,Y=1 D KILL Q
;
UPDT ;Update 00 to 01, update 60 to 61
S SN=UPDATE,DIE="^ONCO(165.5,",DA=REC00,DR=".06///^S X=SN"
D ^DIE S D0=ONCOD0P
I $D(REC002) S SN=UPDATE,DIE="^ONCO(165.5,",DA=REC002,DR=".06///^S X=SN" D ^DIE S D0=ONCOD0P
W !!?5,"The following up-dating has occurred:",!! D SDA^ONCOCOM H 2
Q
;
KLN ;KILL entry
S DA=ONCOD0P,DIK="^ONCO(165.5," D ^DIK,KILL
R !?5,"<ENTRY DELETED> - press RETURN to continue->",DA:DTIME
Q:'$T!(DA=U)
W !
Q
;
KILL ;KILL variables
K AC,ACAY,ACN,ACS,ACSL,ALPHA,AY,BEN,DA,DIC,DIE,DIK,DIR,D0,DR,DTOUT
K KK,KKM,KKB,LASTBEN,LASTMAL,LL,MAL,NEXTBEN,NEXTMAL,NUM,ONCOSIT
K PRIM,PRIMIEN,REC00,REC002,RECNUM,SEQDIV,SN,SEQ,SQN,UPDATE,X,XD0,XX
K ^TMP($J,"BEN"),^TMP($J,"MAL")
Q
;
EX ;Exit
D KILL S Y=0
Q
;
CLEANUP ;Cleanup
K ONCOACN,ONCOD0,ONCOD0P,ONCONM,ONCOP,ONCOPN,ONCOSIT,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOAIM 5603 printed Apr 09, 2024@21:28:57 Page 2
ONCOAIM ;HINES OIFO/GWB - Create additional primaries for a patient ;03/08/11
+1 ;;2.2;ONCOLOGY;**1,4,15,17**;Jul 31, 2013;Build 6
+2 ;
EN ;Add additional primaries for patient
+1 DO KILL
+2 WRITE @IOF
+3 WRITE !!?5,"******** ADD PRIMARY RECORD FOR THIS PATIENT********",!!
+4 if $DATA(ONCONM)
WRITE ?5,"PATIENT: ",ONCONM
+5 ;
+6 ;Get next ACESSION NUMBER (165.5,.05)/SEQUENCE NUMBER (165.5,.06)
+7 ;Loop thru 165.5 "D" cross-reference
+8 ;Set up 2 ^TMP arrays: 1 for malignants, 1 for benigns
+9 SET (KKM,KKB)=0
SET AC=$PIECE(ONCOP,U,5)
SET ACN=$EXTRACT(AC,1,4)_"-"_$EXTRACT(AC,5,9)
SET ACS=ACN
+10 FOR KK=1:1
SET ACSL=ACS
SET ACS=$ORDER(^ONCO(165.5,"D",ACS))
SET SQN=$PIECE(ACS,"/",2)
Begin DoDot:1
+11 if $PIECE(ACS,"/")'=ACN
QUIT
+12 SET RECNUM=0
+13 FOR LL=1:1
SET RECNUM=$ORDER(^ONCO(165.5,"D",ACS,RECNUM))
if RECNUM=""
QUIT
Begin DoDot:2
+14 SET PRIMIEN=$PIECE(^ONCO(165.5,RECNUM,0),U)
+15 SET PRIM=$PIECE(^ONCO(164.2,PRIMIEN,0),U,1)
+16 SET SEQDIV=$$DIV^ONCFUNC(RECNUM)
+17 IF ((+SQN>0)&(+SQN<60))!(SQN="00")!(SQN=99)
Begin DoDot:3
+18 IF SEQDIV=DUZ(2)
SET KKM=KKM+1
SET ^TMP($JOB,"MAL",KKM)=SQN_U_ACS_U_PRIM_U_RECNUM_U_SEQDIV
End DoDot:3
+19 IF '$TEST
Begin DoDot:3
+20 IF SEQDIV=DUZ(2)
SET KKB=KKB+1
SET ^TMP($JOB,"BEN",KKB)=SQN_U_ACS_U_PRIM_U_RECNUM_U_SEQDIV
End DoDot:3
End DoDot:2
End DoDot:1
if $PIECE(ACS,"/")'=ACN
QUIT
+21 ;Find last malignant/benign (if any) and determine SEQUENCE NUMBER
+22 KILL LASTBEN,LASTMAL,NEXTBEN,NEXTMAL
+23 SET ALPHA=0
FOR
SET BEN=ALPHA
SET ALPHA=$ORDER(^TMP($JOB,"BEN",ALPHA))
if ALPHA'>0
QUIT
+24 SET NUM=0
FOR
SET MAL=NUM
SET NUM=$ORDER(^TMP($JOB,"MAL",NUM))
if NUM'>0
QUIT
+25 SET LASTBEN=$PIECE($GET(^TMP($JOB,"BEN",BEN)),U,1)
+26 SET LASTMAL=$PIECE($GET(^TMP($JOB,"MAL",MAL)),U,1)
+27 SET NEXTBEN=$SELECT(LASTBEN=60:62,LASTBEN'="":LASTBEN+1,1:60)
+28 SET NEXTMAL=$SELECT(LASTMAL'="":LASTMAL+1,1:"NULL")
+29 SET NEXTMAL=$SELECT(NEXTMAL=1!(NEXTMAL>99):2,NEXTMAL="NULL":"00^99",1:NEXTMAL)
+30 SET NEXTMAL=$SELECT($LENGTH(NEXTMAL)<2:"0"_NEXTMAL,1:NEXTMAL)
+31 ;
+32 WRITE !!?5,"ACCESSION NUMBER: ",ACN
+33 ;
PROMPT ;SEQUENCE NUMBER (165.5,.06) prompt
+1 NEW DEF,DIEN
+2 SET DEF=$SELECT(NEXTMAL["00":"00",1:NEXTMAL)
+3 KILL DIR
SET DIR(0)="F^2:2"
SET DIR("A")=" SEQUENCE NUMBER."
SET DIR("B")=DEF
+4 SET DIR("?")="Enter the next SEQUENCE NUMBER. Enter ?? for additional HELP"
+5 SET DIR("??")="^D HLP^ONCOAIM2"
DO ^DIR
IF "^^"[Y
DO KILL
QUIT
+6 IF (Y'?2N)!((Y>88)&(Y<99))
WRITE " Allowable Values: 00-88, 99"
GOTO PROMPT
+7 SET XXIEN=ACN_"/"_Y
IF $DATA(^ONCO(165.5,"D",XXIEN))
Begin DoDot:1
+8 WRITE !?25,XXIEN," is already assigned.",!
+9 SET XD0=ONCOD0
DO CX^ONCOCOM
KILL XXIEN
QUIT
End DoDot:1
GOTO PROMPT
+10 SET DIEN=ACN_"/"_Y
+11 SET SN=Y
SET SEQ=SN
SET AY=$EXTRACT(DT,1)+17
SET AY=AY_$EXTRACT(DT,2,3)
+12 IF SN="02"
IF $DATA(^TMP($JOB,"MAL",1))
IF $PIECE(^TMP($JOB,"MAL",1),U,1)="00"
Begin DoDot:1
+13 SET ACS=$PIECE(^TMP($JOB,"MAL",1),U,2)
+14 SET REC00=$PIECE(^TMP($JOB,"MAL",1),U,4)
+15 WRITE !!?5,"You are adding the second malignant or in-situ primary for this patient"
+16 WRITE !!?5,ACS," ","will be changed to ",ACN,"/01",!
End DoDot:1
+17 IF SN="02"
IF $DATA(^TMP($JOB,"MAL",2))
IF $PIECE(^TMP($JOB,"MAL",2),U,1)'="01"
Begin DoDot:1
+18 SET REC002=$PIECE(^TMP($JOB,"MAL",2),U,4)
End DoDot:1
+19 IF SN>59
IF SN<88
IF SN'=NEXTBEN
WRITE ?32,"Next Non-Malignant SEQUENCE NUMBER is",NEXTBEN
GOTO PROMPT
+20 IF SN=62
IF $DATA(^TMP($JOB,"BEN",1))
IF $PIECE(^TMP($JOB,"BEN",1),U)=60
Begin DoDot:1
+21 SET ACS=$PIECE(^TMP($JOB,"BEN",1),U,2)
+22 SET REC00=$PIECE(^TMP($JOB,"BEN",1),U,4)
+23 WRITE !!?5,"You are adding the second Non-Malignant primary for this patient"
+24 WRITE !!?5,ACS," ","will be changed to ",ACN,"/61",!
End DoDot:1
+25 ;
LOOK2 ;Select Primary Site
+1 KILL DIC
+2 SET DIC="^ONCO(164.2,"
SET DIC(0)="AEQM"
+3 SET DIC("A")=" Select Primary 'SITE/GP': "
+4 SET DIC("S")="I '$P(^(0),U,3)"
+5 DO ^DIC
KILL DIC
if Y<0
GOTO EX
+6 SET (XX,X,ONCOSIT)=+Y
SET ONCOPN=$PIECE(Y,U,2)
SET XD0=ONCOD0
+7 DO SEX^ONCOCKI
if '$DATA(X)
GOTO LOOK2
+8 KILL DIR
+9 SET DIR("A")=" Ok to add:"
SET DIR("B")="Y"
SET DIR(0)="Y"
DO ^DIR
+10 if Y
GOTO CR
if Y=0
GOTO EN
QUIT
+11 ;
CR ;Create Primary
+1 KILL DIC,DO,DTOUT
+2 WRITE !,?5,"Creating another primary record for ",ONCONM_" "_ACN_"..."
+3 SET DIC="^ONCO(165.5,"
SET X=ONCOSIT
SET DIC(0)="Z"
+4 SET DIC("DR")="2000////^S X=DUZ(2);236////^S X=DT;244////^S X=DUZ"
+5 DO FILE^DICN
KILL DIC,X
if Y<0
GOTO EX
+6 SET ONCOD0P=+Y
+7 SET $PIECE(^ONCO(165.5,+Y,0),U,2)=ONCOD0
SET $PIECE(^(7),U,2)=0
+8 SET ^ONCO(165.5,"C",ONCOD0,ONCOD0P)=""
+9 SET ACAY=$EXTRACT(DT,1)+17_$EXTRACT(DT,2,3)
+10 ;new code P17 set defaults DATE DX (3) and CASEFINDING SOURCE (21)
+11 ; mostly copied next 7 lines from ONCOAI
+12 SET (SR,XD,MO,CS)=""
+13 NEW SSPIEN
+14 SET SSPIEN=$ORDER(^ONCO(160,ONCOD0,"SUS","C",DUZ(2),""))
IF SSPIEN'=""
Begin DoDot:1
+15 SET XD=$PIECE(^ONCO(160,ONCOD0,"SUS",SSPIEN,0),U,1)
+16 SET SR=$PIECE(^ONCO(160,ONCOD0,"SUS",SSPIEN,0),U,3)
+17 SET CS=$SELECT(SR="LS":"Pathology Department Review",SR="LC":"Pathology Department Review",SR="LE":"Pathology Department Review",SR="PT":"Daily Discharge Review",SR="RA":"Diagnostic Imaging/Radiology",1:"")
+18 SET MO=$PIECE(^ONCO(160,ONCOD0,"SUS",SSPIEN,0),U,11)
End DoDot:1
+19 ;
+20 LOCK +^ONCO(165.5,ONCOD0P,0):0
+21 SET DIE="^ONCO(165.5,"
+22 SET DR="W !;.05////^S X=AC;.06////^S X=SEQ;.07//^S X=ACAY;.04;155;3//^S X=XD;20;21//^S X=CS"
+23 SET ACN=AC_"/"_SEQ
SET DA=ONCOD0P
+24 DO ^DIE
+25 LOCK -^ONCO(165.5,ONCOD0P,0)
+26 if $DATA(Y)=0
GOTO PID
DO KLN
GOTO EX
+27 ;
PID ;Continue defining Primary Record
+1 IF SN="02"
IF $DATA(^TMP($JOB,"MAL",1))
IF $PIECE(^TMP($JOB,"MAL",1),U,1)="00"
SET UPDATE="01"
DO UPDT
+2 IF SN=62
IF $DATA(^TMP($JOB,"BEN",1))
IF $PIECE(^TMP($JOB,"BEN",1),U,1)=60
SET UPDATE=61
DO UPDT
+3 SET ONCOACN=AC_"/"_SEQ
SET Y=1
DO KILL
QUIT
+4 ;
UPDT ;Update 00 to 01, update 60 to 61
+1 SET SN=UPDATE
SET DIE="^ONCO(165.5,"
SET DA=REC00
SET DR=".06///^S X=SN"
+2 DO ^DIE
SET D0=ONCOD0P
+3 IF $DATA(REC002)
SET SN=UPDATE
SET DIE="^ONCO(165.5,"
SET DA=REC002
SET DR=".06///^S X=SN"
DO ^DIE
SET D0=ONCOD0P
+4 WRITE !!?5,"The following up-dating has occurred:",!!
DO SDA^ONCOCOM
HANG 2
+5 QUIT
+6 ;
KLN ;KILL entry
+1 SET DA=ONCOD0P
SET DIK="^ONCO(165.5,"
DO ^DIK
DO KILL
+2 READ !?5,"<ENTRY DELETED> - press RETURN to continue->",DA:DTIME
+3 if '$TEST!(DA=U)
QUIT
+4 WRITE !
+5 QUIT
+6 ;
KILL ;KILL variables
+1 KILL AC,ACAY,ACN,ACS,ACSL,ALPHA,AY,BEN,DA,DIC,DIE,DIK,DIR,D0,DR,DTOUT
+2 KILL KK,KKM,KKB,LASTBEN,LASTMAL,LL,MAL,NEXTBEN,NEXTMAL,NUM,ONCOSIT
+3 KILL PRIM,PRIMIEN,REC00,REC002,RECNUM,SEQDIV,SN,SEQ,SQN,UPDATE,X,XD0,XX
+4 KILL ^TMP($JOB,"BEN"),^TMP($JOB,"MAL")
+5 QUIT
+6 ;
EX ;Exit
+1 DO KILL
SET Y=0
+2 QUIT
+3 ;
CLEANUP ;Cleanup
+1 KILL ONCOACN,ONCOD0,ONCOD0P,ONCONM,ONCOP,ONCOPN,ONCOSIT,Y
