RAPRC ;HISC/FPT AISC/MJK-Radiology Procedure Workload Report ;6/18/97 09:57
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;
; called by RA WKLPROCEDURE
;
K ^TMP($J,"RA"),^TMP($J,"RAPRC"),^TMP($J,"DIV-IMG")
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
S X=$$SETUPDI^RAUTL7() I X D Q^RAPRC1 Q
D SELDIV^RAUTL7 I '$D(^TMP($J,"RA D-TYPE"))!($G(RAQUIT)) D Q^RAPRC1 Q
D IT I RAITYPE="" D Q^RAPRC1 Q
S A=""
F S A=$O(RACCESS(DUZ,"DIV-IMG",A)) Q:A']"" D
.Q:'$D(^TMP($J,"RA D-TYPE",A)) S A1=$O(^TMP($J,"RA D-TYPE",A,0))
.Q:A1'>0 S B=""
.F S B=$O(RACCESS(DUZ,"DIV-IMG",A,B)) Q:B']"" D
..I B=RAITYPE S ^TMP($J,"RAPRC",A1)=0
I '$D(^TMP($J,"RAPRC")) D Q^RAPRC1 Q
K A,A1,B
D DATE^RAUTL I RAPOP D Q^RAPRC1 Q
S RAXIT=0 D DISPXAM^RALWKL1(9) I RAXIT D Q^RAPRC1 Q
S ZTDESC="Rad/Nuc Med PROCEDURE WORKLOAD RPT",ZTRTN="START^RAPRC",ZTSAVE("BEGDATE")="",ZTSAVE("ENDDATE")="",ZTSAVE("^TMP($J,""RAPRC"",")="",ZTSAVE("RAITNUM")="",ZTSAVE("RAITYPE")=""
DEV W ! D ZIS^RAUTL I RAPOP D Q^RAPRC1 Q
START ;start processing
U IO K ^TMP($J,"RA") S RABEG=BEGDATE-.0001,RAEND=ENDDATE+.9999,RACRT=9 D CRIT^RAUTL1
S RALP=""
F S RALP=$O(^TMP($J,"RAPRC",RALP)) Q:RALP="" S ^TMP($J,"RA",RALP)="0^0^0"
K RALP
F RADTE=RABEG:0:RAEND S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RAEND) F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0 D RADTI
G ^RAPRC1
;
RADTI F RADTI=0:0 K RAOR,RAPORT S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:RADTI'>0 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,"RAPRC",RADIV))
F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 I $D(^(RACNI,0)) S RAP0=^(0) D CHK:$D(RACRT(+$P(RAP0,"^",3)))
Q
;
CHK Q:$P($G(^RA(72,+$P(RAP0,U,3),0)),U,7)'=RAITNUM
S C=$S($D(^DIC(42,+$P(RAP0,"^",6),0)):"IN",1:"OUT")
F I=0:0 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,+$P(RAP0,"^",2),0)) S RAPRI=^(0),RAPRC=$E($P(RAPRI,"^"),1,30) Q:'$D(^(2)) F I=0:0 S I=$O(^RAMIS(71,+$P(RAP0,"^",2),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)) F I=0:0 S I=$O(RAMIS(I)) Q:I'>0 S RAMIS=RAMIS(I),RAWT=RAWT(I),RAMUL=RAMUL(I) D STORE
K RAMIS,RAWT,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL Q
;
STORE I $D(RAOR) S RANUM=RAMUL,A=25 D AUX K RAFL
I $D(RAPORT) S RANUM=RAMUL,A=26 D AUX K RAFL
I $D(RAMULP) S RANUM=$S($D(RAMULPFL):0,1:1),A="MULP",RAMULPFL="" D AUX
S X=^TMP($J,"RA",RADIV),^(RADIV)=($S(C="IN":$P(X,"^")+($S(RAMUL:RAMUL,1:1)),1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+($S(RAMUL:RAMUL,1:1)),1:$P(X,"^",2)))_"^"_($P(X,"^",3)+(RAMUL*RAWT))
S:'$D(^TMP($J,"RA",RADIV,RAMIS)) ^(RAMIS)="0^0^0" S X=^(RAMIS),^(RAMIS)=($S(C="IN":$P(X,"^")+($S(RAMUL:RAMUL,1:1)),1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+($S(RAMUL:RAMUL,1:1)),1:$P(X,"^",2)))_"^"_($P(X,"^",3)+(RAMUL*RAWT))
S:'$D(^TMP($J,"RA",RADIV,RAMIS,RAPRC)) ^(RAPRC)="0^0^0" S X=^(RAPRC),^(RAPRC)=($S(C="IN":$P(X,"^")+($S(RAMUL:RAMUL,1:1)),1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+($S(RAMUL:RAMUL,1:1)),1:$P(X,"^",2)))_"^"_($P(X,"^",3)+(RAMUL*RAWT))
Q
;
PRC I +RAZ=25 S RAOR="" Q
I +RAZ=26 S RAPORT="" Q
S:$P(RAZ,U,3)="Y" RABILAT="" F J=1:1 I '$D(RAMIS(J)) S RAMIS(J)=$S(RAMJ]"":+RAZ,1:99),RAWT(J)=+$P(RAMJ,U,2),RAMUL(J)=$S(+$P(RAZ,U,2)'="":+$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,A)) ^(A)="0^0^0" S X=^(A),^(A)=($S(C="IN":$P(X,"^")+RANUM,1:$P(X,"^")))_"^"_($S(C="OUT":$P(X,"^",2)+RANUM,1:$P(X,"^",2)))_"^"_($P(X,"^",3)+(RAMUL*RAWT))
S:'$D(^TMP($J,"RA",RADIV,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)+(RAMUL*RAWT))
Q
IT ; select imaging type
D SETUP^RAUTL7A N RAIMGNUM
S X=$O(RACCESS(DUZ,"IMG",0)) I X'>0 S RAITYPE="" Q
S Y=+$O(RACCESS(DUZ,"IMG",X)) I Y'>0 S RAITNUM=X,RAITYPE=$P(^RA(79.2,X,0),U,1) S:RAITNUM]""&(RAITYPE]"") ^TMP($J,"RA I-TYPE",RAITYPE,RAITNUM)="" Q
S RAIMGNUM=$$IMGNUM^RAUTL7A() I RAIMGNUM=1 D SAVEONE^RAPRC1 Q
W ! K DIC S DIC="^RA(79.2,",DIC(0)="AEMQZ",DIC("A")="Select one IMAGING TYPE: ",DIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),$D(RACCESS(DUZ,""IMG"",+Y))" D ^DIC
I Y'>0 S Y=""
S RAITNUM=+Y,RAITYPE=$P(Y,U,2)
K DIC,DTOUT,DUOUT
I RAITNUM]"",RAITYPE]"" S ^TMP($J,"RA I-TYPE",RAITYPE,RAITNUM)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPRC 4545 printed Dec 13, 2024@02:38:45 Page 2
RAPRC ;HISC/FPT AISC/MJK-Radiology Procedure Workload Report ;6/18/97 09:57
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ;
+3 ; called by RA WKLPROCEDURE
+4 ;
+5 KILL ^TMP($JOB,"RA"),^TMP($JOB,"RAPRC"),^TMP($JOB,"DIV-IMG")
+6 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
SET RAPSTX=""
+7 SET X=$$SETUPDI^RAUTL7()
IF X
DO Q^RAPRC1
QUIT
+8 DO SELDIV^RAUTL7
IF '$DATA(^TMP($JOB,"RA D-TYPE"))!($GET(RAQUIT))
DO Q^RAPRC1
QUIT
+9 DO IT
IF RAITYPE=""
DO Q^RAPRC1
QUIT
+10 SET A=""
+11 FOR
SET A=$ORDER(RACCESS(DUZ,"DIV-IMG",A))
if A']""
QUIT
Begin DoDot:1
+12 if '$DATA(^TMP($JOB,"RA D-TYPE",A))
QUIT
SET A1=$ORDER(^TMP($JOB,"RA D-TYPE",A,0))
+13 if A1'>0
QUIT
SET B=""
+14 FOR
SET B=$ORDER(RACCESS(DUZ,"DIV-IMG",A,B))
if B']""
QUIT
Begin DoDot:2
+15 IF B=RAITYPE
SET ^TMP($JOB,"RAPRC",A1)=0
End DoDot:2
End DoDot:1
+16 IF '$DATA(^TMP($JOB,"RAPRC"))
DO Q^RAPRC1
QUIT
+17 KILL A,A1,B
+18 DO DATE^RAUTL
IF RAPOP
DO Q^RAPRC1
QUIT
+19 SET RAXIT=0
DO DISPXAM^RALWKL1(9)
IF RAXIT
DO Q^RAPRC1
QUIT
+20 SET ZTDESC="Rad/Nuc Med PROCEDURE WORKLOAD RPT"
SET ZTRTN="START^RAPRC"
SET ZTSAVE("BEGDATE")=""
SET ZTSAVE("ENDDATE")=""
SET ZTSAVE("^TMP($J,""RAPRC"",")=""
SET ZTSAVE("RAITNUM")=""
SET ZTSAVE("RAITYPE")=""
DEV WRITE !
DO ZIS^RAUTL
IF RAPOP
DO Q^RAPRC1
QUIT
START ;start processing
+1 USE IO
KILL ^TMP($JOB,"RA")
SET RABEG=BEGDATE-.0001
SET RAEND=ENDDATE+.9999
SET RACRT=9
DO CRIT^RAUTL1
+2 SET RALP=""
+3 FOR
SET RALP=$ORDER(^TMP($JOB,"RAPRC",RALP))
if RALP=""
QUIT
SET ^TMP($JOB,"RA",RALP)="0^0^0"
+4 KILL RALP
+5 FOR RADTE=RABEG:0:RAEND
SET RADTE=$ORDER(^RADPT("AR",RADTE))
if RADTE'>0!(RADTE>RAEND)
QUIT
FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
if RADFN'>0
QUIT
DO RADTI
+6 GOTO ^RAPRC1
+7 ;
RADTI FOR RADTI=0:0
KILL RAOR,RAPORT
SET RADTI=$ORDER(^RADPT("AR",RADTE,RADFN,RADTI))
if RADTI'>0
QUIT
IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
SET RAD0=^(0)
DO RACNI
+1 QUIT
RACNI SET RADIV=$PIECE($GET(^RA(79,+$PIECE(RAD0,U,3),0)),U)
SET RADIV=$SELECT($DATA(^DIC(4,+RADIV,0)):+RADIV,1:99)
if '$DATA(^TMP($JOB,"RAPRC",RADIV))
QUIT
+1 FOR RACNI=0:0
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if RACNI'>0
QUIT
IF $DATA(^(RACNI,0))
SET RAP0=^(0)
if $DATA(RACRT(+$PIECE(RAP0,"^",3)))
DO CHK
+2 QUIT
+3 ;
CHK if $PIECE($GET(^RA(72,+$PIECE(RAP0,U,3),0)),U,7)'=RAITNUM
QUIT
+1 SET C=$SELECT($DATA(^DIC(42,+$PIECE(RAP0,"^",6),0)):"IN",1:"OUT")
+2 FOR I=0:0
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)
+3 if '$DATA(^RAMIS(71,+$PIECE(RAP0,"^",2),0))
QUIT
SET RAPRI=^(0)
SET RAPRC=$EXTRACT($PIECE(RAPRI,"^"),1,30)
if '$DATA(^(2))
QUIT
FOR I=0:0
SET I=$ORDER(^RAMIS(71,+$PIECE(RAP0,"^",2),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
+4 if '$DATA(RAMIS(1))
QUIT
FOR I=0:0
SET I=$ORDER(RAMIS(I))
if I'>0
QUIT
SET RAMIS=RAMIS(I)
SET RAWT=RAWT(I)
SET RAMUL=RAMUL(I)
DO STORE
+5 KILL RAMIS,RAWT,RAMUL,RAZ,RAMJ,RAMULP,RAMULPFL
QUIT
+6 ;
STORE IF $DATA(RAOR)
SET RANUM=RAMUL
SET A=25
DO AUX
KILL RAFL
+1 IF $DATA(RAPORT)
SET RANUM=RAMUL
SET A=26
DO AUX
KILL RAFL
+2 IF $DATA(RAMULP)
SET RANUM=$SELECT($DATA(RAMULPFL):0,1:1)
SET A="MULP"
SET RAMULPFL=""
DO AUX
+3 SET X=^TMP($JOB,"RA",RADIV)
SET ^(RADIV)=($SELECT(C="IN":$PIECE(X,"^")+($SELECT(RAMUL:RAMUL,1:1)),1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+($SELECT(RAMUL:RAMUL,1:1)),1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+(RAMUL*RAWT))
+4 if '$DATA(^TMP($JOB,"RA",RADIV,RAMIS))
SET ^(RAMIS)="0^0^0"
SET X=^(RAMIS)
SET ^(RAMIS)=($SELECT(C="IN":$PIECE(X,"^")+($SELECT(RAMUL:RAMUL,1:1)),1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+($SELECT(RAMUL:RAMUL,1:1)),1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+(RAMUL*RAWT))
+5 if '$DATA(^TMP($JOB,"RA",RADIV,RAMIS,RAPRC))
SET ^(RAPRC)="0^0^0"
SET X=^(RAPRC)
SET ^(RAPRC)=($SELECT(C="IN":$PIECE(X,"^")+($SELECT(RAMUL:RAMUL,1:1)),1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+($SELECT(RAMUL:RAMUL,1:1)),1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+(RAMUL*RAWT))
+6 QUIT
+7 ;
PRC IF +RAZ=25
SET RAOR=""
QUIT
+1 IF +RAZ=26
SET RAPORT=""
QUIT
+2 if $PIECE(RAZ,U,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,U,2)
SET RAMUL(J)=$SELECT(+$PIECE(RAZ,U,2)'="":+$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,A))
SET ^(A)="0^0^0"
SET X=^(A)
SET ^(A)=($SELECT(C="IN":$PIECE(X,"^")+RANUM,1:$PIECE(X,"^")))_"^"_($SELECT(C="OUT":$PIECE(X,"^",2)+RANUM,1:$PIECE(X,"^",2)))_"^"_($PIECE(X,"^",3)+(RAMUL*RAWT))
+1 if '$DATA(^TMP($JOB,"RA",RADIV,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)+(RAMUL*RAWT))
+2 QUIT
IT ; select imaging type
+1 DO SETUP^RAUTL7A
NEW RAIMGNUM
+2 SET X=$ORDER(RACCESS(DUZ,"IMG",0))
IF X'>0
SET RAITYPE=""
QUIT
+3 SET Y=+$ORDER(RACCESS(DUZ,"IMG",X))
IF Y'>0
SET RAITNUM=X
SET RAITYPE=$PIECE(^RA(79.2,X,0),U,1)
if RAITNUM]""&(RAITYPE]"")
SET ^TMP($JOB,"RA I-TYPE",RAITYPE,RAITNUM)=""
QUIT
+4 SET RAIMGNUM=$$IMGNUM^RAUTL7A()
IF RAIMGNUM=1
DO SAVEONE^RAPRC1
QUIT
+5 WRITE !
KILL DIC
SET DIC="^RA(79.2,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select one IMAGING TYPE: "
SET DIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),$D(RACCESS(DUZ,""IMG"",+Y))"
DO ^DIC
+6 IF Y'>0
SET Y=""
+7 SET RAITNUM=+Y
SET RAITYPE=$PIECE(Y,U,2)
+8 KILL DIC,DTOUT,DUOUT
+9 IF RAITNUM]""
IF RAITYPE]""
SET ^TMP($JOB,"RA I-TYPE",RAITYPE,RAITNUM)=""
+10 QUIT
