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