source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADLY.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1RADLY ;HISC/GJC AISC/MJK,RMO-Rad Daily Log Report ;7/17/97 12:35
2 ;;5.0;Radiology/Nuclear Medicine;**15**;Mar 16, 1998
3 ; setup raccess(duz,"LOC" raccess(duz,"DIV" raccess(duz,"IMG"
4 I $O(RACCESS(DUZ,""))="" S RAPSTX="" D SETVARS^RAPSET1(0)
5 ; Check access and
6 ; setup raccess(duz,"DIV-IMG","chicago (ws),"general radiology"
7 S RAXIT=$$SETUPDI^RAUTL7() G:RAXIT CLEAN
8 ; Select Div
9 ; setup ^tmp($j,"RA D-TYPE"
10 D SELDIV^RAUTL7
11 I '$D(^TMP($J,"RA D-TYPE"))!(RAQUIT) K RACCESS(DUZ,"DIV-IMG") S RAXIT=1 G CLEAN
12 ; Set imaging types as allowed by division(s) picked
13 N X,X1,RACHK1 S X=0
14 ; setup ^tmp($j,"DIV-IMG"
15 D SETUP^RAUTL7A
16 ; setup ^tmp($j,"RA I-TYPE"
17 F S X=$O(^TMP($J,"DIV-IMG",X)) Q:X'=+X I $D(RACCESS(DUZ,"IMG",X)) S ^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+X,0)),U),X)=""
18 ; Select Img Loc
19 ; setup ^tmp($j,"DIV-ITYP-ILOC" ^tmp($j,"RA LOC-TYPE"
20 D SELLOC^RAUTL7
21 I '$D(^TMP($J,"RA LOC-TYPE"))!(RAQUIT) K RACESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-ITYP-ILOC") S RAXIT=1
22CLEAN K ^TMP($J,"DIV-IMG")
23 ;
24 I RAXIT K RAXIT K:$D(RAPSTX) RACCESS,RAPSTX,I,POP,RAQUIT Q
25 ; loop thru raccess(duz,"DIV-IMG" to setup ^tmp($j,"RADLY",
26 ; matching on ^tmp($j,"RA D-TYPE" and ^tmp($j,"RA I-TYPE"
27 ; use new code in rtn radly1, instead of rtn radlq3
28 D ZEROUT^RADLY1 K RACCESS(DUZ,"DIV-IMG") W !
29ASKLOG ; Ask log date
30 W ! K %DT
31 S %DT="PATEX",%DT("A")="Select Log Date: "
32 S %DT("B")="T-1" D ^%DT K %DT
33 I Y<0 D KILL^RADLY1 Q
34 S RALDTI=Y\1 S RALDTX=$$FMTE^XLFDT(Y\1,1)
35 S ZTDESC="Rad/Nuc Med Daily Log Rpt"
36 S ZTRTN="START^RADLY",ZTSAVE("RALDT*")=""
37 S ZTSAVE("^TMP($J,""RADLY"",")="",ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
38 S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
39 S ZTSAVE("^TMP($J,""RA LOC-TYPE"",")=""
40 D ZIS^RAUTL
41 I RAPOP D KILL^RADLY1 Q
42START ; Start the process
43 U IO D NOW^%DTC
44 S:$D(ZTQUEUED) ZTREQ="@"
45 S RATDY=$$FMTE^XLFDT(%\1,1),(RAPG,RAXIT)=0
46 S $P(RALN,"-",(IOM+1))="",RAHEAD="Daily Log Report For: "_RALDTX
47 S RATAB(1)=$S(IOM=132:8,1:5),RATAB(2)=$S(IOM=132:25,1:8)
48 S RATAB(3)=$S(IOM=132:42,1:25),RATAB(4)=$S(IOM=132:52,1:32)
49 S RATAB(5)=$S(IOM=132:72,1:38),RATAB(6)=$S(IOM=132:95,1:43)
50 S RATAB(7)=$S(IOM=132:114,1:60),RATAB(8)=$S(IOM=132:122,1:62)
51 S RATAB(9)=$S(IOM=132:102,1:62)
52 ;
53 F RADTE=RALDTI:0 S RADTE=$O(^RADPT("AR",RADTE)) Q:'RADTE D Q:RAXIT
54 . Q:RADTE>(RALDTI+.9999)
55 . F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:'RADFN D Q:RAXIT
56 .. S RADTI=9999999.9999-RADTE
57 .. D:$D(^RADPT(RADFN,"DT",RADTI,0)) SORT^RADLY1
58 .. Q
59 . Q
60 I RAXIT D CLOSE^RAUTL,KILL^RADLY1 Q
61 ;
62 ; eliminate "RADLY" nodes that are outside the user-selected img locs
63 N A,B,C S A=""
64CLN1 S A=$O(^TMP($J,"RADLY",A)) G:A']"" PREP S B=""
65CLN2 S B=$O(^TMP($J,"RADLY",A,B)) G:B']"" CLN1 S C=""
66CLN3 S C=$O(^TMP($J,"RADLY",A,B,C)) G:C']"" CLN2
67 K:$O(^TMP($J,"RA LOC-TYPE",C,0))="" ^TMP($J,"RADLY",A,B,C)
68 K:$O(^TMP($J,"RA I-TYPE",B,0))="" ^TMP($J,"RADLY",A,B)
69 K:$O(^TMP($J,"RADLY",A,""))="" ^TMP($J,"RADLY",A)
70 G CLN3
71PREP G:'$D(^TMP($J,"RADLY")) OUT
72 S X=+$O(^TMP($J,"RADLY","")),Y=$O(^TMP($J,"RADLY",X,""))
73 S RADIV=$P($G(^DIC(4,X,0)),"^"),RAITYPE=Y
74 S RAILOC=$O(^TMP($J,"RADLY",X,Y,""))
75 ; save current values
76 S RADIV0=RADIV,RAITYPE0=RAITYPE,RAILOC0=RAILOC
77 D HD^RADLY1
78 I RAXIT D CLOSE^RAUTL,KILL^RADLY1 Q
79 I $D(^TMP($J,"RADLY")) D
80 . D PRINT^RADLY1 ; Print out data
81 . I 'RAXIT D
82 .. S RADIVNM=$$DIVTOT^RACMP("RADLY") Q:'RADIVNM
83 .. S (RADIV,RAFLG,RAITYPE)="",RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1
84 .. D:'RAXIT SYNOP
85 .. Q
86 . Q
87OUT D CLOSE^RAUTL,KILL^RADLY1
88 Q
89SET ; Set ^TMP global
90 S RAEX(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
91 S RACN=$P(RAEX(0),"^"),RAPRC=+$P(RAEX(0),"^",2)
92 S RAPRC=$G(^RAMIS(71,RAPRC,0)),RAST=+$P(RAEX(0),"^",3)
93 S RAPRC=$E($S(RAPRC]"":$P(RAPRC,"^"),1:"Unknown"),1,19)
94 S RAST=$G(^RA(72,RAST,0)),RA6=+$P(RAEX(0),"^",6)
95 S RA8=+$P(RAEX(0),"^",8),RA9=+$P(RAEX(0),"^",9)
96 S RAST=$E($S(RAST]"":$P(RAST,"^"),1:"Unknown"),1,20)
97 S X=RADTE D TIME^RAUTL1 S RATME=X
98 S:$D(^DIC(42,RA6,0)) RAWHE=$P(^DIC(42,RA6,0),"^")
99 S:$D(^SC(RA8,0)) RAWHE=$P(^SC(RA8,0),"^")
100 S:$D(^DIC(34,RA9,0)) RAWHE=$P(^DIC(34,RA9,0),"^")
101 S:$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")) RAWHE=$P(^("R"),"^")
102 S RAWHE=$E($S($G(RAWHE)]"":RAWHE,1:"Unknown"),1,20)
103 S RARPT=+$P(RAEX(0),"^",17)
104 S RARPT=$S($O(^RARPT(RARPT,"R",0)):"Yes",1:"No")
105 I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
106 S ^TMP($J,"RADLY",RADIV)=+$G(^TMP($J,"RADLY",RADIV))+1
107 S ^TMP($J,"RADLY",RADIV,RAITYPE)=+$G(^TMP($J,"RADLY",RADIV,RAITYPE))+1
108 S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC)=+$G(^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC))+1
109 S RADIVTY=+$G(RADIVTY)+1
110 S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACN_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN
111 Q
112SYNOP ; Synopsis of data presented to the user.
113 S A=""
114 W !?RATAB(2),"Division",!?RATAB(2)+3,"Imaging Type",!?RATAB(2)+6,"Imaging Location(s)",!
115SYN1 S A=$O(^TMP($J,"RADLY",A)) Q:A']""
116 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT
117 W !!?RATAB(2),$P($G(^DIC(4,A,0)),"^") S B=""
118SYN2 S B=$O(^TMP($J,"RADLY",A,B)) G:B']"" SYN1
119 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT
120 W !?RATAB(2)+3,B,!?RATAB(2)+6 S C=""
121SYN3 S C=$O(^TMP($J,"RADLY",A,B,C)) G:C']"" SYN2
122 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT
123 W:$X>(IOM-30) !?RATAB(2)+6
124 W C,?($X+3)
125 G SYN3
Note: See TracBrowser for help on using the repository browser.