- 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 Feb 19, 2025@00:05:01 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