RACPT ;HISC/GJC AISC/DMK-Procedure/CPT Stats Report ;12/29/00 11:27
;;5.0;Radiology/Nuclear Medicine;**26**;Mar 16, 1998
CHK D CHK^RACPT1 I $G(RAQUIT)!$G(RAPOP) G Q
START ; start processing
U IO K ^TMP($J,"RA")
S BEGDATE(0)=$E(BEGDATE,4,5)_"/"_$E(BEGDATE,6,7)_"/"_$E(BEGDATE,2,3)
S ENDDATE(0)=$E(ENDDATE,4,5)_"/"_$E(ENDDATE,6,7)_"/"_$E(ENDDATE,2,3)
S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL S RARUNDTE=Y
S QQ="",$P(QQ,"=",80)="=",X=""
S RASORT=$S(RASORT="B":"I,O",1:RASORT)
F I=RABEG-.0001:0 S I=$O(^RADPT("AR",I)) Q:'I!(I>RAEND) S RADFN="" F S RADFN=$O(^RADPT("AR",I,RADFN)) Q:RADFN'>0 S RADTI=9999999.9999-I I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAY=^(0) D MORE
DIV K RAIMAG
F II=1:1 S RAI=$P(RASORT,",",II) Q:RAI="" S RADIVN(0)="" F S RADIVN(0)=$O(^TMP($J,"RA D-TYPE",RADIVN(0))) Q:RADIVN(0)="" S RADIVN=0 F S RADIVN=$O(^TMP($J,"RA D-TYPE",RADIVN(0),RADIVN)) Q:RADIVN'>0 D
. S RAIMAG(0)=""
. F S RAIMAG(0)=$O(^TMP($J,"RA I-TYPE",RAIMAG(0))) Q:RAIMAG(0)="" S RAIMAG=0 F S RAIMAG=$O(^TMP($J,"RA I-TYPE",RAIMAG(0),RAIMAG)) Q:RAIMAG'>0 D
.. S RAIMAG(1)=$E(RAIMAG(0),1,3)_"-"_RAIMAG
.. I $O(^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),""))="" S ^TMP($J,"RA",RAI,RADIVN,RAIMAG(1))="" Q ;un-used Div-Img combin.
.. S L="" F S L=$O(^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),L)) Q:L="" S K="" F S K=$O(^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),L,K)) Q:K="" D
... S ^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),"COST")=^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),L,K)*$P($G(^RAMIS(71,K,0)),U,10)+$G(^TMP($J,"RA",RAI,RADIVN,RAIMAG(1),"COST"))
... Q
.. Q
. Q
S (RADIV,X,RAI)="",RAEXIT=0,PAGE=1
F II=1:1 S RAI=$P(RASORT,",",II) Q:RAI=""!RAEXIT D HANG^RACPT1:$$SRTPA^RACPT1(II) Q:RAEXIT S RADIV="" F S RADIV=$O(^TMP($J,"RA",RAI,RADIV)) Q:RADIV=""!RAEXIT D GET
Q ;
F I="RA","RA D-TYPE","RA I-TYPE","RA P-TYPE" K ^TMP($J,I)
K BEGDATE,C,ENDDATE,I,II,J,K,L,PAGE,QQ,RABEG,RACAT,RACN,RACNI,CPT,RADFN
K RADIV,RADIV1,RADIVN,RADTI,RAEND,RAEOPFLG,RAEXIT,RAI,RAIMAG,RAINPUT
K RAPOP,RAPROC,RAQUIT,RARUNDTE,RASORT,RASW,RATOT,RAUT,RAX,RAY,RASV
K %DT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,RAMES,RANUMPRC,RAUTIL,X,Y,Z,ZTDESC
K RACAN,ZTRTN,ZTSAVE,ZTSK,RACMLIST
K:$D(RAPSTX) RACCESS,RAPSTX
W ! D CLOSE^RAUTL
K DDH,POP
Q
; data storage description :
; ^tmp($j,"ra","o",499,"gen-1",36200,751)=2 ; two of this proc was done
; ^tmp($j,"ra","o",499,"gen-1",71021,59)=5 ; five of this proc was done
; ... etc.
; ^tmp($j,"ra","o",499,"gen-1","cost")=sum cost all procs this img typ
; ^tmp($j,"ra","o",499,"gen-1","done")=sum total no. procs this img typ
MORE ;
S (RAIMAG,Y)=$P(RAY,U,2),C=$P(^DD(70.02,2,0),U,2) Q:RAIMAG'>0
D Y^DIQ S RAIMAG(0)=Y,RAIMAG(1)=$E(RAIMAG(0),1,3)_"-"_RAIMAG
I $D(^TMP($J,"RA I-TYPE",RAIMAG(0),RAIMAG))[0 Q ;img loc not selected
S (RADIVN,Y)=$P(RAY,U,3),C=$P(^DD(70.02,3,0),U,2) Q:RADIVN'>0
D Y^DIQ S RADIVN(0)=Y
I $D(^TMP($J,"RA D-TYPE",RADIVN(0),RADIVN))[0 Q ;div not selected
S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RAX=^(0) D SET
Q
SET ;
Q:'RACAN&($P($G(^RA(72,+$P(RAX,"^",3),0)),"^",3)=0) ; quit if
; cancelled exams are not to be included & our exam is indeed cancelled
S RADIV=$P(RAY,"^",3) Q:RADIV=""
S (RAPROC,Y)=+$P(RAX,"^",2),C=$P(^DD(70.03,2,0),U,2) Q:RAPROC'>0
D Y^DIQ S RAPROC(0)=Y
I $D(^TMP($J,"RA P-TYPE",RAPROC(0),RAPROC))[0,RAINPUT=0 Q ;proc not sel
S RACAT=$S($D(^DIC(42,+$P(RAX,"^",6),0)):"I",1:"O")
Q:RASORT'[RACAT ;category of in/outpatient status not selected
S CPT=$S($D(^RAMIS(71,RAPROC,0)):$P(^(0),"^",9),1:"") Q:CPT=""
D:$G(RACMLIST) CMLIST^RAWKL1(.CPT)
S ^TMP($J,"RA",RACAT,RADIV,RAIMAG(1),CPT,RAPROC)=$G(^TMP($J,"RA",RACAT,RADIV,RAIMAG(1),CPT,RAPROC))+1
S ^TMP($J,"RA",RACAT,RADIV,RAIMAG(1),"DONE")=$G(^TMP($J,"RA",RACAT,RADIV,RAIMAG(1),"DONE"))+1
Q
GET ;
S RAIMAG(1)="",RAEOPFLG=0
F S RAIMAG(1)=$O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1))) Q:RAIMAG(1)=""!RAEXIT S RATOT(3)=0 D
. S RAIMAG=+$P(RAIMAG(1),"-",2)
. S RAIMAG(0)=$P($G(^RA(79.2,RAIMAG,0)),U)
. I RAIMAG(0)="" S RAIMAG(0)="UNKNOWN"
. D HED^RACPT1
. I $O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1),""))="" D Q
.. W !!,"No reports entered for the selected time frame."
.. I ($O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1)))]"")!($O(^TMP($J,"RA",RAI,RADIV))]"")!($O(^TMP($J,"RA",RAI))]"") S RAEOPFLG=1 D HANG^RACPT1
.. Q
. S CPT=""
. F S CPT=$O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1),CPT)) Q:CPT=""!RAEXIT S J=0 D
.. F S J=$O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1),CPT,J)) Q:J'>0!RAEXIT S RATOT=^(J) D PRINT^RACPT1 Q:RAEXIT
.. Q
. W !?12,"Total for this imaging type -->",?45,$J(^TMP($J,"RA",RAI,RADIV,RAIMAG(1),"DONE"),5),?63,$J(^("COST"),12,2)
. I ($O(^TMP($J,"RA",RAI,RADIV,RAIMAG(1)))]"")!($O(^TMP($J,"RA",RAI,RADIV))]"") S RAEOPFLG=1 D HANG^RACPT1
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRACPT 4801 printed Dec 13, 2024@02:34:10 Page 2
RACPT ;HISC/GJC AISC/DMK-Procedure/CPT Stats Report ;12/29/00 11:27
+1 ;;5.0;Radiology/Nuclear Medicine;**26**;Mar 16, 1998
CHK DO CHK^RACPT1
IF $GET(RAQUIT)!$GET(RAPOP)
GOTO Q
START ; start processing
+1 USE IO
KILL ^TMP($JOB,"RA")
+2 SET BEGDATE(0)=$EXTRACT(BEGDATE,4,5)_"/"_$EXTRACT(BEGDATE,6,7)_"/"_$EXTRACT(BEGDATE,2,3)
+3 SET ENDDATE(0)=$EXTRACT(ENDDATE,4,5)_"/"_$EXTRACT(ENDDATE,6,7)_"/"_$EXTRACT(ENDDATE,2,3)
+4 SET X="NOW"
SET %DT="T"
DO ^%DT
KILL %DT
DO D^RAUTL
SET RARUNDTE=Y
+5 SET QQ=""
SET $PIECE(QQ,"=",80)="="
SET X=""
+6 SET RASORT=$SELECT(RASORT="B":"I,O",1:RASORT)
+7 FOR I=RABEG-.0001:0
SET I=$ORDER(^RADPT("AR",I))
if 'I!(I>RAEND)
QUIT
SET RADFN=""
FOR
SET RADFN=$ORDER(^RADPT("AR",I,RADFN))
if RADFN'>0
QUIT
SET RADTI=9999999.9999-I
IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
SET RAY=^(0)
DO MORE
DIV KILL RAIMAG
+1 FOR II=1:1
SET RAI=$PIECE(RASORT,",",II)
if RAI=""
QUIT
SET RADIVN(0)=""
FOR
SET RADIVN(0)=$ORDER(^TMP($JOB,"RA D-TYPE",RADIVN(0)))
if RADIVN(0)=""
QUIT
SET RADIVN=0
FOR
SET RADIVN=$ORDER(^TMP($JOB,"RA D-TYPE",RADIVN(0),RADIVN))
if RADIVN'>0
QUIT
Begin DoDot:1
+2 SET RAIMAG(0)=""
+3 FOR
SET RAIMAG(0)=$ORDER(^TMP($JOB,"RA I-TYPE",RAIMAG(0)))
if RAIMAG(0)=""
QUIT
SET RAIMAG=0
FOR
SET RAIMAG=$ORDER(^TMP($JOB,"RA I-TYPE",RAIMAG(0),RAIMAG))
if RAIMAG'>0
QUIT
Begin DoDot:2
+4 SET RAIMAG(1)=$EXTRACT(RAIMAG(0),1,3)_"-"_RAIMAG
+5 ;un-used Div-Img combin.
IF $ORDER(^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),""))=""
SET ^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1))=""
QUIT
+6 SET L=""
FOR
SET L=$ORDER(^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),L))
if L=""
QUIT
SET K=""
FOR
SET K=$ORDER(^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),L,K))
if K=""
QUIT
Begin DoDot:3
+7 SET ^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),"COST")=^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),L,K)*$PIECE($GET(^RAMIS(71,K,0)),U,10)+$GET(^TMP($JOB,"RA",RAI,RADIVN,RAIMAG(1),"COST"))
+8 QUIT
End DoDot:3
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET (RADIV,X,RAI)=""
SET RAEXIT=0
SET PAGE=1
+12 FOR II=1:1
SET RAI=$PIECE(RASORT,",",II)
if RAI=""!RAEXIT
QUIT
if $$SRTPA^RACPT1(II)
DO HANG^RACPT1
if RAEXIT
QUIT
SET RADIV=""
FOR
SET RADIV=$ORDER(^TMP($JOB,"RA",RAI,RADIV))
if RADIV=""!RAEXIT
QUIT
DO GET
Q ;
+1 FOR I="RA","RA D-TYPE","RA I-TYPE","RA P-TYPE"
KILL ^TMP($JOB,I)
+2 KILL BEGDATE,C,ENDDATE,I,II,J,K,L,PAGE,QQ,RABEG,RACAT,RACN,RACNI,CPT,RADFN
+3 KILL RADIV,RADIV1,RADIVN,RADTI,RAEND,RAEOPFLG,RAEXIT,RAI,RAIMAG,RAINPUT
+4 KILL RAPOP,RAPROC,RAQUIT,RARUNDTE,RASORT,RASW,RATOT,RAUT,RAX,RAY,RASV
+5 KILL %DT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,RAMES,RANUMPRC,RAUTIL,X,Y,Z,ZTDESC
+6 KILL RACAN,ZTRTN,ZTSAVE,ZTSK,RACMLIST
+7 if $DATA(RAPSTX)
KILL RACCESS,RAPSTX
+8 WRITE !
DO CLOSE^RAUTL
+9 KILL DDH,POP
+10 QUIT
+11 ; data storage description :
+12 ; ^tmp($j,"ra","o",499,"gen-1",36200,751)=2 ; two of this proc was done
+13 ; ^tmp($j,"ra","o",499,"gen-1",71021,59)=5 ; five of this proc was done
+14 ; ... etc.
+15 ; ^tmp($j,"ra","o",499,"gen-1","cost")=sum cost all procs this img typ
+16 ; ^tmp($j,"ra","o",499,"gen-1","done")=sum total no. procs this img typ
MORE ;
+1 SET (RAIMAG,Y)=$PIECE(RAY,U,2)
SET C=$PIECE(^DD(70.02,2,0),U,2)
if RAIMAG'>0
QUIT
+2 DO Y^DIQ
SET RAIMAG(0)=Y
SET RAIMAG(1)=$EXTRACT(RAIMAG(0),1,3)_"-"_RAIMAG
+3 ;img loc not selected
IF $DATA(^TMP($JOB,"RA I-TYPE",RAIMAG(0),RAIMAG))[0
QUIT
+4 SET (RADIVN,Y)=$PIECE(RAY,U,3)
SET C=$PIECE(^DD(70.02,3,0),U,2)
if RADIVN'>0
QUIT
+5 DO Y^DIQ
SET RADIVN(0)=Y
+6 ;div not selected
IF $DATA(^TMP($JOB,"RA D-TYPE",RADIVN(0),RADIVN))[0
QUIT
+7 SET RACNI=0
FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if 'RACNI
QUIT
IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
SET RAX=^(0)
DO SET
+8 QUIT
SET ;
+1 ; quit if
if 'RACAN&($PIECE($GET(^RA(72,+$PIECE(RAX,"^",3),0)),"^",3)=0)
QUIT
+2 ; cancelled exams are not to be included & our exam is indeed cancelled
+3 SET RADIV=$PIECE(RAY,"^",3)
if RADIV=""
QUIT
+4 SET (RAPROC,Y)=+$PIECE(RAX,"^",2)
SET C=$PIECE(^DD(70.03,2,0),U,2)
if RAPROC'>0
QUIT
+5 DO Y^DIQ
SET RAPROC(0)=Y
+6 ;proc not sel
IF $DATA(^TMP($JOB,"RA P-TYPE",RAPROC(0),RAPROC))[0
IF RAINPUT=0
QUIT
+7 SET RACAT=$SELECT($DATA(^DIC(42,+$PIECE(RAX,"^",6),0)):"I",1:"O")
+8 ;category of in/outpatient status not selected
if RASORT'[RACAT
QUIT
+9 SET CPT=$SELECT($DATA(^RAMIS(71,RAPROC,0)):$PIECE(^(0),"^",9),1:"")
if CPT=""
QUIT
+10 if $GET(RACMLIST)
DO CMLIST^RAWKL1(.CPT)
+11 SET ^TMP($JOB,"RA",RACAT,RADIV,RAIMAG(1),CPT,RAPROC)=$GET(^TMP($JOB,"RA",RACAT,RADIV,RAIMAG(1),CPT,RAPROC))+1
+12 SET ^TMP($JOB,"RA",RACAT,RADIV,RAIMAG(1),"DONE")=$GET(^TMP($JOB,"RA",RACAT,RADIV,RAIMAG(1),"DONE"))+1
+13 QUIT
GET ;
+1 SET RAIMAG(1)=""
SET RAEOPFLG=0
+2 FOR
SET RAIMAG(1)=$ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1)))
if RAIMAG(1)=""!RAEXIT
QUIT
SET RATOT(3)=0
Begin DoDot:1
+3 SET RAIMAG=+$PIECE(RAIMAG(1),"-",2)
+4 SET RAIMAG(0)=$PIECE($GET(^RA(79.2,RAIMAG,0)),U)
+5 IF RAIMAG(0)=""
SET RAIMAG(0)="UNKNOWN"
+6 DO HED^RACPT1
+7 IF $ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1),""))=""
Begin DoDot:2
+8 WRITE !!,"No reports entered for the selected time frame."
+9 IF ($ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1)))]"")!($ORDER(^TMP($JOB,"RA",RAI,RADIV))]"")!($ORDER(^TMP($JOB,"RA",RAI))]"")
SET RAEOPFLG=1
DO HANG^RACPT1
+10 QUIT
End DoDot:2
QUIT
+11 SET CPT=""
+12 FOR
SET CPT=$ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1),CPT))
if CPT=""!RAEXIT
QUIT
SET J=0
Begin DoDot:2
+13 FOR
SET J=$ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1),CPT,J))
if J'>0!RAEXIT
QUIT
SET RATOT=^(J)
DO PRINT^RACPT1
if RAEXIT
QUIT
+14 QUIT
End DoDot:2
+15 WRITE !?12,"Total for this imaging type -->",?45,$JUSTIFY(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1),"DONE"),5),?63,$JUSTIFY(^("COST"),12,2)
+16 IF ($ORDER(^TMP($JOB,"RA",RAI,RADIV,RAIMAG(1)))]"")!($ORDER(^TMP($JOB,"RA",RAI,RADIV))]"")
SET RAEOPFLG=1
DO HANG^RACPT1
+17 QUIT
End DoDot:1
+18 QUIT
