RAWKL1 ;HISC/FPT-Workload Reports (cont.) ;12/27/00 11:28
;;5.0;Radiology/Nuclear Medicine;**26,31**;Mar 16, 1998
RADFN ; count & store in tmp global
S RADFN=0 F K RAOR,RAPORT S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0!($D(RAEOS)) I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAD0=^(0) D RACNI
Q
RACNI ;
S RADIV=$P($G(^RA(79,+$P(RAD0,U,3),0)),U),RADIV=$S($D(^DIC(4,+RADIV,0)):+RADIV,1:99)
Q:'$D(^TMP($J,"RA",RADIV)) S RACNI=0
;RAPRIM=0 means want both primary and secondary staff/resid
F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!($D(RAEOS)) I $D(^(RACNI,0)) S RAP0=^(0),RAPIFN=+$P(RAP0,"^",2) I $D(RACRT(+$P(RAP0,U,3))) D ITNAME I RAITYPE?3AP1"-".N D
. D CHK:RAPCE,TC:'RAPCE
. D:RAPCE=12&($G(RAPRIM)=0) SECRES
. D:RAPCE=15&($G(RAPRIM)=0) SECSTF
. Q
Q
CHK ;
Q:'$D(^TMP($J,"RA",RADIV,RAITYPE))
K RAFLD("DESC")
S:RAPCE RAFLD=$S($D(@("^"_RAFILE_"+$P(RAP0,""^"",RAPCE),0)")):$P(^(0),"^"),1:"UNKNOWN") I RAPCE=18,$D(^(0)) S RAFLD("DESC")=" - "_$P(^(0),"^",2)
I RAINPUT=0,'$D(^TMP($J,"RAFLD",RAFLD)) Q
I $D(RAFLD("DESC")) S RAFLD=RAFLD_RAFLD("DESC") K RAFLD("DESC")
S RAFLD=$E(RAFLD,1,30)
S C=$S($D(^DIC(42,+$P(RAP0,"^",6),0)):"IN",1:"OUT")
; for each proc mod, check for Amis Credit Indicator, file 71.2:
; where "b"=bilateral, "o"=operating room, "p"=portable
S I=0 F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:I'>0 I $D(^(I,0)) S RAQI=+^(0) D EXTRA^RAUTL12(RAQI)
Q:'$D(^RAMIS(71,RAPIFN,0)) S RAPRI=^(0)
;raz=^ramis(71,rapifn,2,i,0)
;ramj=^ramis(71.1,+raz,0)
S RAPRC=$$LJ^XLFSTR($E($P(RAPRI,"^"),1,27),29," ") D CPT^RAFLM D CMLIST(.RAPRC) Q:'$D(^RAMIS(71,RAPIFN,2)) S I=0 F S I=$O(^RAMIS(71,RAPIFN,2,I)) Q:I'>0 I $D(^(I,0)) S RAZ=^(0),RAMJ=$S($D(^RAMIS(71.1,+RAZ,0)):^(0),1:"") D PRC
Q:'$D(RAMIS(1))
I J=1 S RAMIS=RAMIS(1),RAWT=RAWT(1),RAMUL=RAMUL(1),RAWT=RAWT*RAMUL,RANUM=RAMUL
I J>1 S RANUM=1,RAWT=0,RAMIS=RAMIS(1) F J=1:1 Q:'$D(RAMIS(J)) S I=RAWT(J),RAMUL=RAMUL(J),RAWT=RAWT+(RAMUL*I)
D STORE K RAMIS,RAWT,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL,RAOR,RAPORT
Q
;
STORE ; Store off into ^TMP($J,"RA"
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS="" Q:$D(RAEOS)
; presence of:
; RAOR = operating room, set from extra^rautl12(-) and/or PRC
; RAPORT = portable, set from extra^rautl12(-) and/or PRC
; RAMULP = proc has >1 Amis Codes
I $D(RAOR) S A=25 D AUX
I $D(RAPORT) S A=26 D AUX
I $D(RAMULP) S A="MULP" D AUX
S X=^TMP($J,"RA",RADIV),^(RADIV)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)
S X=^TMP($J,"RA",RADIV,RAITYPE),^(RAITYPE)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)
S:'($D(^TMP($J,"RA",RADIV,RAITYPE,RAFLD))#2) ^(RAFLD)="0^0^0" S X=^(RAFLD),^(RAFLD)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)
S:'$D(^TMP($J,"RA",RADIV,RAITYPE,RAFLD,RAMIS,RAPRC)) ^(RAPRC)="0^0^0" S X=^(RAPRC),^(RAPRC)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)
Q
; this PRC is done for each Proc's Amis Code sub record
; 1st sub rec would be RAMIS(1), 2nd would be RAMIS(2), etc.
; ramis(j)=ien 71.1
; rawt(j)=record 71.1's WEIGHT
; ramul(j)=file 71'S Amis code sub rec's Amis Weight Multiplier
;
PRC I +RAZ=25 S RAOR="" Q
I +RAZ=26 S RAPORT="" Q
S:$P(RAZ,"^",3)="Y" RABILAT="" F J=1:1 I '$D(RAMIS(J)) S RAMIS(J)=$S(RAMJ]"":+RAZ,1:99),RAWT(J)=+$P(RAMJ,"^",2),RAMUL(J)=$S(+$P(RAZ,"^",2)>0:+$P(RAZ,U,2),1:1) S:$D(RABILAT)&(RAMUL(J)<2) RAMUL(J)=RAMUL(J)*2 S:J>1 RAMULP="" Q
K RABILAT
Q
;
AUX S:'$D(^TMP($J,"RA",RADIV,RAITYPE,RAFLD,A,RAPRC)) ^(RAPRC)="0^0^0" S X=^(RAPRC),^(RAPRC)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+RAWT)
Q
;
TC S RATCI=0 F S RATCI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",RATCI)) Q:RATCI'>0 S RAFLD=$S($D(^VA(200,+^(RATCI,0),0)):$P(^(0),"^"),1:"") D:RAFLD]"" CHK
Q
SECRES ; count secondary residents
Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0))
S RASRR=0,RAPCE(1)=RAPCE,RAPCE="SRR"
F S RASRR=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RASRR)) Q:RASRR'>0 S RAFLD=$S($D(^VA(200,+^(RASRR,0),0)):$P(^(0),"^",1),1:"") D:RAFLD]"" CHK
K RASRR S RAPCE=RAPCE(1)
Q
SECSTF ; count secondary staff
Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0))
S RASSR=0,RAPCE(1)=RAPCE,RAPCE="SSR"
F S RASSR=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RASSR)) Q:RASSR'>0 S RAFLD=$S($D(^VA(200,+^(RASSR,0),0)):$P(^(0),"^",1),1:"") D:RAFLD]"" CHK
K RASSR S RAPCE=RAPCE(1)
Q
;
ITNAME ; get imaging type name from Exam's exam status
S RAITNUM=$P($G(^RA(72,+$P(RAP0,U,3),0)),U,7)
S RAITYPE=$E($P($G(^RA(79.2,+RAITNUM,0)),U,1),1,3)_"-"_+RAITNUM
K RAITNUM
Q
CMLIST(RASTR) ;append max 3 CPTmods onto string and within any ()
Q:'$G(RACMLIST) ;user doesn't want CPT mods as separate line items
Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))
N RACMSTR,I,J,X
S I=0 ;put into array to let M sort external values of CPT Mods
F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I)) Q:I'>0 S X=$$BASICMOD^RACPTMSC(+$G(^(I,0)),DT),RACMSTR($P(X,U,2))=""
S I="",J=0
F S I=$O(RACMSTR(I)) Q:I="" S J=J+1 Q:J>3 S RACMSTR=$G(RACMSTR)_$S($G(RACMSTR)="":"",1:",")_I
S:J>3 RACMSTR=RACMSTR_"*"
S:RASTR["(" RASTR=$E(RASTR,1,($L(RASTR)-1)) ;remove ")"
S RASTR=RASTR_"-"_RACMSTR_$S(RASTR["(":")",1:"") ;append CPTmods to str
Q
RAWKL1 ;HISC/FPT-Workload Reports (cont.) ;12/27/00 11:28
+1 ;;5.0;Radiology/Nuclear Medicine;**26,31**;Mar 16, 1998
RADFN ; count & store in tmp global
+1 SET RADFN=0
FOR
KILL RAOR,RAPORT
SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
IF RADFN'>0!($DATA(RAEOS))
QUIT
IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
SET RAD0=^(0)
DO RACNI
+2 QUIT
RACNI ;
+1 SET RADIV=$PIECE($GET(^RA(79,+$PIECE(RAD0,U,3),0)),U)
SET RADIV=$SELECT($DATA(^DIC(4,+RADIV,0)):+RADIV,1:99)
+2 IF '$DATA(^TMP($JOB,"RA",RADIV))
QUIT
SET RACNI=0
+3 ;RAPRIM=0 means want both primary and secondary staff/resid
+4 FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
IF RACNI'>0!($DATA(RAEOS))
QUIT
IF $DATA(^(RACNI,0))
SET RAP0=^(0)
SET RAPIFN=+$PIECE(RAP0,"^",2)
IF $DATA(RACRT(+$PIECE(RAP0,U,3)))
DO ITNAME
IF RAITYPE?3AP1"-".N
Begin DoDot:1
+5 IF RAPCE
DO CHK
IF 'RAPCE
DO TC
+6 IF RAPCE=12&($GET(RAPRIM)=0)
DO SECRES
+7 IF RAPCE=15&($GET(RAPRIM)=0)
DO SECSTF
+8 QUIT
End DoDot:1
+9 QUIT
CHK ;
+1 IF '$DATA(^TMP($JOB,"RA",RADIV,RAITYPE))
QUIT
+2 KILL RAFLD("DESC")
+3 IF RAPCE
SET RAFLD=$SELECT($DATA(@("^"_RAFILE_"+$P(RAP0,""^"",RAPCE),0)")):$PIECE(^(0),"^"),1:"UNKNOWN")
IF RAPCE=18
IF $DATA(^(0))
SET RAFLD("DESC")=" - "_$PIECE(^(0),"^",2)
+4 IF RAINPUT=0
IF '$DATA(^TMP($JOB,"RAFLD",RAFLD))
QUIT
+5 IF $DATA(RAFLD("DESC"))
SET RAFLD=RAFLD_RAFLD("DESC")
KILL RAFLD("DESC")
+6 SET RAFLD=$EXTRACT(RAFLD,1,30)
+7 SET C=$SELECT($DATA(^DIC(42,+$PIECE(RAP0,"^",6),0)):"IN",1:"OUT")
+8 ; for each proc mod, check for Amis Credit Indicator, file 71.2:
+9 ; where "b"=bilateral, "o"=operating room, "p"=portable
+10 SET I=0
FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I))
IF I'>0
QUIT
IF $DATA(^(I,0))
SET RAQI=+^(0)
DO EXTRA^RAUTL12(RAQI)
+11 IF '$DATA(^RAMIS(71,RAPIFN,0))
QUIT
SET RAPRI=^(0)
+12 ;raz=^ramis(71,rapifn,2,i,0)
+13 ;ramj=^ramis(71.1,+raz,0)
+14 SET RAPRC=$$LJ^XLFSTR($EXTRACT($PIECE(RAPRI,"^"),1,27),29," ")
DO CPT^RAFLM
DO CMLIST(.RAPRC)
IF '$DATA(^RAMIS(71,RAPIFN,2))
QUIT
SET I=0
FOR
SET I=$ORDER(^RAMIS(71,RAPIFN,2,I))
IF I'>0
QUIT
IF $DATA(^(I,0))
SET RAZ=^(0)
SET RAMJ=$SELECT($DATA(^RAMIS(71.1,+RAZ,0)):^(0),1:"")
DO PRC
+15 IF '$DATA(RAMIS(1))
QUIT
+16 IF J=1
SET RAMIS=RAMIS(1)
SET RAWT=RAWT(1)
SET RAMUL=RAMUL(1)
SET RAWT=RAWT*RAMUL
SET RANUM=RAMUL
+17 IF J>1
SET RANUM=1
SET RAWT=0
SET RAMIS=RAMIS(1)
FOR J=1:1
IF '$DATA(RAMIS(J))
QUIT
SET I=RAWT(J)
SET RAMUL=RAMUL(J)
SET RAWT=RAWT+(RAMUL*I)
+18 DO STORE
KILL RAMIS,RAWT,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL,RAOR,RAPORT
+19 QUIT
+20 ;
STORE ; Store off into ^TMP($J,"RA"
+1 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
IF $GET(ZTSTOP)=1
SET RAEOS=""
IF $DATA(RAEOS)
QUIT
+2 ; presence of:
+3 ; RAOR = operating room, set from extra^rautl12(-) and/or PRC
+4 ; RAPORT = portable, set from extra^rautl12(-) and/or PRC
+5 ; RAMULP = proc has >1 Amis Codes
+6 IF $DATA(RAOR)
SET A=25
DO AUX
+7 IF $DATA(RAPORT)
SET A=26
DO AUX
+8 IF $DATA(RAMULP)
SET A="MULP"
DO AUX
+9 SET X=^TMP($JOB,"RA",RADIV)
SET ^(RADIV)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)
+10 SET X=^TMP($JOB,"RA",RADIV,RAITYPE)
SET ^(RAITYPE)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)
+11 IF '($DATA(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLD))#2)
SET ^(RAFLD)="0^0^0"
SET X=^(RAFLD)
SET ^(RAFLD)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)
+12 IF '$DATA(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLD,RAMIS,RAPRC))
SET ^(RAPRC)="0^0^0"
SET X=^(RAPRC)
SET ^(RAPRC)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)
+13 QUIT
+14 ; this PRC is done for each Proc's Amis Code sub record
+15 ; 1st sub rec would be RAMIS(1), 2nd would be RAMIS(2), etc.
+16 ; ramis(j)=ien 71.1
+17 ; rawt(j)=record 71.1's WEIGHT
+18 ; ramul(j)=file 71'S Amis code sub rec's Amis Weight Multiplier
+19 ;
PRC IF +RAZ=25
SET RAOR=""
QUIT
+1 IF +RAZ=26
SET RAPORT=""
QUIT
+2 IF $PIECE(RAZ,"^",3)="Y"
SET RABILAT=""
FOR J=1:1
IF '$DATA(RAMIS(J))
SET RAMIS(J)=$SELECT(RAMJ]"":+RAZ,1:99)
SET RAWT(J)=+$PIECE(RAMJ,"^",2)
SET RAMUL(J)=$SELECT(+$PIECE(RAZ,"^",2)>0:+$PIECE(RAZ,U,2),1:1)
IF $DATA(RABILAT)&(RAMUL(J)<2)
SET RAMUL(J)=RAMUL(J)*2
IF J>1
SET RAMULP=""
QUIT
+3 KILL RABILAT
+4 QUIT
+5 ;
AUX IF '$DATA(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLD,A,RAPRC))
SET ^(RAPRC)="0^0^0"
SET X=^(RAPRC)
SET ^(RAPRC)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+RAWT)
+1 QUIT
+2 ;
TC SET RATCI=0
FOR
SET RATCI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",RATCI))
IF RATCI'>0
QUIT
SET RAFLD=$SELECT($DATA(^VA(200,+^(RATCI,0),0)):$PIECE(^(0),"^"),1:"")
IF RAFLD]""
DO CHK
+1 QUIT
SECRES ; count secondary residents
+1 IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0))
QUIT
+2 SET RASRR=0
SET RAPCE(1)=RAPCE
SET RAPCE="SRR"
+3 FOR
SET RASRR=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RASRR))
IF RASRR'>0
QUIT
SET RAFLD=$SELECT($DATA(^VA(200,+^(RASRR,0),0)):$PIECE(^(0),"^",1),1:"")
IF RAFLD]""
DO CHK
+4 KILL RASRR
SET RAPCE=RAPCE(1)
+5 QUIT
SECSTF ; count secondary staff
+1 IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0))
QUIT
+2 SET RASSR=0
SET RAPCE(1)=RAPCE
SET RAPCE="SSR"
+3 FOR
SET RASSR=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RASSR))
IF RASSR'>0
QUIT
SET RAFLD=$SELECT($DATA(^VA(200,+^(RASSR,0),0)):$PIECE(^(0),"^",1),1:"")
IF RAFLD]""
DO CHK
+4 KILL RASSR
SET RAPCE=RAPCE(1)
+5 QUIT
+6 ;
ITNAME ; get imaging type name from Exam's exam status
+1 SET RAITNUM=$PIECE($GET(^RA(72,+$PIECE(RAP0,U,3),0)),U,7)
+2 SET RAITYPE=$EXTRACT($PIECE($GET(^RA(79.2,+RAITNUM,0)),U,1),1,3)_"-"_+RAITNUM
+3 KILL RAITNUM
+4 QUIT
CMLIST(RASTR) ;append max 3 CPTmods onto string and within any ()
+1 ;user doesn't want CPT mods as separate line items
IF '$GET(RACMLIST)
QUIT
+2 IF '$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))
QUIT
+3 NEW RACMSTR,I,J,X
+4 ;put into array to let M sort external values of CPT Mods
SET I=0
+5 FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I))
IF I'>0
QUIT
SET X=$$BASICMOD^RACPTMSC(+$GET(^(I,0)),DT)
SET RACMSTR($PIECE(X,U,2))=""
+6 SET I=""
SET J=0
+7 FOR
SET I=$ORDER(RACMSTR(I))
IF I=""
QUIT
SET J=J+1
IF J>3
QUIT
SET RACMSTR=$GET(RACMSTR)_$SELECT($GET(RACMSTR)="":"",1:",")_I
+8 IF J>3
SET RACMSTR=RACMSTR_"*"
+9 ;remove ")"
IF RASTR["("
SET RASTR=$EXTRACT(RASTR,1,($LENGTH(RASTR)-1))
+10 ;append CPTmods to str
SET RASTR=RASTR_"-"_RACMSTR_$SELECT(RASTR["(":")",1:"")
+11 QUIT
