ONCOAIC ;HINES OIFO/GWB - Create first primary for a patient ;03/08/11
;;2.2;ONCOLOGY;**1,15,20**;Jul 31, 2013;Build 5
;
EN ;Create first ONCOLOGY PRINMARY (165.5) record
D KILL
W @IOF
W !!?5,"******** CREATE FIRST PRIMARY RECORD FOR THIS PATIENT*******",!!
W:$D(ONCONM) ?5,"PATIENT: ",ONCONM
;
LOOK1 ;Select first primary
K DIC,ONCOPN,ONCOSIT
S DIC="^ONCO(164.2,",DIC(0)="AEQM"
S DIC("A")=" Select first Primary SITE/GP: "
S DIC("S")="I '$P(^(0),U,3)"
W ! D ^DIC K DIC G EX:Y<0
S (XX,X,ONCOSIT)=+Y,ONCOPN=$P(Y,U,2),XD0=ONCOD0
D SEX^ONCOCKI G LOOK1:'$D(X)
;
A2 ;Create first ONCOLOGY PRIMARY (165.5) record for this patient
L +(^ONCO(165.5,"ACAY"),^ONCO(165.5,"ACD"),^ONCO(165.5,"AF")):2
I '$T G ASK
W !
K DIR,ONCOD0P
S DIR("A")=" Ok to ADD:",DIR("B")="Yes",DIR(0)="Y" D ^DIR
G A:Y,EN:Y=0 Q
;
A K DO
W !,?5,"Creating a new Primary record for ",ONCONM
S DIC="^ONCO(165.5,",DIC(0)="Z"
S X=ONCOSIT
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)=""
;
NAN ;New ACCESSION NUMBER (165.5,.05)
K DIR
S DIR(0)="N^:2099",DIR("A")=" ACCESSION YEAR"
S DIR("B")=$E(DT,1)+17_$E(DT,2,3)
S Y=$G(^ONCO(165.5,"ACAY"))
W ! D ^DIR
I Y[U!(Y="") S Y=ONCOD0P D KLN Q
I $L(Y)'=4 W !!?5,"ACCESSION YEAR must be 4 digits!" G NAN
S YR=Y,^ONCO(165.5,"ACAY")=YR,AC=$O(^ONCO(165.5,"ACD",Y,0))
I AC'="" S AC=Y_AC,SEQ="00" G DIE
NA S MR=YR_"00001",XR=999999999-((YR+1)_"00000")
S NR=$O(^ONCO(165.5,"AF",XR))
G AC:NR=""
I NR<(999900002-MR) W !!?5,"SYSTEM appears out of numbers. Looking for unassigned ones" D FND G DIE:Y'="",EX
I NR>(999999999-MR) S NR=""
AC S AC=$S(NR="":YR_"00001",1:(1000000000-NR)),SEQ="00"
S AC=$S($L(AC)=1:"00000"_AC,$L(AC)=2:"0000"_AC,$L(AC)=3:"000"_AC,$L(AC)=4:"00"_AC,$L(AC)=5:"0"_AC,1:AC)
;
DIE S DIE="^ONCO(165.5,",DA=ONCOD0P
S DR="W !,?5;.07///^S X=YR;.05//^S X=AC;.06//^S X=SEQ;.04;155;3;20;22.3;21"
S ACN=AC_"/"_SEQ
D ^DIE
LOCK L -(^ONCO(165.5,"ACAY"),^ONCO(165.5,"ACD"),^ONCO(165.5,"AF")):1 G ASK:'$T,PID:$D(Y)=0 S Y=ONCOD0P D KLN G EX
;
ASK W !
S DIR("A")=" Another user is accessioning. Try Again",DIR(0)="Y"
S DIR("B")="Y"
S DIR("?")=" "
S DIR("?",1)=" Another user is obtaining the next available ACCESSION NUMBER."
S DIR("?",2)=" Please wait a few seconds and try again."
D ^DIR G A2:Y=1
Q
;
FND ;Search for unused accession numbers
S NR=YR_"00000",MR=(YR+1)_"00000"
NR S NR=NR+1 I NR<MR G:$D(^ONCO(165.5,"AA",NR)) NR S AC=NR,SEQ="00",Y=1 Q
W !!?10,"OUT of ACCESSION Numbers for "_YR S Y=""
Q
;
PID ;Continue defining Primary Record
S ONCOACN=AC_"/"_SEQ,Y=1 D KILL Q
;
KLN ;KILL entry
S DA=+Y,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,ACN,DA,DIC,DIE,DIK,DIR,DR
K MR,NR,SEQ,X,XX,XD0,XR,YR
Q
;
EX ;Exit
D KILL S Y=0
Q
;
CLEANUP ;Cleanup
K ONCOACN,ONCOD0,ONCONM,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOAIC 3106 printed Dec 13, 2024@02:24:09 Page 2
ONCOAIC ;HINES OIFO/GWB - Create first primary for a patient ;03/08/11
+1 ;;2.2;ONCOLOGY;**1,15,20**;Jul 31, 2013;Build 5
+2 ;
EN ;Create first ONCOLOGY PRINMARY (165.5) record
+1 DO KILL
+2 WRITE @IOF
+3 WRITE !!?5,"******** CREATE FIRST PRIMARY RECORD FOR THIS PATIENT*******",!!
+4 if $DATA(ONCONM)
WRITE ?5,"PATIENT: ",ONCONM
+5 ;
LOOK1 ;Select first primary
+1 KILL DIC,ONCOPN,ONCOSIT
+2 SET DIC="^ONCO(164.2,"
SET DIC(0)="AEQM"
+3 SET DIC("A")=" Select first Primary SITE/GP: "
+4 SET DIC("S")="I '$P(^(0),U,3)"
+5 WRITE !
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 LOOK1
+8 ;
A2 ;Create first ONCOLOGY PRIMARY (165.5) record for this patient
+1 LOCK +(^ONCO(165.5,"ACAY"),^ONCO(165.5,"ACD"),^ONCO(165.5,"AF")):2
+2 IF '$TEST
GOTO ASK
+3 WRITE !
+4 KILL DIR,ONCOD0P
+5 SET DIR("A")=" Ok to ADD:"
SET DIR("B")="Yes"
SET DIR(0)="Y"
DO ^DIR
+6 if Y
GOTO A
if Y=0
GOTO EN
QUIT
+7 ;
A KILL DO
+1 WRITE !,?5,"Creating a new Primary record for ",ONCONM
+2 SET DIC="^ONCO(165.5,"
SET DIC(0)="Z"
+3 SET X=ONCOSIT
+4 SET DIC("DR")="2000////^S X=DUZ(2);236////^S X=DT;244////^S X=DUZ"
+5 DO FILE^DICN
+6 KILL DIC,X
if Y<0
GOTO EX
+7 SET ONCOD0P=+Y
+8 SET $PIECE(^ONCO(165.5,+Y,0),U,2)=ONCOD0
SET $PIECE(^(7),U,2)=0
+9 SET ^ONCO(165.5,"C",ONCOD0,ONCOD0P)=""
+10 ;
NAN ;New ACCESSION NUMBER (165.5,.05)
+1 KILL DIR
+2 SET DIR(0)="N^:2099"
SET DIR("A")=" ACCESSION YEAR"
+3 SET DIR("B")=$EXTRACT(DT,1)+17_$EXTRACT(DT,2,3)
+4 SET Y=$GET(^ONCO(165.5,"ACAY"))
+5 WRITE !
DO ^DIR
+6 IF Y[U!(Y="")
SET Y=ONCOD0P
DO KLN
QUIT
+7 IF $LENGTH(Y)'=4
WRITE !!?5,"ACCESSION YEAR must be 4 digits!"
GOTO NAN
+8 SET YR=Y
SET ^ONCO(165.5,"ACAY")=YR
SET AC=$ORDER(^ONCO(165.5,"ACD",Y,0))
+9 IF AC'=""
SET AC=Y_AC
SET SEQ="00"
GOTO DIE
NA SET MR=YR_"00001"
SET XR=999999999-((YR+1)_"00000")
+1 SET NR=$ORDER(^ONCO(165.5,"AF",XR))
+2 if NR=""
GOTO AC
+3 IF NR<(999900002-MR)
WRITE !!?5,"SYSTEM appears out of numbers. Looking for unassigned ones"
DO FND
if Y'=""
GOTO DIE
GOTO EX
+4 IF NR>(999999999-MR)
SET NR=""
AC SET AC=$SELECT(NR="":YR_"00001",1:(1000000000-NR))
SET SEQ="00"
+1 SET AC=$SELECT($LENGTH(AC)=1:"00000"_AC,$LENGTH(AC)=2:"0000"_AC,$LENGTH(AC)=3:"000"_AC,$LENGTH(AC)=4:"00"_AC,$LENGTH(AC)=5:"0"_AC,1:AC)
+2 ;
DIE SET DIE="^ONCO(165.5,"
SET DA=ONCOD0P
+1 SET DR="W !,?5;.07///^S X=YR;.05//^S X=AC;.06//^S X=SEQ;.04;155;3;20;22.3;21"
+2 SET ACN=AC_"/"_SEQ
+3 DO ^DIE
LOCK LOCK -(^ONCO(165.5,"ACAY"),^ONCO(165.5,"ACD"),^ONCO(165.5,"AF")):1
if '$TEST
GOTO ASK
if $DATA(Y)=0
GOTO PID
SET Y=ONCOD0P
DO KLN
GOTO EX
+1 ;
ASK WRITE !
+1 SET DIR("A")=" Another user is accessioning. Try Again"
SET DIR(0)="Y"
+2 SET DIR("B")="Y"
+3 SET DIR("?")=" "
+4 SET DIR("?",1)=" Another user is obtaining the next available ACCESSION NUMBER."
+5 SET DIR("?",2)=" Please wait a few seconds and try again."
+6 DO ^DIR
if Y=1
GOTO A2
+7 QUIT
+8 ;
FND ;Search for unused accession numbers
+1 SET NR=YR_"00000"
SET MR=(YR+1)_"00000"
NR SET NR=NR+1
IF NR<MR
if $DATA(^ONCO(165.5,"AA",NR))
GOTO NR
SET AC=NR
SET SEQ="00"
SET Y=1
QUIT
+1 WRITE !!?10,"OUT of ACCESSION Numbers for "_YR
SET Y=""
+2 QUIT
+3 ;
PID ;Continue defining Primary Record
+1 SET ONCOACN=AC_"/"_SEQ
SET Y=1
DO KILL
QUIT
+2 ;
KLN ;KILL entry
+1 SET DA=+Y
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,ACN,DA,DIC,DIE,DIK,DIR,DR
+2 KILL MR,NR,SEQ,X,XX,XD0,XR,YR
+3 QUIT
+4 ;
EX ;Exit
+1 DO KILL
SET Y=0
+2 QUIT
+3 ;
CLEANUP ;Cleanup
+1 KILL ONCOACN,ONCOD0,ONCONM,Y
