RARTFLDS ;HISC/CAH,FPT,GJC AISC/MJK-Computed fields on Reports(#74) file ;4/19/96 08:44
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
1 S X="" Q:'$D(D0)!('$D(^RARPT(D0,0))) S RAX=^(0),RARPT=D0,RADFN=$P(RAX,"^",2),RADTI=9999999.9999-$P(RAX,"^",3),RACN=$P(RAX,"^",4) G Q:RACN']"" S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) G Q:RACNI'>0
S RAX=$S($D(^RADPT(RADFN,"DT",RADTI,0)):^(0),1:0) G Q:'RAX
S RAY3=$S($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)):^(0),1:0) G Q:'RAY3
N RA1 S RA1=$O(^RARPT(D0,1,"B",""))
G @RAEXFLD
;
ALL S X=RAY3 G Q
PROC S X=$S($D(^RAMIS(71,+$P(RAY3,"^",2),0)):$P(^(0),"^"),1:"") D MEMSET G Q
EXAM S X=$S($D(^RA(72,+$P(RAY3,"^",3),0)):$P(^(0),"^"),1:"") D MEMSET G Q
CAT S X=$S($P(RAY3,"^",4)']"":"",1:$P($P(^DD(70.03,4,0),$P(RAY3,"^",4)_":",2),";")) G Q
WARD S X=$S($D(^DIC(42,+$P(RAY3,"^",6),0)):$P(^(0),"^"),1:"") G Q
SERV S X=$S($D(^DIC(49,+$P(RAY3,"^",7),0)):$P(^(0),"^"),1:"") G Q
CLINIC S X=$S($D(^SC(+$P(RAY3,"^",8),0)):$P(^(0),"^"),1:"") G Q
CONT S X=$S($D(^DIC(34,+$P(RAY3,"^",9),0)):$P(^(0),"^"),1:"") G Q
RSCH S X=$S($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")):^("R"),1:"") G Q
RES S X=$S($D(^VA(200,+$P(RAY3,"^",12),0)):$P(^(0),"^"),1:"") D MEMSET G Q
DIAG S X=$S($D(^RA(78.3,+$P(RAY3,"^",13),0)):$P(^(0),"^"),1:"") D MEMSET G Q
PHY S X=$S($D(^VA(200,+$P(RAY3,"^",14),0)):$P(^(0),"^"),1:"") G Q
STAFF S X=$S($D(^VA(200,+$P(RAY3,"^",15),0)):$P(^(0),"^"),1:"") D MEMSET G Q
COMP S X=$S($D(^RA(78.1,+$P(RAY3,"^",16),0)):$P(^(0),"^"),1:"") D MEMSET G Q
EXRM S X=$S($D(^RA(78.6,+$P(RAY3,"^",18),0)):$P(^(0),"^"),1:"") G Q
BED S X=$S($D(^DIC(42.4,+$P(RAY3,"^",19),0)):$P(^(0),"^"),1:"") G Q
TECH S X="" I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))>0,$D(^VA(200,+^($O(^(0)),0),0)) S X=$P(^(0),"^")
G Q
LOC S X=$S('$D(^RA(79.1,+$P(RAX,"^",4),0)):"",$D(^SC(+^(0),0)):$P(^(0),"^"),1:"") G Q
DIV S X=$S($D(^DIC(4,+$P(RAX,"^",3),0)):$P(^(0),"^"),1:"") G Q
;
Q K RADFN,RADTI,RACNI,RAX,RAY3 Q
;
FLD(D0,RAEXFLD) ;
N RACN,RACNI,RADFN,RADTI,RARPT,RAX,RAY3,X
D RARTFLDS
Q X
MEMSET ;insert + infront of value if this record is a member of a print set
S:RA1]"" X="+"_X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTFLDS 2146 printed Dec 13, 2024@02:39:25 Page 2
RARTFLDS ;HISC/CAH,FPT,GJC AISC/MJK-Computed fields on Reports(#74) file ;4/19/96 08:44
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
1 SET X=""
if '$DATA(D0)!('$DATA(^RARPT(D0,0)))
QUIT
SET RAX=^(0)
SET RARPT=D0
SET RADFN=$PIECE(RAX,"^",2)
SET RADTI=9999999.9999-$PIECE(RAX,"^",3)
SET RACN=$PIECE(RAX,"^",4)
if RACN']""
GOTO Q
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
if RACNI'>0
GOTO Q
+1 SET RAX=$SELECT($DATA(^RADPT(RADFN,"DT",RADTI,0)):^(0),1:0)
if 'RAX
GOTO Q
+2 SET RAY3=$SELECT($DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)):^(0),1:0)
if 'RAY3
GOTO Q
+3 NEW RA1
SET RA1=$ORDER(^RARPT(D0,1,"B",""))
+4 GOTO @RAEXFLD
+5 ;
ALL SET X=RAY3
GOTO Q
PROC SET X=$SELECT($DATA(^RAMIS(71,+$PIECE(RAY3,"^",2),0)):$PIECE(^(0),"^"),1:"")
DO MEMSET
GOTO Q
EXAM SET X=$SELECT($DATA(^RA(72,+$PIECE(RAY3,"^",3),0)):$PIECE(^(0),"^"),1:"")
DO MEMSET
GOTO Q
CAT SET X=$SELECT($PIECE(RAY3,"^",4)']"":"",1:$PIECE($PIECE(^DD(70.03,4,0),$PIECE(RAY3,"^",4)_":",2),";"))
GOTO Q
WARD SET X=$SELECT($DATA(^DIC(42,+$PIECE(RAY3,"^",6),0)):$PIECE(^(0),"^"),1:"")
GOTO Q
SERV SET X=$SELECT($DATA(^DIC(49,+$PIECE(RAY3,"^",7),0)):$PIECE(^(0),"^"),1:"")
GOTO Q
CLINIC SET X=$SELECT($DATA(^SC(+$PIECE(RAY3,"^",8),0)):$PIECE(^(0),"^"),1:"")
GOTO Q
CONT SET X=$SELECT($DATA(^DIC(34,+$PIECE(RAY3,"^",9),0)):$PIECE(^(0),"^"),1:"")
GOTO Q
RSCH SET X=$SELECT($DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")):^("R"),1:"")
GOTO Q
RES SET X=$SELECT($DATA(^VA(200,+$PIECE(RAY3,"^",12),0)):$PIECE(^(0),"^"),1:"")
DO MEMSET
GOTO Q
DIAG SET X=$SELECT($DATA(^RA(78.3,+$PIECE(RAY3,"^",13),0)):$PIECE(^(0),"^"),1:"")
DO MEMSET
GOTO Q
PHY SET X=$SELECT($DATA(^VA(200,+$PIECE(RAY3,"^",14),0)):$PIECE(^(0),"^"),1:"")
GOTO Q
STAFF SET X=$SELECT($DATA(^VA(200,+$PIECE(RAY3,"^",15),0)):$PIECE(^(0),"^"),1:"")
DO MEMSET
GOTO Q
COMP SET X=$SELECT($DATA(^RA(78.1,+$PIECE(RAY3,"^",16),0)):$PIECE(^(0),"^"),1:"")
DO MEMSET
GOTO Q
EXRM SET X=$SELECT($DATA(^RA(78.6,+$PIECE(RAY3,"^",18),0)):$PIECE(^(0),"^"),1:"")
GOTO Q
BED SET X=$SELECT($DATA(^DIC(42.4,+$PIECE(RAY3,"^",19),0)):$PIECE(^(0),"^"),1:"")
GOTO Q
TECH SET X=""
IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))>0
IF $DATA(^VA(200,+^($ORDER(^(0)),0),0))
SET X=$PIECE(^(0),"^")
+1 GOTO Q
LOC SET X=$SELECT('$DATA(^RA(79.1,+$PIECE(RAX,"^",4),0)):"",$DATA(^SC(+^(0),0)):$PIECE(^(0),"^"),1:"")
GOTO Q
DIV SET X=$SELECT($DATA(^DIC(4,+$PIECE(RAX,"^",3),0)):$PIECE(^(0),"^"),1:"")
GOTO Q
+1 ;
Q KILL RADFN,RADTI,RACNI,RAX,RAY3
QUIT
+1 ;
FLD(D0,RAEXFLD) ;
+1 NEW RACN,RACNI,RADFN,RADTI,RARPT,RAX,RAY3,X
+2 DO RARTFLDS
+3 QUIT X
MEMSET ;insert + infront of value if this record is a member of a print set
+1 if RA1]""
SET X="+"_X
QUIT
