Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RADLY1

RADLY1.m

Go to the documentation of this file.
  1. RADLY1 ;HISC/GJC-Rad Daily Log Report ;5/7/97 13:50
  1. ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
  1. PRINT ; Output subroutine part one
  1. S RA1=""
  1. P1 S RA1=$O(^TMP($J,"RADLY",RA1)) Q:RA1']"" S RA2=""
  1. S RADIV=$P($G(^DIC(4,RA1,0)),"^") D CKCHANGE Q:RAXIT
  1. P2 S RA2=$O(^TMP($J,"RADLY",RA1,RA2)) I RA2']"" D DIVCHK Q:RAXIT G P1
  1. S RAITYPE=RA2,RA3="" D CKCHANGE Q:RAXIT
  1. P3 S RA3=$O(^TMP($J,"RADLY",RA1,RA2,RA3)) I RA3']"" D IMGCHK Q:RAXIT G P2
  1. S RAILOC=RA3,RA4="" D CKCHANGE Q:RAXIT
  1. P4 S RA4=$O(^TMP($J,"RADLY",RA1,RA2,RA3,RA4)) I RA4']"" D LOCCHK Q:RAXIT G P3
  1. S RA5=""
  1. P5 S RA5=$O(^TMP($J,"RADLY",RA1,RA2,RA3,RA4,RA5)) G:RA5']"" P4 S RA6=""
  1. P6 S RA6=$O(^TMP($J,"RADLY",RA1,RA2,RA3,RA4,RA5,RA6)) G:RA6']"" P5 S RA0=$G(^(RA6))
  1. D:RA0]"" PRT1 Q:RAXIT
  1. G P6
  1. HD ; Header
  1. W:RAPG!($E(IOST,1,2)="C-") @IOF
  1. S RAPG=RAPG+1 W !?(IOM-$L(RAHEAD)\2-5),RAHEAD,?RATAB(9),"Page: ",RAPG
  1. ; raflg gets set after all records are printed,=1 if more than 1 div.
  1. W:'$D(RAFLG) !,"Division : ",$S(RADIV]"":RADIV,1:"Unknown")
  1. W:$D(RAFLG) !,"Division : "
  1. W ?RATAB(9),"Date: ",RATDY
  1. N RA12
  1. S RA12=$S(RAILOC]"":RAILOC,1:"Unknown")
  1. S:IOM<132 RA12=$E(RA12,1,30)
  1. W:'$D(RAFLG) !,"Imaging Location : ",RA12," ("
  1. W:$D(RAFLG) !,"Imaging Location :"
  1. S RA12=$S(RAITYPE]"":RAITYPE,1:"Unknown")
  1. S:IOM<132 RA12=$E(RA12,1,30)
  1. W:'$D(RAFLG) RA12,")"
  1. I IOM=132 D ; If 132 column
  1. . I $$USESSAN^RAHLRU1() D
  1. .. W !,"Name",?RATAB(2),"Pt ID",?RATAB(3)-2,"Time",?RATAB(4)-2
  1. .. W "Ward/Clinic",?RATAB(5)-1,"Procedure",?RATAB(6)-2,"Exam Status"
  1. .. W ?RATAB(7)-4,"Case#",?RATAB(8)+6,"Rptd",!,RALN
  1. . I '$$USESSAN^RAHLRU1() D
  1. .. W !,"Name",?RATAB(2),"Pt ID",?RATAB(3),"Time",?RATAB(4),"Ward/Clinic"
  1. .. W ?RATAB(5),"Procedure",?RATAB(6),"Exam Status",?RATAB(7),"Case#"
  1. .. W ?RATAB(8),"Reported",!,RALN
  1. . Q
  1. E D ; default to 80 column format
  1. . I $$USESSAN^RAHLRU1() D
  1. .. W !,"Name",?RATAB(3),"Pt ID",?RATAB(5),"Ward/Clinic"
  1. .. W ?RATAB(7),"Procedure",!,?RATAB(2),"Exam Status",?RATAB(4),"Case #"
  1. .. W ?RATAB(6)+9,"Time",?RATAB(8)+8,"Reported",!,RALN
  1. . I '$$USESSAN^RAHLRU1() D
  1. .. W !,"Name",?RATAB(3),"Pt ID",?RATAB(5),"Ward/Clinic"
  1. .. W ?RATAB(7),"Procedure",!,?RATAB(2),"Exam Status",?RATAB(4),"Case #"
  1. .. W ?RATAB(6),"Time",?RATAB(8),"Reported",!,RALN
  1. . Q
  1. I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1
  1. Q
  1. PRT1 ; Output subroutine two
  1. F I=1:1:7 D
  1. . S @$P("RACN^RAPRC^RAST^RATME^RAWHE^RARPT^RASSN","^",I)=$P(RA0,"^",I)
  1. . Q
  1. I $Y>(IOSL-4) D Q:RAXIT
  1. . S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HD
  1. . Q
  1. I IOM=132 D ; default to 132 column format
  1. . I $$USESSAN^RAHLRU1() D
  1. .. W !,RA4,?RATAB(2),RASSN,?RATAB(3)-2,RATME,?RATAB(4)-2,RAWHE
  1. .. W ?RATAB(5)-1,RAPRC,?RATAB(6)-2,$E(RAST,1,14),?RATAB(7)-4,RACN
  1. .. W ?RATAB(8)+6,RARPT
  1. . I '$$USESSAN^RAHLRU1() D
  1. .. W !,RA4,?RATAB(2),RASSN,?RATAB(3),RATME,?RATAB(4),RAWHE
  1. .. W ?RATAB(5),RAPRC,?RATAB(6),RAST,?RATAB(7),RACN,?RATAB(8),RARPT
  1. . Q
  1. E D ; If 80 column
  1. . I $$USESSAN^RAHLRU1() D
  1. .. W !,RA4,?RATAB(3),RASSN,?RATAB(5),RAWHE,?RATAB(7),RAPRC,!?RATAB(2)
  1. .. W RAST,?RATAB(4),RACN,?RATAB(6)+9,RATME,?RATAB(8)+8,RARPT
  1. . I '$$USESSAN^RAHLRU1() D
  1. .. W !,RA4,?RATAB(3),RASSN,?RATAB(5),RAWHE,?RATAB(7),RAPRC
  1. .. W !?RATAB(2),RAST,?RATAB(4),RACN,?RATAB(6),RATME,?RATAB(8),RARPT
  1. . Q
  1. Q
  1. KILL ; Kill variables
  1. K %,%I,%X,%Y,DIC,I,RA0,RA1,RA2,RA3,RA4,RA5,RA6,RA7,RA8,RA9,RA10,RA11
  1. K RACN,RACNI,RADFN,RADIV,RADIVNM,RADIVTY,RADTE,RADTI,RAEX,RAFLG,RAHEAD
  1. K RAIMGTY,RAITYPE,RALDTI,RALDTX,RALN,RAMES,RANME,RAPG,RAPOP,RAPRC,RAPT
  1. K RAQUIT,RARE,RARPT,RASSN,RAST,RATAB,RATDY,RATME,RAWHE,RAXIT,X,Y,ZTDESC
  1. K RAILOC,RADIV0,RAITYPE0,RAILOC0
  1. K ZTRTN,ZTSAVE K:$D(RAPSTX) RACCESS,RAPSTX,POP,DUOUT
  1. K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RADLY")
  1. K ^TMP($J,"RA LOC-TYPE"),^TMP($J,"DIV-ITYP-ILOC")
  1. Q
  1. DIVCHK ; Output statistics within division.
  1. N RA7 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
  1. W !?RATAB(2),"Division Total '"_RADIV_"': ",+$G(^TMP($J,"RADLY",RA1))
  1. Q
  1. IMGCHK ; Check for EOS on I-Type
  1. N RA10 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
  1. W !?RATAB(2),"Imaging Type Total '"_RAITYPE_"': ",+$G(^TMP($J,"RADLY",RA1,RAITYPE))
  1. Q
  1. LOCCHK ; Check for EOS on Loc-Type
  1. N RA9 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
  1. W !?RATAB(2),"Imaging Location Total '"_RAILOC_"': ",+$G(^TMP($J,"RADLY",RA1,RAITYPE,RAILOC))
  1. Q
  1. CKCHANGE ; Check for change in div/img-type/img-loc, for header
  1. N A,RAPRTHD
  1. S RAPRTHD=0 ;whether to print page header or not, 1=yes
  1. S A=$P($G(^DIC(4,+RA1,0)),"^")
  1. I $G(RA2)]"",$G(RA3)]"" S:A'=RADIV0 RAPRTHD=1
  1. I $G(RA2)]"",$G(RA3)]"",RADIV0=A S:RA2'=RAITYPE0 RAPRTHD=1
  1. I $G(RA3)]"",RAITYPE0=RA2 S:RA3'=RAILOC0 RAPRTHD=1
  1. S RADIV0=A S:$G(RA2)]"" RAITYPE0=RA2 S:$G(RA3)]"" RAILOC0=RA3
  1. Q:'RAPRTHD&($Y<(IOSL-5))
  1. S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5()
  1. D:'RAXIT HD
  1. Q
  1. SORT ; Gather/sort data
  1. S RARE(0)=$G(^RADPT(RADFN,"DT",RADTI,0))
  1. S RADIV=+$P(RARE(0),"^",3),RADIV("I")=+$P($G(^RA(79,RADIV,0)),"^")
  1. S RADIV=$P($G(^DIC(4,RADIV("I"),0)),"^")
  1. I RADIV']""!('$D(^TMP($J,"RA D-TYPE",RADIV))) Q ; no div
  1. S RADIV=RADIV("I") K RADIV("I")
  1. S RAITYPE=+$P(RARE(0),"^",2) Q:RAITYPE'>0
  1. S RAITYPE=$P($G(^RA(79.2,RAITYPE,0)),"^")
  1. Q:'$D(^TMP($J,"RA I-TYPE",RAITYPE)) ; no img type
  1. S RAILOC=+$P(RARE(0),"^",4) Q:RAILOC'>0
  1. S RAILOC=$P($G(^RA(79.1,RAILOC,0)),"^"),RAILOC=$P($G(^SC(+RAILOC,0)),"^")
  1. Q:'$D(^TMP($J,"RA LOC-TYPE",RAILOC)) ;no img loc
  1. S (RANME,RASSN)="Unknown",RAPT(0)=$G(^DPT(RADFN,0))
  1. S RANME=$S($P(RAPT(0),"^")]"":$P(RAPT(0),"^"),1:RANME)
  1. S RASSN=$$SSN^RAUTL,RANME=$E(RANME,1,23)
  1. F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D Q:RAXIT
  1. . D:$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) SET^RADLY
  1. . Q
  1. Q
  1. ZEROUT ; zero out the ^tmp($j,"RADLY"
  1. ; loop throu raccess(duz,"DIV,ITYP-ILOC",divname,imgtypename,imglocname)
  1. ; THIS SECTION REPLACES THE ORIGINAL CALL TO ZEROUT^RADLQ3("RADLY")
  1. ; so to ensure that locations not assigned to the user will be
  1. ; zeroed out, if those locations share the same imaging types that
  1. ; his assigned locations have
  1. N X,Y,Z,X1
  1. S X=""
  1. ZER1 S X=$O(RACCESS(DUZ,"DIV-ITYP-ILOC",X)) Q:X="" ;eg. "cgo (ws)"
  1. S Y="",X1=$O(^DIC(4,"B",X,0)) ; eg. 639
  1. ZER2 S Y=$O(RACCESS(DUZ,"DIV-ITYP-ILOC",X,Y)) G:Y="" ZER1 S Z="" ;eg. "gen rad"
  1. ZER3 S Z=$O(RACCESS(DUZ,"DIV-ITYP-ILOC",X,Y,Z)) G:Z="" ZER2 ;eg. "x-ray"
  1. S ^TMP($J,"RADLY",X1,Y,Z)=0
  1. G ZER3