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

RALIST ;HISC/GJC AISC/MJK,RMO-List all patient exams associated w/selected Amis ;4/15/96  14:27
 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
 I $O(RACCESS(DUZ,""))="" D  Q
 . W !?5,"You do not have access to any Imaging Locations."
 . W !?5,"Contact your ADPAC."
 . Q
 S (RAFLG,RAXIT)=0
 D SELDIV^RAUTL7
 I $O(^TMP($J,"RA D-TYPE",""))=""!$G(RAQUIT) W !!?5,"No divisions selected." G Q
 D DATE^RAUTL G:RAPOP Q
 S DIC="^RAMIS(71.1,",DIC(0)="AEMQ" W ! D ^DIC G Q:Y<0 S RAMIS=+Y,RAMIS1=$P(Y,"^",2)
 K DIR S DIR(0)="YA",DIR("B")="Yes"
 S DIR("A")="Do you wish to include all Procedures? "
 S DIR("?",1)="Enter 'Yes' to select all entries in the file."
 S DIR("?")="Enter 'No' to select a subset of entries in the file."
 W ! D ^DIR K DIR G:$D(DIRUT) Q S RAINPUT=+Y
 I RAINPUT=0 S RAXIT=0 D  G:RAXIT Q
 . K RADIC
 . S RADIC="^RAMIS(71,",RADIC(0)="EMQZ",RADIC("A")="Select PROCEDURE: "
 . S RADIC("S")="I $O(^RAMIS(71,""AC"",RAMIS,+Y,0))",RAUTIL="RA P-TYPE"
 . D EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
 . I $O(^TMP($J,"RA P-TYPE",""))=""!$G(RAQUIT) W !!?5,"No procedures selected." S RAXIT=1
 . Q
 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)=""
 W ! D ZIS^RAUTL G:RAPOP Q
START K ^TMP($J,"RALIST"),RACNT,RAIN,RAOUT
 ;create list of all procedures with the selected AMIS code if user
 ;specified that all procedures should be included
 S:$D(ZTQUEUED) ZTREQ="@"
 S RADIVNUM=$$NUMDIV^RALIST1()
 I RAINPUT=1 D
 . K ^TMP($J,"RA P-TYPE") N RAD0 S RAD0=0
 . F  S RAD0=$O(^RAMIS(71,RAD0)) Q:RAD0'>0  D
 .. Q:$O(^RAMIS(71,"AC",RAMIS,RAD0,0))'>0
 .. S X=$P($G(^RAMIS(71,RAD0,0)),U)
 .. I X]"" S ^TMP($J,"RA P-TYPE",X,RAD0)=""
 .. Q
 . Q
 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
 U IO S (PAGE,RACNT,RAIN,RAOUT,RACOUNT)=0,BEGDATE=BEGDATE-.0001,ENDDATE=ENDDATE+.9999,RACRT=8 D CRIT^RAUTL1
 F RADTE=BEGDATE:0:ENDDATE S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>ENDDATE)  D  Q:RAXIT
 . F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0  D  Q:RAXIT
 .. I $D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$E($P(RANME,"^"),1,25) D RACNI
 .. Q
 . Q
 I RAXIT D Q QUIT
 S RADIVN=""
 F  S RADIVN=$O(^TMP($J,"RA D-TYPE",RADIVN)) Q:RADIVN=""  D
 . I $O(^TMP($J,"RALIST",RADIVN,0))'>0 S ^TMP($J,"RALIST",RADIVN)=""
 . Q
 D PRINT^RALIST1
 ; Kill and quit
Q K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA P-TYPE"),^TMP($J,"RALIST")
 K %DT,BEG,BEGDATE,C,DIC,END,ENDDATE,I,M,M1,PAGE,POP,RAPOP,RACNI,RACNT
 K RACOUNT,RACRT,RADATE,RADFN,RADIVN,RADTE,RADTI,RAFLG,RAIN,RAINPUT
 K RAMIS,RAMIS1,RAMUL,RAMUL1,RANME,RANOW,RAOUT,RAPROC,RAQI,RAQUIT,RASSN
 K RADIVNUM,RASV,RASTAT,N,N1,RABILAT,RAUTIL,RAXIT,TMP,X,Y,ZTRTN,ZTSAVE
 K DIROUT,DIRUT,DTOUT,DUOUT,RAMES,ZTDESC
 K:$D(RAPSTX) RACCESS,RAPSTX
 D CLOSE^RAUTL
 K DDH,DISYS
 Q
 ;
RACNI S RADTI=9999999.9999-RADTE S Y=RADTE D D^RAUTL S RADATE=Y
 S (RADIVN,Y)=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,3)
 S C=$P(^DD(70.02,3,0),U,2) D:Y]"" Y^DIQ S RADIVN(0)=Y Q:RADIVN(0)=""
 I $D(^TMP($J,"RA D-TYPE",RADIVN(0),RADIVN))[0 Q
 F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0  D  Q:RAXIT
 . S Y=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
 . S RAPROC=$P(Y,U,2),RAPROC(0)=$P($G(^RAMIS(71,+RAPROC,0)),U)
 . ;if AMIS code 25 or 26 (OR or Portable) was selected, all procedures
 . ;regardless of AMIS code must be allowed because any exam can have
 . ;a modifier of Operating Room or Portable.
 . Q:RAPROC(0)=""  I RAMIS'=25&(RAMIS'=26) I $D(^TMP($J,"RA P-TYPE",RAPROC(0),RAPROC))[0 Q
 . I Y]"",$D(RACRT(+$P(Y,"^",3))) D RACNI1
 . Q
 Q
RACNI1 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
 S RAMUL=1
 F M=0:0 S M=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",M)) Q:'M  D  Q:RAXIT
 . S M1=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",M,0))
 . S M1=$P($G(^RAMIS(71.2,M1,0)),U,2)
 . D PRT:(RAMIS=26&(M1="p"))&('RAXIT),PRT:(RAMIS=25&(M1="o"))&('RAXIT)
 . Q
 Q
 ;
PRT I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
 G PRT1:RAMIS=25!(RAMIS=26)
 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
 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
PRT1 S RACOUNT=RACOUNT+1
 S TMP=RANME_U_RASSN_U_$S(RAMUL>1:"+",RAMUL=0:"-",1:"")_U
 S TMP=TMP_$E($S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"Unknown"),1,25)_U
 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")
 S ^TMP($J,"RALIST",RADIVN(0),RACOUNT)=TMP
 S RACNT(RADIVN(0))=$G(RACNT(RADIVN(0)))+RAMUL
 I $P(Y,"^",4)="I" S RAIN(RADIVN(0))=$G(RAIN(RADIVN(0)))+RAMUL Q
 S RAOUT(RADIVN(0))=$G(RAOUT(RADIVN(0)))+RAMUL
 Q