RAFLM ;HISC/GJC AISC/MJK,RMO-Film Usage Report ;4/17/96 10:15
;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998
;
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
;
SUM W !!,"Film Usage Report",!,"-----------------" K RAFL1
ASKSUM W ! K DIR S DIR(0)="Y",DIR("A")="Do you wish only the summary report",DIR("B")="NO",DIR("?")="Enter YES for a summary report or NO for a detailed report"
D ^DIR K DIR I $D(DIRUT) D Q^RAFLM2 Q
S:Y=0 RAFL1=""
K DIROUT,DIRUT,DTOUT,DUOUT
S X=$$DIVLOC^RAUTL7() I X D Q^RAFLM2 Q
S A="",RATITLE="Film"
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 $D(^TMP($J,"RA I-TYPE",B)) D IT^RALWKL2 I B1?3AP1"-".N S ^TMP($J,"RAFLM",A1,B1)=0
.. Q
. Q
K A,A1,B,B1,RACCESS(DUZ,"DIV-IMG")
S RAINPUT=$$ALLNOTH^RALWKL3() I RAINPUT="" D Q^RAFLM2 Q
I RAINPUT=0 D FILM I RAQUIT=1 D Q^RAFLM2 Q
I RAINPUT=0 S RAFLDCNT=0,RALP="" F S RALP=$O(^TMP($J,"RAFILM",RALP)) Q:RALP="" S RAFLDCNT=RAFLDCNT+1
K RALP
D DATE^RAUTL I RAPOP D Q^RAFLM2 Q
S RAXIT=0 D DISPXAM^RALWKL1(6) I RAXIT D Q^RAFLM2 Q
S ZTDESC="Rad/Nuc Med FILM USAGE RPT",ZTRTN="START^RAFLM",ZTSAVE("^TMP($J,""RAFILM"",")="",ZTSAVE("^TMP($J,""RAFLM"",")="" S:$D(RAFL1) ZTSAVE("RAFL1")=""
F RASV="BEGDATE","ENDDATE","RAFLDCNT","RAINPUT" S ZTSAVE(RASV)=""
DEV W ! D ZIS^RAUTL I RAPOP D Q^RAFLM2 Q
START ; start processing
U IO K ^TMP($J,"RA") S RABEG=BEGDATE-.0001,RAEND=ENDDATE+.9999,RACRT=6 D CRIT^RAUTL1 S RACPT=""
S:$D(ZTQUEUED) ZTREQ="@"
S RAITCNT=0,RALP="",RAEOS=0
F S RALP=$O(^TMP($J,"RAFLM",RALP)) Q:RALP="" S RAITCNT(RALP)=0,^TMP($J,"RA",RALP)="0^0" S RALP1="" F S RALP1=$O(^TMP($J,"RAFLM",RALP,RALP1)) Q:RALP1="" S RAITCNT(RALP)=RAITCNT(RALP)+1,^TMP($J,"RA",RALP,RALP1)="0^0"
K RALP,RALP1
F RADTE=RABEG:0:RAEND S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RAEND)!(RAEOS) F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0 D RADTI^RAFLM1 Q:RAEOS
G:'RAEOS ^RAFLM2
Q
FILM ; select films to include in report
K ^TMP($J,"RAFILM")
S RAONECHK=$P(^RA(78.4,0),U,4) I RAONECHK=1 S RAIEN=$O(^RA(78.4,0)) Q:RAIEN<1 S RAONENME=$P(^RA(78.4,+RAIEN,0),U,1),RAONENME=$E(RAONENME,1,30),^TMP($J,"RAFILM",RAONENME)="" D KILL Q
S RADIC="^RA(78.4,",RADIC(0)="QEAMZ",RADIC("A")="Select "_RATITLE_": ",RAUTIL="RAFILM"
S RADIC("S")="I '$P(^(0),U,4)"
D EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
KILL ;
K %W,%Y1,DIC,RACNT,RADIC,RAIEN,RAONECHK,RAONENME,RAUTIL,X,Y
Q
CPT ;
Q:'$P(RAPRI,"^",9) S RACPT=+$P(RAPRI,"^",9)
S RACPT=$$NAMCODE^RACPTMSC(RACPT,DT),RACPT=$P(RACPT,"^")
Q:RACPT=""
S RAPRC=RAPRC_"("_RACPT_")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAFLM 2723 printed Dec 13, 2024@02:35:10 Page 2
RAFLM ;HISC/GJC AISC/MJK,RMO-Film Usage Report ;4/17/96 10:15
+1 ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998
+2 ;
+3 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
SET RAPSTX=""
+4 ;
SUM WRITE !!,"Film Usage Report",!,"-----------------"
KILL RAFL1
ASKSUM WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you wish only the summary report"
SET DIR("B")="NO"
SET DIR("?")="Enter YES for a summary report or NO for a detailed report"
+1 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO Q^RAFLM2
QUIT
+2 if Y=0
SET RAFL1=""
+3 KILL DIROUT,DIRUT,DTOUT,DUOUT
+4 SET X=$$DIVLOC^RAUTL7()
IF X
DO Q^RAFLM2
QUIT
+5 SET A=""
SET RATITLE="Film"
+6 FOR
SET A=$ORDER(RACCESS(DUZ,"DIV-IMG",A))
if A']""
QUIT
Begin DoDot:1
+7 if '$DATA(^TMP($JOB,"RA D-TYPE",A))
QUIT
SET A1=$ORDER(^TMP($JOB,"RA D-TYPE",A,0))
+8 if A1'>0
QUIT
SET B=""
+9 FOR
SET B=$ORDER(RACCESS(DUZ,"DIV-IMG",A,B))
if B']""
QUIT
Begin DoDot:2
+10 IF $DATA(^TMP($JOB,"RA I-TYPE",B))
DO IT^RALWKL2
IF B1?3AP1"-".N
SET ^TMP($JOB,"RAFLM",A1,B1)=0
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 KILL A,A1,B,B1,RACCESS(DUZ,"DIV-IMG")
+14 SET RAINPUT=$$ALLNOTH^RALWKL3()
IF RAINPUT=""
DO Q^RAFLM2
QUIT
+15 IF RAINPUT=0
DO FILM
IF RAQUIT=1
DO Q^RAFLM2
QUIT
+16 IF RAINPUT=0
SET RAFLDCNT=0
SET RALP=""
FOR
SET RALP=$ORDER(^TMP($JOB,"RAFILM",RALP))
if RALP=""
QUIT
SET RAFLDCNT=RAFLDCNT+1
+17 KILL RALP
+18 DO DATE^RAUTL
IF RAPOP
DO Q^RAFLM2
QUIT
+19 SET RAXIT=0
DO DISPXAM^RALWKL1(6)
IF RAXIT
DO Q^RAFLM2
QUIT
+20 SET ZTDESC="Rad/Nuc Med FILM USAGE RPT"
SET ZTRTN="START^RAFLM"
SET ZTSAVE("^TMP($J,""RAFILM"",")=""
SET ZTSAVE("^TMP($J,""RAFLM"",")=""
if $DATA(RAFL1)
SET ZTSAVE("RAFL1")=""
+21 FOR RASV="BEGDATE","ENDDATE","RAFLDCNT","RAINPUT"
SET ZTSAVE(RASV)=""
DEV WRITE !
DO ZIS^RAUTL
IF RAPOP
DO Q^RAFLM2
QUIT
START ; start processing
+1 USE IO
KILL ^TMP($JOB,"RA")
SET RABEG=BEGDATE-.0001
SET RAEND=ENDDATE+.9999
SET RACRT=6
DO CRIT^RAUTL1
SET RACPT=""
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 SET RAITCNT=0
SET RALP=""
SET RAEOS=0
+4 FOR
SET RALP=$ORDER(^TMP($JOB,"RAFLM",RALP))
if RALP=""
QUIT
SET RAITCNT(RALP)=0
SET ^TMP($JOB,"RA",RALP)="0^0"
SET RALP1=""
FOR
SET RALP1=$ORDER(^TMP($JOB,"RAFLM",RALP,RALP1))
if RALP1=""
QUIT
SET RAITCNT(RALP)=RAITCNT(RALP)+1
SET ^TMP($JOB,"RA",RALP,RALP1)="0^0"
+5 KILL RALP,RALP1
+6 FOR RADTE=RABEG:0:RAEND
SET RADTE=$ORDER(^RADPT("AR",RADTE))
if RADTE'>0!(RADTE>RAEND)!(RAEOS)
QUIT
FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
if RADFN'>0
QUIT
DO RADTI^RAFLM1
if RAEOS
QUIT
+7 if 'RAEOS
GOTO ^RAFLM2
+8 QUIT
FILM ; select films to include in report
+1 KILL ^TMP($JOB,"RAFILM")
+2 SET RAONECHK=$PIECE(^RA(78.4,0),U,4)
IF RAONECHK=1
SET RAIEN=$ORDER(^RA(78.4,0))
if RAIEN<1
QUIT
SET RAONENME=$PIECE(^RA(78.4,+RAIEN,0),U,1)
SET RAONENME=$EXTRACT(RAONENME,1,30)
SET ^TMP($JOB,"RAFILM",RAONENME)=""
DO KILL
QUIT
+3 SET RADIC="^RA(78.4,"
SET RADIC(0)="QEAMZ"
SET RADIC("A")="Select "_RATITLE_": "
SET RAUTIL="RAFILM"
+4 SET RADIC("S")="I '$P(^(0),U,4)"
+5 DO EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
KILL ;
+1 KILL %W,%Y1,DIC,RACNT,RADIC,RAIEN,RAONECHK,RAONENME,RAUTIL,X,Y
+2 QUIT
CPT ;
+1 if '$PIECE(RAPRI,"^",9)
QUIT
SET RACPT=+$PIECE(RAPRI,"^",9)
+2 SET RACPT=$$NAMCODE^RACPTMSC(RACPT,DT)
SET RACPT=$PIECE(RACPT,"^")
+3 if RACPT=""
QUIT
+4 SET RAPRC=RAPRC_"("_RACPT_")"
+5 QUIT
