source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RALIST.m

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

initial load of FOIAVistA 6/30/08 version

File size: 4.9 KB
Line 
1RALIST ;HISC/GJC AISC/MJK,RMO-List all patient exams associated w/selected Amis ;4/15/96 14:27
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
4 I $O(RACCESS(DUZ,""))="" D Q
5 . W !?5,"You do not have access to any Imaging Locations."
6 . W !?5,"Contact your ADPAC."
7 . Q
8 S (RAFLG,RAXIT)=0
9 D SELDIV^RAUTL7
10 I $O(^TMP($J,"RA D-TYPE",""))=""!$G(RAQUIT) W !!?5,"No divisions selected." G Q
11 D DATE^RAUTL G:RAPOP Q
12 S DIC="^RAMIS(71.1,",DIC(0)="AEMQ" W ! D ^DIC G Q:Y<0 S RAMIS=+Y,RAMIS1=$P(Y,"^",2)
13 K DIR S DIR(0)="YA",DIR("B")="Yes"
14 S DIR("A")="Do you wish to include all Procedures? "
15 S DIR("?",1)="Enter 'Yes' to select all entries in the file."
16 S DIR("?")="Enter 'No' to select a subset of entries in the file."
17 W ! D ^DIR K DIR G:$D(DIRUT) Q S RAINPUT=+Y
18 I RAINPUT=0 S RAXIT=0 D G:RAXIT Q
19 . K RADIC
20 . S RADIC="^RAMIS(71,",RADIC(0)="EMQZ",RADIC("A")="Select PROCEDURE: "
21 . S RADIC("S")="I $O(^RAMIS(71,""AC"",RAMIS,+Y,0))",RAUTIL="RA P-TYPE"
22 . D EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
23 . I $O(^TMP($J,"RA P-TYPE",""))=""!$G(RAQUIT) W !!?5,"No procedures selected." S RAXIT=1
24 . Q
25 S ZTRTN="START^RALIST" F RASV="BEGDATE","ENDDATE","RAFLG","RAXIT","RAMIS","RAMIS1","RAINPUT","^TMP($J,""RA D-TYPE"",","^TMP($J,""RA P-TYPE""," S ZTSAVE(RASV)=""
26 W ! D ZIS^RAUTL G:RAPOP Q
27START K ^TMP($J,"RALIST"),RACNT,RAIN,RAOUT
28 ;create list of all procedures with the selected AMIS code if user
29 ;specified that all procedures should be included
30 S:$D(ZTQUEUED) ZTREQ="@"
31 S RADIVNUM=$$NUMDIV^RALIST1()
32 I RAINPUT=1 D
33 . K ^TMP($J,"RA P-TYPE") N RAD0 S RAD0=0
34 . F S RAD0=$O(^RAMIS(71,RAD0)) Q:RAD0'>0 D
35 .. Q:$O(^RAMIS(71,"AC",RAMIS,RAD0,0))'>0
36 .. S X=$P($G(^RAMIS(71,RAD0,0)),U)
37 .. I X]"" S ^TMP($J,"RA P-TYPE",X,RAD0)=""
38 .. Q
39 . Q
40 S Y=BEGDATE D D^RAUTL S BEG=Y,Y=ENDDATE D D^RAUTL S END=Y,%DT="TX",X="NOW" D ^%DT D D^RAUTL S RANOW=Y
41 U IO S (PAGE,RACNT,RAIN,RAOUT,RACOUNT)=0,BEGDATE=BEGDATE-.0001,ENDDATE=ENDDATE+.9999,RACRT=8 D CRIT^RAUTL1
42 F RADTE=BEGDATE:0:ENDDATE S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>ENDDATE) D Q:RAXIT
43 . F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0 D Q:RAXIT
44 .. I $D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$E($P(RANME,"^"),1,25) D RACNI
45 .. Q
46 . Q
47 I RAXIT D Q QUIT
48 S RADIVN=""
49 F S RADIVN=$O(^TMP($J,"RA D-TYPE",RADIVN)) Q:RADIVN="" D
50 . I $O(^TMP($J,"RALIST",RADIVN,0))'>0 S ^TMP($J,"RALIST",RADIVN)=""
51 . Q
52 D PRINT^RALIST1
53 ; Kill and quit
54Q K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA P-TYPE"),^TMP($J,"RALIST")
55 K %DT,BEG,BEGDATE,C,DIC,END,ENDDATE,I,M,M1,PAGE,POP,RAPOP,RACNI,RACNT
56 K RACOUNT,RACRT,RADATE,RADFN,RADIVN,RADTE,RADTI,RAFLG,RAIN,RAINPUT
57 K RAMIS,RAMIS1,RAMUL,RAMUL1,RANME,RANOW,RAOUT,RAPROC,RAQI,RAQUIT,RASSN
58 K RADIVNUM,RASV,RASTAT,N,N1,RABILAT,RAUTIL,RAXIT,TMP,X,Y,ZTRTN,ZTSAVE
59 K DIROUT,DIRUT,DTOUT,DUOUT,RAMES,ZTDESC
60 K:$D(RAPSTX) RACCESS,RAPSTX
61 D CLOSE^RAUTL
62 K DDH,DISYS
63 Q
64 ;
65RACNI S RADTI=9999999.9999-RADTE S Y=RADTE D D^RAUTL S RADATE=Y
66 S (RADIVN,Y)=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,3)
67 S C=$P(^DD(70.02,3,0),U,2) D:Y]"" Y^DIQ S RADIVN(0)=Y Q:RADIVN(0)=""
68 I $D(^TMP($J,"RA D-TYPE",RADIVN(0),RADIVN))[0 Q
69 F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D Q:RAXIT
70 . S Y=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
71 . S RAPROC=$P(Y,U,2),RAPROC(0)=$P($G(^RAMIS(71,+RAPROC,0)),U)
72 . ;if AMIS code 25 or 26 (OR or Portable) was selected, all procedures
73 . ;regardless of AMIS code must be allowed because any exam can have
74 . ;a modifier of Operating Room or Portable.
75 . Q:RAPROC(0)="" I RAMIS'=25&(RAMIS'=26) I $D(^TMP($J,"RA P-TYPE",RAPROC(0),RAPROC))[0 Q
76 . I Y]"",$D(RACRT(+$P(Y,"^",3))) D RACNI1
77 . Q
78 Q
79RACNI1 I $D(^RAMIS(71,"AC",RAMIS,+$P(Y,"^",2))) S RAMUL=$S(RAMIS=25!(RAMIS=26):1,1:$O(^RAMIS(71,"AC",RAMIS,+$P(Y,"^",2),0))) D PRT Q
80 S RAMUL=1
81 F M=0:0 S M=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",M)) Q:'M D Q:RAXIT
82 . S M1=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",M,0))
83 . S M1=$P($G(^RAMIS(71.2,M1,0)),U,2)
84 . D PRT:(RAMIS=26&(M1="p"))&('RAXIT),PRT:(RAMIS=25&(M1="o"))&('RAXIT)
85 . Q
86 Q
87 ;
88PRT I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
89 G PRT1:RAMIS=25!(RAMIS=26)
90 K RABILAT S RAMUL=$P(^RAMIS(71,+$P(Y,"^",2),2,RAMUL,0),"^",2) S:RAMUL="" RAMUL=1 I $P(^(0),"^",3)="Y" S RABILAT=1 S:RAMUL=1 RAMUL=2
91 I '$D(RABILAT) F RAMUL1=0:0 S RAMUL1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAMUL1)) Q:RAMUL1'>0 I $D(^(RAMUL1,0)) S RAQI=+^(0) I $P($G(^RAMIS(71.2,RAQI,0)),U,2)="b" S RAMUL=RAMUL*2 Q
92PRT1 S RACOUNT=RACOUNT+1
93 S TMP=RANME_U_RASSN_U_$S(RAMUL>1:"+",RAMUL=0:"-",1:"")_U
94 S TMP=TMP_$E($S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"Unknown"),1,25)_U
95 S TMP=TMP_RADATE_U_$S($D(^DIC(42,+$P(Y,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(Y,"^",8),0)):$P(^(0),"^"),1:"Unknown")
96 S ^TMP($J,"RALIST",RADIVN(0),RACOUNT)=TMP
97 S RACNT(RADIVN(0))=$G(RACNT(RADIVN(0)))+RAMUL
98 I $P(Y,"^",4)="I" S RAIN(RADIVN(0))=$G(RAIN(RADIVN(0)))+RAMUL Q
99 S RAOUT(RADIVN(0))=$G(RAOUT(RADIVN(0)))+RAMUL
100 Q
Note: See TracBrowser for help on using the repository browser.