RACNLU ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Case Number Lookup ;11/13/00 09:13
;;5.0;Radiology/Nuclear Medicine;**7,15,23,47**;Mar 16, 1998;Build 21
CASE N RADIV,RAIMAGE,RANODE
R !!,"Enter Case Number: ",X:DTIME S:'$T!(X="") X="^" G Q:X="^"
I X?1A W !?3,*7,"You must enter more than one character of the name!" G CASE
I X?1A.AP!(X?1A4N)!(X?9N) S RAHEAD="**** Case Lookup by Patient ****",DIC(0)="EMQ" D ^RADPA G CASE:Y<0 S RADFN=+Y G ^RAPTLU
I X?16.N.E D QUES G CASE
D SPACE:X=" " G Q:X="^" D QUES:'X&(X'="??") G CASE:X="^" D SEL G CASE:"^"[X!('RACNT) F I=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",I)=$P(Y,"^",I)
W:RACNT'=1 !!?1,"Case No.: ",RACN,?16,"Procedure: ",$E(RAPRC,1,30),?58,"Name: ",$E(RANME,1,20)
I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
Q K I,RACNT,RADTCN,RAEND,RAFL,RAFST,RAIX,^TMP("MAG",$J,"COL"),^TMP("MAG",$J,"ROW") Q
;
SEL ;
K ^TMP($J,"RAEX") S RACNT=0 G ADC:X["-" S RAFST=$S(X:X-.01,1:0),RAEND=$S(X:X,1:99999),X="",RAIX="AE"
;S RAXHOLD=X ;don't need MAG calls anymore 111300
;I $$IMAGE^RARIC1 D MED^MAGSET3,ERASE^MAGSET3
;S X=RAXHOLD K RAXHOLD
F RACN=RAFST:0 Q:X="^"!(X>0) S RACN=$O(^RADPT(RAIX,RACN)) Q:RACN'>0!(RACN>RAEND) F RADFN=0:0 S RADFN=$O(^RADPT(RAIX,RACN,RADFN)) Q:RADFN'>0 S RADTI=$O(^(RADFN,0)),RACNI=$O(^(RADTI,0)) S X="" D PRT Q:X="^"!(X>0)
G CHK
ADC ;S RAIX="ADC",RACN=$P(X,"-",2),RADTCN=X,X=""
S RAIX="ADC",RACN=$P(X,"-",$L(X,"-")),RADTCN=$S($L(X,"-")=3:$P(X,"-",2,3),1:X),X=""
F RADFN=0:0 S RADFN=$O(^RADPT(RAIX,RADTCN,RADFN)) Q:RADFN'>0 S RADTI=$O(^(RADFN,0)),RACNI=$O(^(RADTI,0)) S X="" D PRT Q:X="^"!(X>0)
I 'RACNT D ADC1
CHK Q:X="^"!(X>0) I 'RACNT W !?3,*7,"No matches found!" Q
;Q:X="^"!(X>0) I 'RACNT W !?3,*7,"No matches found!" Q
I RACNT=1 S X=1,Y=^TMP($J,"RAEX",1) D:$D(RAOPT("EDITCN")) CHECK Q
CHK1 Q:'(RACNT#15) W !,"CHOOSE FROM 1-",RACNT,": " R X:DTIME S:'$T!(X="") X="^" Q:X="^" I X["?" D HLP G CHK1
I '$D(^TMP($J,"RAEX",+X)) S X="^" W *7," ??" Q
S Y=^TMP($J,"RAEX",+X) D:$D(RAOPT("EDITCN")) CHECK Q
PRT S RAFL=0 Q:'$D(^RADPT(RADFN,0))!('$D(^DPT(RADFN,0))) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^")
K RADIV ;this var must be cleared so can detect bad ^RADPT("AE" ;111500
I $D(^RADPT(RADFN,"DT",RADTI,0)) D Q:'RAFL
. S RANODE=$G(^RADPT(RADFN,"DT",RADTI,0))
. S RADIV=+$P(RANODE,"^",3),RAIMAGE=+$P(RANODE,"^",2),RADIVIEN=RADIV
. S RADIV=+$G(^RA(79,RADIV,0)),RADIV=$P($G(^DIC(4,RADIV,0)),"^")
. S:RADIV']"" RADIV="Unknown"
. S RAIMAGE=$P($G(^RA(79.2,RAIMAGE,0)),"^")
. S:RAIMAGE']"" RAIMAGE="Unknown"
. S (Y,RADTE)=+$P(RANODE,"^") D D^RAUTL S RADATE=Y
. I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RAFL=1,Y=^(0)
. Q
I '$D(RADIV) Q ;possible corrupted "AE" active case x-ref on ^RADPT
; pointing to a non-existent visit node
; Note: if $D(ORVP) the screen logic is to be ignored. We have entered
; through OE/RR. Even if we are not screening, the user may have
; already selected various Division(s) and Imaging type(s) which are
; in ^TMP($J,"RA D-TYPE" and ^TMP($J,"RA I-TYPE". If RANOSCRN is
; defined, it means no screening by imaging types to which the
; user has access privilege.
I '$D(ORVP),($D(RANOSCRN)),('$D(RADUPSCN)) I $D(^TMP($J,"RA D-TYPE"))!($D(^TMP($J,"RA I-TYPE"))) Q:'$D(^TMP($J,"RA D-TYPE",RADIV))!('$D(^TMP($J,"RA I-TYPE",RAIMAGE)))
; If in 'Case No. Exam Edit' option, skip i-type check in the next line
I '$D(ORVP),('$D(RADUPSCN)),('$D(RAOPT("EDITCN"))) Q:$$IMGTY^RAUTL12("e",RADFN,RADTI)'=RAIMGTY&('$D(RANOSCRN))
S RAST=+$P(Y,"^",3),RARPT=+$P(Y,"^",17),RAPRC=$S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"Unknown"),RACNT=RACNT+1
S ^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST
;I $$IMAGE^RARIC1 D DISPA^MAGRIC ; don't need MAG calls anymore 111300
I RACNT=1,$S('$D(RAEND):1,RAEND<99999:1,1:0),$D(RAVW),$O(^RADPT(RAIX,$S(RAIX="ADC":RADTCN,1:RACN),RADFN))'>0 S X=1,Y=^TMP($J,"RAEX",1) Q
N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:$$LCASE(RADTE,RACN))
I $$USESSAN^RAHLRU1() D HD:RACNT=1 W !?1,RACNT,?7,RACNDSP W:$O(^RARPT(RARPT,2005,0)) ?22,"i" W ?24,$E(RAPRC,1,25),?50,$E(RANME,1,22),?74,$$SSN^RAUTL(RADFN,1) Q:RACNT#15
I '$$USESSAN^RAHLRU1() D HD:RACNT=1 W !?1,RACNT,?7,$$LCASE(RADTE,RACN) W:$O(^RARPT(RARPT,2005,0)) ?22,"i" W ?24,$E(RAPRC,1,25),?50,$E(RANME,1,22),?74,$$SSN^RAUTL(RADFN,1) Q:RACNT#15
PRT1 W !,"Type '^' to STOP, or",!,"CHOOSE FROM 1-",RACNT,": " R X:DTIME S:'$T X="^" Q:X="^"!(X="") I X["?" D HLP G PRT1
I '$D(^TMP($J,"RAEX",+X)) W *7," ??" S X="^" Q
S X=+X,Y=^TMP($J,"RAEX",X) Q
;
HD W !!,"Choice",?7,"Case No.",?24,"Procedure",?50,"Name",?74,"Pt ID",!,"------",?7,"---------------",?24,"---------",?50,"-----------------",?74,"------" Q
;
SPACE I $D(^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")) S X=^("CASE #") I $D(^RADPT(+$P(X,"^"),"DT",+$P(X,"^",2),"P",+$P(X,"^",3),0)) S RADTX=$P($P(X,"^",2),"."),X=+^(0) S X=$$LCASE(9999999-RADTX,X) W " ",X K RADTX Q
S X="^" Q
;
QUES W !,"Enter an active case number in the following form '999'..."
W !?10,"...or enter a completed case number as 'MMDDYY-999'"
W !?10,"...or enter a patient's name"
W !?10,"...or enter a patient's 9-digit SSN"
W !?10,"...or enter the first character of the patient's",!?13,"last name and the last four digits of their SSN."
ASKACT R !!,"Do you wish to see the entire list of active cases? NO// ",X:DTIME S X=$E(X) S:'$T!("Nn"[X) X="^" I "Yy"'[X,X'="^" W:X'="?" *7 W !!?3,"Enter 'YES' to list all active cases, or 'NO' not to." G ASKACT
S:"Yy"[X X="??" Q
HLP W !!?3,"Enter the number corresponding to the exam you wish to select.",! Q
LCASE(RADT,RACN) ; Pass back the long case number.
; Input : RADT -> FM date (internal format)
; RACN -> Case #
; Output: long case number i.e, '010197-100'
; RTK 3/16/2009 ADDED NEXT 2 LINES FOR USE WITH SSAN P47
Q $TR($TR($$FMTE^XLFDT(RADT,"2FD")," ","0"),"/","")_"-"_RACN
CHECK ; Check if the exam selected is of the same imaging type as the sign-on
; location. Must be in the 'Case No. Exam Edit' option.
Q:'$D(RAOPT("EDITCN")) N RAMASK,RARTRN S RAMASK=Y
I $$IMGTY^RAUTL12("e",$P(Y,"^"),$P(Y,"^",2))'=RAIMGTY D
. N X S RARTRN=$$SW^RAPSET1($$IMGTY^RAUTL12("e",$P(Y,"^"),$P(Y,"^",2)),RAIMGTY)
. Q
W:+$G(RARTRN) !!,$P(RARTRN,"^",2),$C(7)
S Y=RAMASK
I +$G(RARTRN) S X="^" K RADFN,RADTI,RACNI,RANME,RASSN,RADATE,RADTE,RACN,RAPRC,RARPT,RAST,RAEND,RAFST,RAIX
Q
ADC1 ;
S RAIX="ADC1"
F RADFN=0:0 S RADFN=$O(^RADPT(RAIX,RADTCN,RADFN)) Q:RADFN'>0 S RADTI=$O(^(RADFN,0)),RACNI=$O(^(RADTI,0)) S X="" D PRT Q:X="^"!(X>0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRACNLU 6805 printed Apr 09, 2024@21:41:25 Page 2
RACNLU ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Case Number Lookup ;11/13/00 09:13
+1 ;;5.0;Radiology/Nuclear Medicine;**7,15,23,47**;Mar 16, 1998;Build 21
CASE NEW RADIV,RAIMAGE,RANODE
+1 READ !!,"Enter Case Number: ",X:DTIME
if '$TEST!(X="")
SET X="^"
if X="^"
GOTO Q
+2 IF X?1A
WRITE !?3,*7,"You must enter more than one character of the name!"
GOTO CASE
+3 IF X?1A.AP!(X?1A4N)!(X?9N)
SET RAHEAD="**** Case Lookup by Patient ****"
SET DIC(0)="EMQ"
DO ^RADPA
if Y<0
GOTO CASE
SET RADFN=+Y
GOTO ^RAPTLU
+4 IF X?16.N.E
DO QUES
GOTO CASE
+5 if X=" "
DO SPACE
if X="^"
GOTO Q
if 'X&(X'="??")
DO QUES
if X="^"
GOTO CASE
DO SEL
if "^"[X!('RACNT)
GOTO CASE
FOR I=1:1:11
SET @$PIECE("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",I)=$PIECE(Y,"^",I)
+6 if RACNT'=1
WRITE !!?1,"Case No.: ",RACN,?16,"Procedure: ",$EXTRACT(RAPRC,1,30),?58,"Name: ",$EXTRACT(RANME,1,20)
+7 IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
SET ^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI
SET Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
Q KILL I,RACNT,RADTCN,RAEND,RAFL,RAFST,RAIX,^TMP("MAG",$JOB,"COL"),^TMP("MAG",$JOB,"ROW")
QUIT
+1 ;
SEL ;
+1 KILL ^TMP($JOB,"RAEX")
SET RACNT=0
if X["-"
GOTO ADC
SET RAFST=$SELECT(X:X-.01,1:0)
SET RAEND=$SELECT(X:X,1:99999)
SET X=""
SET RAIX="AE"
+2 ;S RAXHOLD=X ;don't need MAG calls anymore 111300
+3 ;I $$IMAGE^RARIC1 D MED^MAGSET3,ERASE^MAGSET3
+4 ;S X=RAXHOLD K RAXHOLD
+5 FOR RACN=RAFST:0
if X="^"!(X>0)
QUIT
SET RACN=$ORDER(^RADPT(RAIX,RACN))
if RACN'>0!(RACN>RAEND)
QUIT
FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT(RAIX,RACN,RADFN))
if RADFN'>0
QUIT
SET RADTI=$ORDER(^(RADFN,0))
SET RACNI=$ORDER(^(RADTI,0))
SET X=""
DO PRT
if X="^"!(X>0)
QUIT
+6 GOTO CHK
ADC ;S RAIX="ADC",RACN=$P(X,"-",2),RADTCN=X,X=""
+1 SET RAIX="ADC"
SET RACN=$PIECE(X,"-",$LENGTH(X,"-"))
SET RADTCN=$SELECT($LENGTH(X,"-")=3:$PIECE(X,"-",2,3),1:X)
SET X=""
+2 FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT(RAIX,RADTCN,RADFN))
if RADFN'>0
QUIT
SET RADTI=$ORDER(^(RADFN,0))
SET RACNI=$ORDER(^(RADTI,0))
SET X=""
DO PRT
if X="^"!(X>0)
QUIT
+3 IF 'RACNT
DO ADC1
CHK if X="^"!(X>0)
QUIT
IF 'RACNT
WRITE !?3,*7,"No matches found!"
QUIT
+1 ;Q:X="^"!(X>0) I 'RACNT W !?3,*7,"No matches found!" Q
+2 IF RACNT=1
SET X=1
SET Y=^TMP($JOB,"RAEX",1)
if $DATA(RAOPT("EDITCN"))
DO CHECK
QUIT
CHK1 if '(RACNT#15)
QUIT
WRITE !,"CHOOSE FROM 1-",RACNT,": "
READ X:DTIME
if '$TEST!(X="")
SET X="^"
if X="^"
QUIT
IF X["?"
DO HLP
GOTO CHK1
+1 IF '$DATA(^TMP($JOB,"RAEX",+X))
SET X="^"
WRITE *7," ??"
QUIT
+2 SET Y=^TMP($JOB,"RAEX",+X)
if $DATA(RAOPT("EDITCN"))
DO CHECK
QUIT
PRT SET RAFL=0
if '$DATA(^RADPT(RADFN,0))!('$DATA(^DPT(RADFN,0)))
QUIT
SET RANME=^(0)
SET RASSN=$$SSN^RAUTL
SET RANME=$PIECE(RANME,"^")
+1 ;this var must be cleared so can detect bad ^RADPT("AE" ;111500
KILL RADIV
+2 IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
Begin DoDot:1
+3 SET RANODE=$GET(^RADPT(RADFN,"DT",RADTI,0))
+4 SET RADIV=+$PIECE(RANODE,"^",3)
SET RAIMAGE=+$PIECE(RANODE,"^",2)
SET RADIVIEN=RADIV
+5 SET RADIV=+$GET(^RA(79,RADIV,0))
SET RADIV=$PIECE($GET(^DIC(4,RADIV,0)),"^")
+6 if RADIV']""
SET RADIV="Unknown"
+7 SET RAIMAGE=$PIECE($GET(^RA(79.2,RAIMAGE,0)),"^")
+8 if RAIMAGE']""
SET RAIMAGE="Unknown"
+9 SET (Y,RADTE)=+$PIECE(RANODE,"^")
DO D^RAUTL
SET RADATE=Y
+10 IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
SET RAFL=1
SET Y=^(0)
+11 QUIT
End DoDot:1
if 'RAFL
QUIT
+12 ;possible corrupted "AE" active case x-ref on ^RADPT
IF '$DATA(RADIV)
QUIT
+13 ; pointing to a non-existent visit node
+14 ; Note: if $D(ORVP) the screen logic is to be ignored. We have entered
+15 ; through OE/RR. Even if we are not screening, the user may have
+16 ; already selected various Division(s) and Imaging type(s) which are
+17 ; in ^TMP($J,"RA D-TYPE" and ^TMP($J,"RA I-TYPE". If RANOSCRN is
+18 ; defined, it means no screening by imaging types to which the
+19 ; user has access privilege.
+20 IF '$DATA(ORVP)
IF ($DATA(RANOSCRN))
IF ('$DATA(RADUPSCN))
IF $DATA(^TMP($JOB,"RA D-TYPE"))!($DATA(^TMP($JOB,"RA I-TYPE")))
if '$DATA(^TMP($JOB,"RA D-TYPE",RADIV))!('$DATA(^TMP($JOB,"RA I-TYPE",RAIMAGE)))
QUIT
+21 ; If in 'Case No. Exam Edit' option, skip i-type check in the next line
+22 IF '$DATA(ORVP)
IF ('$DATA(RADUPSCN))
IF ('$DATA(RAOPT("EDITCN")))
if $$IMGTY^RAUTL12("e",RADFN,RADTI)'=RAIMGTY&('$DATA(RANOSCRN))
QUIT
+23 SET RAST=+$PIECE(Y,"^",3)
SET RARPT=+$PIECE(Y,"^",17)
SET RAPRC=$SELECT($DATA(^RAMIS(71,+$PIECE(Y,"^",2),0)):$PIECE(^(0),"^"),1:"Unknown")
SET RACNT=RACNT+1
+24 SET ^TMP($JOB,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST
+25 ;I $$IMAGE^RARIC1 D DISPA^MAGRIC ; don't need MAG calls anymore 111300
+26 IF RACNT=1
IF $SELECT('$DATA(RAEND):1,RAEND<99999:1,1:0)
IF $DATA(RAVW)
IF $ORDER(^RADPT(RAIX,$SELECT(RAIX="ADC":RADTCN,1:RACN),RADFN))'>0
SET X=1
SET Y=^TMP($JOB,"RAEX",1)
QUIT
+27 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+28 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:$$LCASE(RADTE,RACN))
+29 IF $$USESSAN^RAHLRU1()
if RACNT=1
DO HD
WRITE !?1,RACNT,?7,RACNDSP
if $ORDER(^RARPT(RARPT,2005,0))
WRITE ?22,"i"
WRITE ?24,$EXTRACT(RAPRC,1,25),?50,$EXTRACT(RANME,1,22),?74,$$SSN^RAUTL(RADFN,1)
if RACNT#15
QUIT
+30 IF '$$USESSAN^RAHLRU1()
if RACNT=1
DO HD
WRITE !?1,RACNT,?7,$$LCASE(RADTE,RACN)
if $ORDER(^RARPT(RARPT,2005,0))
WRITE ?22,"i"
WRITE ?24,$EXTRACT(RAPRC,1,25),?50,$EXTRACT(RANME,1,22),?74,$$SSN^RAUTL(RADFN,1)
if RACNT#15
QUIT
PRT1 WRITE !,"Type '^' to STOP, or",!,"CHOOSE FROM 1-",RACNT,": "
READ X:DTIME
if '$TEST
SET X="^"
if X="^"!(X="")
QUIT
IF X["?"
DO HLP
GOTO PRT1
+1 IF '$DATA(^TMP($JOB,"RAEX",+X))
WRITE *7," ??"
SET X="^"
QUIT
+2 SET X=+X
SET Y=^TMP($JOB,"RAEX",X)
QUIT
+3 ;
HD WRITE !!,"Choice",?7,"Case No.",?24,"Procedure",?50,"Name",?74,"Pt ID",!,"------",?7,"---------------",?24,"---------",?50,"-----------------",?74,"------"
QUIT
+1 ;
SPACE IF $DATA(^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"RA","CASE #"))
SET X=^("CASE #")
IF $DATA(^RADPT(+$PIECE(X,"^"),"DT",+$PIECE(X,"^",2),"P",+$PIECE(X,"^",3),0))
SET RADTX=$PIECE($PIECE(X,"^",2),".")
SET X=+^(0)
SET X=$$LCASE(9999999-RADTX,X)
WRITE " ",X
KILL RADTX
QUIT
+1 SET X="^"
QUIT
+2 ;
QUES WRITE !,"Enter an active case number in the following form '999'..."
+1 WRITE !?10,"...or enter a completed case number as 'MMDDYY-999'"
+2 WRITE !?10,"...or enter a patient's name"
+3 WRITE !?10,"...or enter a patient's 9-digit SSN"
+4 WRITE !?10,"...or enter the first character of the patient's",!?13,"last name and the last four digits of their SSN."
ASKACT READ !!,"Do you wish to see the entire list of active cases? NO// ",X:DTIME
SET X=$EXTRACT(X)
if '$TEST!("Nn"[X)
SET X="^"
IF "Yy"'[X
IF X'="^"
if X'="?"
WRITE *7
WRITE !!?3,"Enter 'YES' to list all active cases, or 'NO' not to."
GOTO ASKACT
+1 if "Yy"[X
SET X="??"
QUIT
HLP WRITE !!?3,"Enter the number corresponding to the exam you wish to select.",!
QUIT
LCASE(RADT,RACN) ; Pass back the long case number.
+1 ; Input : RADT -> FM date (internal format)
+2 ; RACN -> Case #
+3 ; Output: long case number i.e, '010197-100'
+4 ; RTK 3/16/2009 ADDED NEXT 2 LINES FOR USE WITH SSAN P47
+5 QUIT $TRANSLATE($TRANSLATE($$FMTE^XLFDT(RADT,"2FD")," ","0"),"/","")_"-"_RACN
CHECK ; Check if the exam selected is of the same imaging type as the sign-on
+1 ; location. Must be in the 'Case No. Exam Edit' option.
+2 if '$DATA(RAOPT("EDITCN"))
QUIT
NEW RAMASK,RARTRN
SET RAMASK=Y
+3 IF $$IMGTY^RAUTL12("e",$PIECE(Y,"^"),$PIECE(Y,"^",2))'=RAIMGTY
Begin DoDot:1
+4 NEW X
SET RARTRN=$$SW^RAPSET1($$IMGTY^RAUTL12("e",$PIECE(Y,"^"),$PIECE(Y,"^",2)),RAIMGTY)
+5 QUIT
End DoDot:1
+6 if +$GET(RARTRN)
WRITE !!,$PIECE(RARTRN,"^",2),$CHAR(7)
+7 SET Y=RAMASK
+8 IF +$GET(RARTRN)
SET X="^"
KILL RADFN,RADTI,RACNI,RANME,RASSN,RADATE,RADTE,RACN,RAPRC,RARPT,RAST,RAEND,RAFST,RAIX
+9 QUIT
ADC1 ;
+1 SET RAIX="ADC1"
+2 FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT(RAIX,RADTCN,RADFN))
if RADFN'>0
QUIT
SET RADTI=$ORDER(^(RADFN,0))
SET RACNI=$ORDER(^(RADTI,0))
SET X=""
DO PRT
if X="^"!(X>0)
QUIT
