source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAREG1.m@ 1806

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

initial load of FOIAVistA 6/30/08 version

File size: 7.0 KB
Line 
1RAREG1 ;HISC/CAH,FPT,DAD AISC/MJK,RMO-Register Patient ;10/15/97 09:34
2 ;;5.0;Radiology/Nuclear Medicine;**7,21**;Mar 16, 1998
3ASKORD I $D(RAVSTFLG),$G(YY)]"",$P(YY,U,5) D ASET G PACS
4 ; radparfl = 1 if user chose detail-to-parent conversion
5 ; radparpr = ien of file 74 of parent proc to replace detail proc
6 K RADPARPR,RADPARFL
7 S RAOLP=0,RAOVSTS="3;5;8" W ! D ^RAORDS G Q1:$D(RAOUT) G EXAM:$D(RAORDS)
8 S RARD("A")="Do you want to Request an Exam for "_RANME_"? ",RARD(0)="S",RARD(1)="Yes^enter a request.",RARD(2)="No^not enter a request.",RARD("B")=2 D SET^RARD K RARD G Q1:$E(X)'="Y"
9 W !!?3,"...requesting an exam for ",RANME,"...",! D ^RAORD1
10EXAM ;
11 ; block mixture of single proc with parent procedures
12 N RA6,RA7,RA8 S RA6="",RA7=0,RA8=0
13 F S RA6=$O(RAORDS(RA6)) Q:'RA6 S:$P($G(^RAMIS(71,$P(^RAO(75.1,+RAORDS(RA6),0),U,2),0)),U,6)="P" RA7=1 S:$P($G(^RAMIS(71,$P(^RAO(75.1,+RAORDS(RA6),0),U,2),0)),U,6)'="P" RA8=1
14 I RA7,RA8 W !!?7,*7,"You may not register a mixture of single and parent procedures.",! G Q1
15 ;
16 I $G(RADPARFL) D G:Y<1 Q1 ; process detail-to-parent
17 . D PSETPNT^RAREG4
18 . Q
19 S RAPARENT=+$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,5)
20 K ^TMP($J,"RAREG1") S (RAEXIT,RAQUIT,RASKIPIT,RACNICNT)=0
21 D RSBIT^RAREG3
22 F RAOLP=1:1 S RAOIFN=$G(RAORDS(RAOLP)) Q:'RAOIFN!RAEXIT!RAQUIT D
23 . D PROCESS^RAREG4
24 . Q
25 I RAEXIT,RAPARENT D EXAMDEL^RAREG2
26 I $D(^TMP($J,"RAREG1")) D UOSM^RAREG2
27PACS I $D(^TMP($J,"RAREG1")) S RACNT=0 F S RACNT=$O(^TMP($J,"RAREG1",RACNT)) Q:'RACNT D
28 .S RAREGTMP=$G(^TMP($J,"RAREG1",RACNT)),RADFN=$P(RAREGTMP,U,1),RADTI=$P(RAREGTMP,U,2),RACNI=$P(RAREGTMP,U,3)
29 .D REG^RAHLRPC
30 .Q
31 K RAREGTMP
32 D:$D(RADPARFL) CKDUPORD^RAREG2 ; ck for dupl procs in outstndg orders
33Q I '$D(RAREC) W !!?3,*7,"No exams entered for this visit. Must delete..." S DA(1)=RADFN,DA=RADTI,DIK="^RADPT(DA(1),""DT""," D ^DIK W "...deletion complete!" K RAPX
34 D LABEL^RAREG3
35Q1 D Q4^RAREG4
36 G PAT^RAREG
37 ;
38 ;CN entry point is called every time a new case number is assigned.
39 ;The next available CN and last date CN's were "recycled" is stored in
40 ;^RA(79.2,1,"CN")=Next availabe CN ^ date last recycled.
41 ;This routine uses the next available CN unless it has been used for
42 ;the same exam date before (DUP checks for duplicate case/date pair).
43 ;Then the next available CN is calculated and written to the first
44 ;piece of ^RA(79.2,1,"CN"). The node is locked during this transaction.
45CN ;VARIABLES RATYPE,RADT AND RASET MUST EXIST AT THIS POINT
46 L +^RA(79.2,RATYPE,"CN") D CAL:'$D(^RA(79.2,RATYPE,"CN")),CAL:DT>$P(^("CN"),"^",2),CAL:+^("CN")>99999 S RAX=+^RA(79.2,RATYPE,"CN") D DUP
47 ; need recalculate if DUP returns an over 99999 value
48 I RAX>99999 D CAL S RAX=+^RA(79.2,RATYPE,"CN") D DUP
49 I 'RASET S X=RAX G CNQ
50 I $D(X),X'="N",X'=RAX W !!,*7,"New case number must be equal to '",RAX,"'. OK? YES// " R RANS:DTIME K X I RANS["N"!(RANS["n")!('$T) G CNQ
51 S X=RAX
52 ; get next available short case number for future registration
53 ; re-set "CN" node if future short case number >99999
54 ; NOTE1: find and store next free case number for future use 091300
55 F RAJ=(^RA(79.2,RATYPE,"CN")+1):1 I '$D(^RADPT("AE",RAJ)) S ^("CN")=RAJ_"^"_$P(^RA(79.2,RATYPE,"CN"),"^",2) Q
56 ; if the next free case no. for future use is >99999, need recalculate
57 I +^RA(79.2,RATYPE,"CN")>99999 D CAL
58CNQ L -^RA(79.2,RATYPE,"CN")
59 I $D(X),X>99999 W !!?3,*7,"You have reached the maximum limit for case numbers (99,999).",!?3,"You must first complete/purge your old exams before you can proceed." K X
60 K RAJ,RATYPE,RASET,RAX,RANS,RADT Q
61DUP ;Check to prevent use of same case number/date pair ;ch
62 ; both short and long case numbers will be checked for duplicates 091500
63 S RADTE99=$S('$D(RADTE):"",1:$E(RADTE,4,5)_$E(RADTE,6,7)_$E(RADTE,2,3))
64 I '$D(^RADPT("AE",RAX)),'$D(^RADPT("ADC",RADTE99_"-"_RAX)) G DUPQ
65 ; also check ADC xref while searching for next available number 08/15/00
66 ; note2: even though the current available case number is being
67 ; stored, the next free case number for future use will be
68 ; found and stored later, see note1 above 091300
69 F RAJ=(^RA(79.2,RATYPE,"CN")+1):1 I '$D(^RADPT("AE",RAJ)),'$D(^RADPT("ADC",RADTE99_"-"_RAJ)) S ^("CN")=RAJ_"^"_$P(^RA(79.2,RATYPE,"CN"),"^",2) S RAX=+^RA(79.2,RATYPE,"CN") Q
70DUPQ K RADTE99 Q
71 ;
72 ; the CAL section is called if :
73 ; there isn't a ^RA(79.2,RATYPE,"CN")
74 ; or today's date is after the date in ^RA(79.2,RATYPE,"CN") piece 2
75 ; or ^RA(79.2,RATYPE,"CN") piece 1 is > 99999, this is
76 ; checked in two places :
77 ; before using this piece 1 as the next case number
78 ; and after calculating future free case number
79 ; or DUP section returns a case number > 99999
80 ;
81 ; the first calculation starts from today's date and finds the date
82 ; for the next Saturday
83 ; %Y=day of week, 6 being Saturday
84 ;
85 ; the second calculation starts from ^RADPT("AE",1 and finds the
86 ; lowest n where ^RADPT("AE",n) doesn't exist anymore.
87 ;
88 ; then the results are used to replace ^RA(79.2,RATYPE,"CN")
89 ; where
90 ; piece 1 is the next free case number
91 ; piece 2 is the date for next Saturday
92 ; RATYPE is always 1 by design
93 ;
94CAL K RAXX S:$D(X) RAXX=X S RAX=DT F RAII=0:0 S X1=RAX,X2=1 D C^%DTC S RAX=X D H^%DTC Q:%Y=6
95 D YMD^%DTC F RAJ=1:1 I '$D(^RADPT("AE",RAJ)) S ^RA(79.2,RATYPE,"CN")=RAJ_"^"_X S:$D(RAXX) X=RAXX Q
96 K RAJ,RAXX,RAX,RAII Q
97PROC(Y) Q $P($G(^RAMIS(71,+Y,0)),U)
98ASET ; register extra cases for a exam/print set that has no VALID report yet
99 ; there may be a stub report from imaging for this set
100 S RAREC="" ; prevent Q from deleting the exam at "DT" level
101 S (RAEXIT,RAQUIT,RASKIPIT,RACNICNT)=0 K ^TMP($J,"RAREG1")
102 N RAFIRST S RAFIRST=$O(^RADPT(RADFN,"DT",RADTI,"P",0)) Q:'RAFIRST
103 S RAOIFN=$P(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0),"^",11) ;imagg order ien
104 N DIR
105PS1 S DIR(0)="Y",DIR("A")="For "_RANME_"'s exam set -- register another descendent exam (Y/N)"
106 W ! D ^DIR Q:'Y
107 N RAPARENT S RAPARENT=1 D ORDER^RAREG2 ;preserve EXAM SET stored data
108 Q:RAQUIT ;6/18/96
109 K RAPRC S RAPARENT=1 D EXAMLOOP^RAREG2 ;prevent undef RAPROC in EXAMLOOP
110 ; RACNI is set by edit tmpl that's used in EXAMLOOP^RAREG2
111 ; quit if registration was incomplete <-- rareg2 deleted entire case
112 Q:'$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
113 S RAPROC=$P($G(^RAO(75.1,+$G(RAOIFN),0)),U,2) ;ien of parent procedure
114 ; set value of MEMBER OF SET
115 ; can't call memset^rareg2 to set MEMBER OF SET, due possiblity of
116 ; orig. proc being a single procedure that got converted to printset
117 N RA25 S RA25=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0)),U,25)
118 I RA25 N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DR="25///"_RA25,DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," D ^DIE
119 G:RA25'=2 PS1
120 ; combined report need more processing
121 G:'$G(RA17) PS1 G:'$D(^RARPT(+$G(RA17),0))#2 PS1
122 ; since there's a stub rpt from imaging (RA17), set piece 17
123 D SET17^RAREG2(RADFN,RADTI,RACNI)
124 ; copy over any dx/res/staff
125 D COPYFROM^RAREG2(RACNI)
126 ; insert rec in 74.05
127 N RARPT,RARPTN,RA1,RAFDA,RAIEN,RAMSG,RAERR,RAXIT
128 S RARPT=RA17,RARPTN=$P(^RARPT(RARPT,0),U),RA1=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U)
129 D:RA1 INSERT^RARTE2
130 G PS1
Note: See TracBrowser for help on using the repository browser.