source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAREG2.m@ 767

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1RAREG2 ;HISC/CAH,FPT,DAD,SS AISC/MJK,RMO-Register Patient ;1/12/98 16:08
2 ;;5.0;Radiology/Nuclear Medicine;**13,18**;Mar 16, 1998
3 ;last modif. JULY 5,00 by SS
4ORDER ; Get data from ordered procedure for registration
5 K RACLNC,RALIFN,RALOC,RAPIFN,RAPRC,RARDTE,RARSH,RASHA
6 S Y=^RAO(75.1,+RAOIFN,0),RAPRC=$S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"") S:$D(RADPARFL) RAPRC=RADPARPR ;may not need to redefine raprc ?
7 S RACAT=$S('$D(RAWARD):$P($P(^DD(75.1,4,0),$P(Y,"^",4)_":",2),";"),1:RACAT)
8 D SL^RAREG3 Q:RAQUIT
9 S:"CS"[$E(RACAT)&($D(^DIC(34,+$P(Y,"^",9),0))) RASHA=$P(^(0),"^") S:"R"[$E(RACAT)&($D(^RAO(75.1,+RAOIFN,"R"))) RARSH=^("R")
10 S:$D(^VA(200,+$P(Y,"^",14),0)) RAPIFN=+$P(Y,"^",14) S:$P(Y,"^",21) RARDTE=$P(Y,"^",21) S:$D(^SC(+$P(Y,"^",22),0)) RALIFN=+$P(Y,"^",22)
11 I '$D(RAWARD),$D(RALIFN),$P(^SC(RALIFN,0),"^",3)="C" S RALOC=$P(^(0),"^") S RACLNC=$S('$D(^("SL")):RALOC,$D(^SC(+$P(^("SL"),"^",5),0)):$P(^(0),"^"),1:RALOC)
12 ;check nodes ahead 6/18/96
13 N RAAHEAD
14 S RAAHEAD=$O(^RADPT(RADFN,"DT","B",RADTE))
15 I RAAHEAD[RADTE W *7,!!?5,"Someone else has already started editing a record for this",!?5,"patient at this time, please try a few minutes later." S RAQUIT=1 R !!,"Press RETURN to continue :",RAAHEAD:DTIME
16 Q
17EXAMLOOP ; register the exam
18 N REM ;this is used by the edit template
19 S DA=RADFN,RACN="N",DIE("NO^")="OUTOK",DR="[RA REGISTER]",DIE="^RADPT(" D ^DIE K DIE("NO^"),DE,DQ
20 K RAPOP,RAFM,RAFM1,RAI,RAMOD,RASTI,RACMTHOD,RANMFLG,RAIEN702 ;moved from edit template
21 S RACNICNT=RACNICNT+1
22 S ^TMP($J,"RAREG1",RACNICNT)=RADFN_U_RADTI_U_RACNI_U_RAOIFN
23 I '$D(RAFIN) D Q
24 . W !?3,*7,"Exam entry not complete. Must delete..."
25 . S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
26 . S DIK="^RADPT(DA(2),""DT"",DA(1),""P""," D ^DIK
27 . K ^TMP($J,"RAREG1",RACNICNT)
28 . K RAPX ; added in RA*5*13 to stop labels & flash cards in RAREG1
29 . Q
30 S RAPARENT=$S($G(RAPARENT):RAPARENT,$P($G(^RAMIS(71,RAPROC,0)),U,6)="P":1,1:+$G(RAPARENT))
31 I $D(^RAO(75.1,+RAOIFN,"H")) S:$D(^("H",0)) ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)=^(0) F I=1:1 Q:'$D(^RAO(75.1,+RAOIFN,"H",I,0)) S ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)=^(0)
32 S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,RAREC=""
33 S:$D(RADPARFL) ^TMP($J,"PRO-REG",RAPROCI,RAOIFN)=""
34 K RAFIN,DR
35 K RACLNC,RALIFN,RALOC,RAOSTS,RAPHY,RAPRC,RARDTE,RARSH,RASHA
36 Q
37EXAMDEL ; Delete examset if incomplete
38 W !!?3,*7,"Exam entry not complete. Must delete all descendent exams..."
39 S RATMP=0
40 F S RATMP=$O(^TMP($J,"RAREG1",RATMP)) Q:RATMP'>0 D
41 . S RA=^TMP($J,"RAREG1",RATMP)
42 . S RAOIFN=$P(RA,U,4),(RADFN,DA(2))=$P(RA,U)
43 . S (RADTI,DA(1))=$P(RA,U,2),(RACNI,DA)=$P(RA,U,3)
44 . S DIK="^RADPT(DA(2),""DT"",DA(1),""P""," D ^DIK
45 . K ^TMP($J,"RAREG1",RATMP),RAPX(RATMP)
46 . K DIE,DR S DIE="^RAO(75.1,",DA=RAOIFN,DR="5///5" D ^DIE K DIE,DR
47 . Q
48 W !?3,"Deletion complete!",!
49 Q
50XTRADESC ; Ask extra descendent procedures for a parent
51 N RASKIPIT S RASKIPIT=0
52 F D Q:RASKIPIT!RAEXIT!RAQUIT
53 . N DIR S DIR(0)="Y"
54 . S DIR("A")="Register another descendent exam for "_RANME_" (Y/N)"
55 . W ! D ^DIR
56 . S RAEXIT=$S($D(DTOUT)!$D(DUOUT):1,1:0),RASKIPIT='Y
57 . I RASKIPIT!RAEXIT Q
58 . D ORDER K RAPRC Q:RAQUIT
59 . D EXAMLOOP,MEMSET(RADFN,RADTI,RACNI)
60 . Q
61 Q
62EXAMSET ; Set the EXAM SET field if a parent is registered
63 N DA,DIE,DR,Y
64 S DIE="^RADPT("_RADFN_",""DT"","
65 S DA(1)=RADFN,DA=RADTI
66 S DR="5///^S X=$S($G(RAPARENT):''RAPARENT,1:""@"")"
67 D ^DIE
68 Q
69MEMSET(RAX,RAY,RAZ) ; Set 'MEMBER OF SET' field on the exam node
70 ; if the procedure is a descendant procedure.
71 ; Var List: RAX <-> RADFN : RAY <-> RADTI : RAZ <-> RACNI
72 Q:$G(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']""
73 N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
74 S DIE="^RADPT("_RAX_",""DT"","_RAY_",""P"","
75 S DA(2)=RAX,DA(1)=RAY,DA=RAZ,DR="25///"_$S($P($G(^RAMIS(71,+RAPROC,0)),"^",18)="Y":2,1:1) D ^DIE ;2=combined report, 1=separate reports
76 Q
77SET17(RAX,RAY,RAZ) ; Set piece 17 on exam node
78 Q:$G(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']""
79 N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
80 S DIE="^RADPT("_RAX_",""DT"","_RAY_",""P"","
81 S DA(2)=RAX,DA(1)=RAY,DA=RAZ,DR="17///"_RA17 D ^DIE
82 Q
83UOSM ; called from RAREG1
84 ; update order status and send OE v3.0 message
85 ; This code will $O through the ^TMP($J,"RAREG1" global and make
86 ; just one call per order/request number to ^RAORDU to update the
87 ; status in File 75.1. One call to ^RAORDU per order/request number
88 ; means only one HL7 type message per order/request will be sent to
89 ; OE v3.0.
90 ;
91 Q:'$D(^TMP($J,"RAREG1"))
92 N RACNT,RAORDNUM,RATMPNDE
93 S RACNT=0
94 F S RACNT=$O(^TMP($J,"RAREG1",RACNT)) Q:RACNT'>0 D
95 .S RATMPNDE=$G(^TMP($J,"RAREG1",RACNT))
96 .S RAOIFN=$P(RATMPNDE,U,4) I RAOIFN D
97 ..Q:$D(RAORDNUM(RAOIFN))
98 ..S RAPROC=$P(^RAO(75.1,+RAOIFN,0),U,2)
99 ..N RA18PCHG S RA18PCHG=$$EN1^RAO7XX(RAOIFN) ;P18 - if the proc changed, sends XX mess, sets RA18PCHG=1 for RAORDU
100 ..S RAOSTS=6 D ^RAORDU
101 ..S RAORDNUM(RAOIFN)=""
102 ..Q
103 .Q
104 Q
105CKDUPORD ; ck for dupl procedures in outstanding orders
106 S RA6="",RA8=0
107CKD1 S RA6=$O(^TMP($J,"PRO-REG",RA6)) Q:'RA6
108 S RA7=$O(^TMP($J,"PRO-REG",RA6,0)) G:'RA7 CKD1
109 K ^TMP($J,"PRO-ORD",RA6,RA7) ; kill hook for order of regist'd proc
110 G:'$O(^TMP($J,"PRO-ORD",RA6,0)) CKD1
111 W:'RA8 !!?5,"Of the procedures you just registered,",!?5,"the following procedure(s) are still in outstanding order(s) :",*7,!
112 S RA8=1
113 S RA7=""
114 F S RA7=$O(^TMP($J,"PRO-ORD",RA6,RA7)) Q:'RA7 W !?5,$P(^RAMIS(71,RA6,0),U) W:^TMP($J,"PRO-ORD",RA6,RA7)="DESC" ?35,"(parent=",$P(^RAMIS(71,$P($G(^RAO(75.1,RA7,0)),U,2),0),U),")"
115 G CKD1
116COPYFROM(RAZ) ;called by RAREG1 if add exam shd copy dx/staff/resident
117 ;RAZ is "P"-node's ien of newly added case of set
118 Q:'$D(RAFIRST)#2 ;RAFIRST is "P"-node's ien of first case of set
119 Q:$G(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0))']""
120 Q:$G(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0))']""
121 N RA,RA2,RA3,RA5 S RA5=0
122 ; RA is a dummy var
123 ; RA2 is used by data server call in RARTE2
124 ; RA3 is used by COPYn^RARTE2 as a dummy var
125 ; RA5=1 if any data got copied over to the new case
126 N RA1PR,RA1PS ; prim res/staff
127 N RA1SR,RA1SS ; sec res/staff arrays
128 N RA1PD,RA1SD ; prim diag, then sec diags arrays
129 N RAFDA,RAIEN,RAMSG,RAXIT
130 S RAXIT=0
131 S RA2=RAZ_","_RADTI_","_RADFN
132 ; get data from first case of set
133 S RA1PR=$P(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0),U,12),RA1PS=$P(^(0),U,15),RA1PD=$P(^(0),U,13)
134 I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",0)) S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",RA)) Q:+RA'=RA S RA1SR(RA)=+(^(RA,0))
135 I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",0)) S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",RA)) Q:+RA'=RA S RA1SS(RA)=+(^(RA,0))
136 I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",0)) S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",RA)) Q:+RA'=RA S RA1SD(RA)=+(^(RA,0))
137 ; copy data from first case of set to new case
138 S:RA1PR $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,12)=RA1PR,RA5=1
139 S:RA1PS $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,15)=RA1PS,RA5=1
140 S:RA1PD $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,13)=RA1PD,RA5=1
141 I $O(RA1SR("")) S RA3="" D COPY3^RARTE2 S RA5=1
142 I $O(RA1SS("")) S RA3="" D COPY4^RARTE2 S RA5=1
143 I $O(RA1SD("")) S RA3="" D COPY5^RARTE2 S RA5=1
144 Q:'RA5
145 ; set xref for this new case only
146 S DIK="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
147 S DA(2)=RADFN,DA(1)=RADTI,DA=RAZ
148 D IX1^DIK
149 Q
Note: See TracBrowser for help on using the repository browser.