ONCOAIC.m

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 ---ONCOAIC   3106     printed  Mar 13, 2025@21:28:56                                                                                                                                                                                                     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