source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL7A.m@ 1096

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

initial load of WorldVistAEHR
File size: 6.0 KB
Line 
1RAUTL7A ;HISC/CAH,FPT-Utility for RACCESS array ;9/10/01 15:13
2 ;;5.0;Radiology/Nuclear Medicine;**31**;Mar 16, 1998
3LOCIMG1() ;Determines if user has access to more than one loc of
4 ;the current imaging type
5 ;Returns Null if more than one Rad/NM Loc, or if no access
6 ;Returns Rad/NM Loc File 79.1 IEN if one only.
7 N X,Y,Z,RALOCTOT S X=$O(RACCESS(DUZ,"LOC",0)) Q:'X ""
8 S (RALOCTOT,X)=0 S Z=$O(^RA(79.2,"B",RAIMGTY,0))
9 F S X=$O(RACCESS(DUZ,"LOC",X)) Q:'X D
10 . I $P($G(^RA(79.1,X,0)),U,6)=Z S RALOCSAV=X,RALOCTOT=RALOCTOT+1
11 . Q
12 I RALOCTOT=1 Q RALOCSAV
13 Q ""
14ERROR ; Display error message
15 W !!?5,"You do not have access to any Imaging Locations."
16 W !?5,"Contact your ADPAC for further assistance.",$C(7)
17 Q
18IMGNUM() ; Detrmines the number of selectable imaging types based on
19 ; division parameters. Called fron SELIMG^RAUTL7
20 N X,Y S (X,Y)=0
21 F S X=$O(^TMP($J,"DIV-IMG",X)) Q:X'>0 S Y=Y+1
22 Q Y
23SETUP ; Setup temp global to screen i-type by division
24 ; Requires ^TMP($J,"RA D-TYPE",Division name), RACCESS "DIV-IMG"
25 ; elements. Creates ^TMP($J,"DIV-IMG",Imaging Type IEN)=""
26 ; Called fron SELIMG^RAUTL7
27 N RAX,RAY,RAZ S RAX=""
28 F S RAX=$O(^TMP($J,"RA D-TYPE",RAX)) Q:RAX']"" D
29 . I $D(RACCESS(DUZ,"DIV-IMG",RAX)) D
30 .. S RAY="" F S RAY=$O(RACCESS(DUZ,"DIV-IMG",RAX,RAY)) Q:RAY']"" D
31 ... S RAZ=+$O(^RA(79.2,"B",RAY,0)),^TMP($J,"DIV-IMG",RAZ)=""
32 ... Q
33 .. Q
34 . Q
35 Q
36LOCNUM() ;Detrmines the number of selectable imaging locations based on
37 ; division parameters. Called fron SELLOC^RAUTL7
38 N X,Y S (X,Y)=0
39 F S X=$O(^TMP($J,"DIV-ITYP-ILOC",X)) Q:X'>0 S Y=Y+1
40 Q Y
41SETUPL ; Setup temp global to screen img-loc, where
42 ; img-loc must be within previously selected img-typ(s)
43 ; Requires RACCESS(duz,"LOC") and ^TMP($J,"RA ITYPE")
44 ; Creates ^TMP($J,"DIV-ITYP-ILOC",Img Loc ien)
45 ; and eg. RACCESS(duz,"DIV-ITYP-ILOC","cgo(ws)","gen rad","x-ray")
46 ; Called from SELLOC^RAUTL7
47 N RAX,RAY,RAZ,RAW
48 S RAX=0
49 ; allow other img locations with img types that match at least one
50 ; of the user's accessible img location's img types
51 ; so, loop thru all img locations
52SETUPL1 S RAX=$O(^RA(79.1,RAX)) Q:'RAX ;eg. 7
53 S RAY=+$P(^RA(79.1,RAX,0),"^",6) G:RAY="" SETUPL1 ;eg. 1
54 G:'$O(^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+RAY,0)),U),0)) SETUPL1
55 S RAZ=$P($G(^RA(79.1,RAX,"DIV")),U) G:RAZ="" SETUPL1 ;eg. 639
56 S RAW=$P(^DIC(4,+RAZ,0),U) G:RAW="" SETUPL1 ;eg. CHICAGO (WS)
57 ; match on selected imaging type
58 G:'$D(^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+RAY,0)),"^"),+RAY)) SETUPL1
59 ; match on selected division(s)
60 G:'$D(^TMP($J,"RA D-TYPE",RAW,RAZ)) SETUPL1
61 S ^TMP($J,"DIV-ITYP-ILOC",RAX)=""
62 ; following line replaces original code from DIVIACC section of ^RAUTL7
63 ; raccess(duz,"DIV-ITYP-ILOC" is used by ZEROUT^RADLY1 to
64 ; zerout the ^tmp($j,"radly" nodes
65 S RACCESS(DUZ,"DIV-ITYP-ILOC",RAW,$P($G(^RA(79.2,+RAY,0)),"^"),$P($G(^SC(+$P($G(^RA(79.1,+RAX,0)),U),0)),U))=""
66 G SETUPL1
67 Q
68VERIFY ; verify old reports
69 ; back door function to "administratively verify" old reports
70 ; that were never verified
71 W !,"This subroutine prompts you for a date and places all unverified reports"
72 W !,"through that date into a status of Verified.",!
73 I '$D(^RARPT("ASTAT")) W !!,"NO UNVERFIED REPORTS CROSS REFERENCE" Q
74 K DIR S DIR(0)="D",DIR("A")="Enter a date",DIR("?")="All unverified reports through this date will be marked as Verified."
75 D ^DIR K DIR I $D(DIRUT) D KILL Q
76 S RAENDATE=Y
77DEVICE ;
78 S ZTRTN="START^RAUTL7A",ZTDESC="Rad/Nuc Med Verify Old Reports",ZTSAVE("RAENDATE")=""
79 D ZIS^RAUTL
80 I RAPOP D KILL Q
81START ;
82 U IO K DIR,DIRUT,DIROUT,DTOUT,DUOUT
83 S RASTATUS="",(RACOUNT,RAPAGE)=0,RAENDATE=$P(RAENDATE,".")_"."_9999
84 S:$D(ZTQUEUED) ZTREQ="@"
85 D NOW^%DTC S Y=X X ^DD("DD") S RATIME=Y
86 D HEADER
87 F S RASTATUS=$O(^RARPT("ASTAT",RASTATUS)) Q:RASTATUS=""!($D(DIRUT)) S RARPT=0 F S RARPT=$O(^RARPT("ASTAT",RASTATUS,RARPT)) Q:RARPT'>0 D Q:$D(DIRUT)
88 .S RARPT0=$G(^RARPT(RARPT,0)) Q:RARPT0=""
89 .S RADTE=$P(RARPT0,U,3) Q:RADTE=""!(RADTE>RAENDATE)
90 .S RADFN=$P(RARPT0,U,2) Q:RADFN=""
91 .S RADTI=9999999.9999-RADTE
92 .S RACNI=$O(^RADPT("ADC",$P(RARPT0,U,1),RADFN,RADTI,0)) Q:RACNI=""
93 .S DFN=RADFN D DEM^VADPT
94 .S RANAME=$P(VADM(1),U,1),RASSN=$P(VADM(2),U,2) K DFN,VADM
95 .S RACOUNT=RACOUNT+1
96 .S RADPT0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
97 .S RARES=+$P(RADPT0,U,12) I $D(^VA(200,RARES,0)) S RARES=$P(^VA(200,RARES,0),U,1)
98 .S RASTAFF=+$P(RADPT0,U,15) I $D(^VA(200,RASTAFF,0)) S RASTAFF=$P(^VA(200,RASTAFF,0),U,1)
99 .W !!,$P(RARPT0,U,1),?15,RANAME_" ("_RASSN_")",?60,"Status: ",RASTATUS
100 .W !,"Resident: ",$S(RARES=0:"<none>",RARES]"":RARES,1:"<none>")
101 .W ?43,"Staff: ",$S(RASTAFF=0:"<none>",RASTAFF]"":RASTAFF,1:"<none>")
102 .K DIE,DR S DIE="^RARPT(",DR="5////V",DA=RARPT D ^DIE
103 .I ($Y+4)>IOSL D Q:$D(DIRUT) W @IOF D HEADER
104 ..Q:$E(IOST)'="C"
105 ..K DIR,DIROUT,DIRUT,DTOUT,DUOUT
106 ..S DIR(0)="E" D ^DIR K DIR
107 ..Q
108 .I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 DIRUT=1
109 .Q
110 W !!,"Total: ",RACOUNT
111KILL ;
112 K %,DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,RACNI,RACOUNT,RADFN,RADPT0,RADTE,RADTI,RAENDATE,RANAME,RAPAGE,RAPOP,RARPT,RARPT0,RARES,RASSN,RATIME,RASTAFF,RASTATUS,X,Y,ZTDESC,ZTRTN,ZTSAVE
113 D CLOSE^RAUTL
114 Q
115HEADER ;
116 W:$Y>0 @IOF
117 S RAPAGE=RAPAGE+1
118 W "Verify Reports Prior to "_$E(RAENDATE,4,5)_"/"_$E(RAENDATE,6,7)_"/"_$E(RAENDATE,2,3)
119 W !,"Run Date/Time: ",RATIME,?70,"Page: ",RAPAGE
120 W !,$$REPEAT^XLFSTR("-",79),!
121 Q
122DISPLAY ; back door function to display all reports not verified in file 74
123 ; prints [captioned] dump of entire record
124 W !!,"This subroutine loops through the unverified reports cross-reference of"
125 W !,"File 74 and displays the report entry including computed field values.",!!
126 D ^%ZIS
127 U IO W:$Y>0 @IOF
128 S RA4CHX=""
129 F S RA4CHX=$O(^RARPT("ASTAT",RA4CHX)) Q:RA4CHX=""!($D(DIRUT)) D
130 . S RA4CHX1=0 F S RA4CHX1=$O(^RARPT("ASTAT",RA4CHX,RA4CHX1)) Q:'RA4CHX1!($D(DIRUT)) D
131 .. I $D(^RARPT(RA4CHX1,0)) S DIC="^RARPT(",DA=+RA4CHX1,DIQ(0)="C" W:$Y>0 @IOF D EN^DIQ I '$D(DIRUT) D Q:$D(DIRUT)
132 ...Q:$E(IOST)'="C"
133 ...K DIR,DIROUT,DIRUT,DTOUT,DUOUT
134 ...S DIR(0)="E" D ^DIR K DIR
135 ...Q
136 D ^%ZISC
137 K A,D0,D1,DA,DIC,DIQ,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DTOUT,DUOUT,DX,I,POP,RA4CHX,RA4CHX1,RACN,RARPT,S,X,Y
138 Q
Note: See TracBrowser for help on using the repository browser.