- 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 Feb 19, 2025@00:05:41 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