source: WorldVistAEHR/trunk/r/ONCOLOGY-ONC/ONCOAIC.m@ 1766

Last change on this file since 1766 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1ONCOAIC ;Hines OIFO/GWB - CREATE FIRST PRIMARY RECORD ;7/20/93
2 ;;2.11;ONCOLOGY;**1,24,25,27,32,42,44,45**;Mar 07, 1995
3 ;
4EN ;Create first ONCOLOGY PRINMARY (165.5) record
5 D KILL
6 W @IOF
7 W !!?5,"******** CREATE FIRST PRIMARY RECORD FOR THIS PATIENT*******",!!
8 W:$D(ONCONM) ?5,"PATIENT: ",ONCONM
9 ;
10LOOK1 ;Select first primary
11 K DIC
12 S DIC="^ONCO(164.2,",DIC(0)="AEQM"
13 S DIC("A")=" Select first Primary SITE/GP: "
14 S DIC("S")="I '$P(^(0),U,3)"
15 W ! D ^DIC K DIC G EX:Y<0
16 S (XX,X,ONCOSIT)=+Y,ONCOPN=$P(Y,U,2),XD0=ONCOD0
17 D SEX^ONCOCKI G LOOK1:'$D(X)
18 ;
19A2 ;Create first ONCOLOGY PRIMARY (165.5) record for this patient
20 L +(^ONCO(165.5,"ACAY"),^ONCO(165.5,"ACD"),^ONCO(165.5,"AF")):2
21 I '$T G ASK
22 W !
23 K DIR,ONCOD0P
24 S DIR("A")=" Ok to ADD:",DIR("B")="Yes",DIR(0)="Y" D ^DIR
25 G A:Y,EN:Y=0 Q
26 ;
27A K DO
28 W !,?5,"Creating a new Primary record for ",ONCONM
29 S DIC="^ONCO(165.5,",DIC(0)="Z"
30 S X=ONCOSIT
31 S DIC("DR")="2000////^S X=DUZ(2)"
32 D FILE^DICN
33 K DIC,X G EX:Y<0
34 S ONCOD0P=+Y
35 S $P(^ONCO(165.5,+Y,0),U,2)=ONCOD0,$P(^(7),U,2)=0
36 S ^ONCO(165.5,"C",ONCOD0,ONCOD0P)=""
37 ;
38NAN ;New ACCESSION NUMBER (165.5,.05)
39 K DIR
40 S DIR(0)="N^:2099",DIR("A")=" ACCESSION YEAR"
41 S DIR("B")=$E(DT,1)+17_$E(DT,2,3)
42 S Y=$G(^ONCO(165.5,"ACAY"))
43 W ! D ^DIR
44 I Y[U!(Y="") S Y=ONCOD0P D KLN Q
45 I $L(Y)'=4 W *7,!!?5,"ACCESSION YEAR must be 4 digits!" G NAN
46 S YR=Y,^ONCO(165.5,"ACAY")=YR,AC=$O(^ONCO(165.5,"ACD",Y,0))
47 I AC'="" S AC=Y_AC,SEQ="00" G DIE
48NA S MR=YR_"00001",XR=999999999-((YR+1)_"00000")
49 S NR=$O(^ONCO(165.5,"AF",XR))
50 G AC:NR=""
51 I NR<(999900002-MR) W *7,!!?5,"SYSTEM appears out of numbers. Looking for unassigned ones" D FND G DIE:Y'="",EX
52 I NR>(999999999-MR) S NR=""
53AC S AC=$S(NR="":YR_"00001",1:(1000000000-NR)),SEQ="00"
54 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)
55 ;
56DIE S DIE="^ONCO(165.5,",DA=ONCOD0P
57 S DR="W !,?5;.07///^S X=YR;.05//^S X=AC;.06//^S X=SEQ"
58 S ACN=AC_"/"_SEQ
59 D ^DIE
60LOCK 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
61 ;
62ASK W !
63 S DIR("A")=" Another user is accessioning. Try Again",DIR(0)="Y"
64 S DIR("B")="Y"
65 S DIR("?")=" "
66 S DIR("?",1)=" Another user is obtaining the next available ACCESSION NUMBER."
67 S DIR("?",2)=" Please wait a few seconds and try again."
68 D ^DIR G A2:Y=1
69 Q
70 ;
71FND ;Search for unused accession numbers
72 S NR=YR_"00000",MR=(YR+1)_"00000"
73NR S NR=NR+1 I NR<MR G:$D(^ONCO(165.5,"AA",NR)) NR S AC=NR,SEQ="00",Y=1 Q
74 W *7,!!?10,"OUT of ACCESSION Numbers for "_YR S Y=""
75 Q
76 ;
77PID ;Continue defining Primary Record
78 S ONCOACN=AC_"/"_SEQ,Y=1 D KILL Q
79 ;
80KLN ;KILL entry
81 S DA=+Y,DIK="^ONCO(165.5," D ^DIK,KILL
82 R !?5,"<ENTRY DELETED> - press RETURN to continue->",DA:DTIME
83 Q:'$T!(DA=U)
84 W !
85 Q
86 ;
87KILL ;KILL variables
88 K AC,ACN,DA,DIC,DIE,DIK,DIR,D0,DR,DUOUT,DTOUT
89 K MR,NR,SEQ,X,XX,XD0,XR,YR
90 Q
91 ;
92EX ;Exit
93 D KILL S Y=0
94 Q
Note: See TracBrowser for help on using the repository browser.